ls.scm

#! /usr/local/bin/guile -s
!#

(use-modules (srfi srfi-1)  ; fold, map etc
	     (srfi srfi-26) ; cut (partial application)
	     (srfi srfi-37) ; args-fold
	     (ice-9 ftw)
	     (ice-9 format)
	     (ice-9 i18n))

(define path-separator "/")

(define (path-append path name) (string-append path path-separator name))

(define perror (cut format (current-error-port) <...>))

(define (string-starts-with? s c) (eq? c (string-ref s 0)))

(define (default-printer path st . rest)
  (format #t "~a~%" (basename path)))

(define* (long-printer path st #:optional
		       (max-nlinks 0) (max-size 0)
		       (max-uname-length 0) (max-groupname-length 0))
  (let*
      ((bits-set?
	(lambda (bits . masks)
	  (let ((mask (fold logior 0 masks)))
	    (eq? mask (logand bits mask)))))
       (permission-string
	(lambda (perms)
	  (let* ((setuid-bit      #o4000)
		 (setgid-bit      #o2000)
		 (sticky-bit      #o1000)
		 (owner-read-bit  #o400)
		 (owner-write-bit #o200)
		 (owner-exec-bit  #o100)
		 (group-read-bit  #o40)
		 (group-write-bit #o20)
		 (group-exec-bit  #o10)
		 (other-read-bit  #o4)
		 (other-write-bit #o2)
		 (other-exec-bit  #o1)
		 (rwx-letter   (lambda (bit letter)
				 (if (bits-set? perms bit) letter #\-)))
		 (setid-letter (lambda (exec-bit setid-bit letter)
				 (cond ((bits-set? perms exec-bit setid-bit) letter)
				       ((bits-set? perms setid-bit)
					(char-downcase letter))
				       (else (rwx-letter exec-bit #\x))))))
	    (string (rwx-letter    owner-read-bit #\r)
		    (rwx-letter    owner-write-bit #\w)
		    (setid-letter  owner-exec-bit setuid-bit #\S)
		    (rwx-letter    group-read-bit #\r)
		    (rwx-letter    group-write-bit #\w)
		    (setid-letter  group-exec-bit setgid-bit #\S)
		    (rwx-letter    other-read-bit #\r)
		    (rwx-letter    other-write-bit #\w)
		    (setid-letter  other-exec-bit sticky-bit #\T)))))
       (format-time
	(lambda (time)
	  (if (and (<= time (current-time))
		   (< (- (current-time) time) (* 3600 24 30 6)))
	      (strftime "%b %e %H:%M" (localtime time))
	      (strftime "%b %e %_5Y" (localtime time)))))
       (type (case (stat:type st)
	       ((directory) #\d)
	       ((regular) #\-)
	       ((symlink) #\l)
	       ((block-special) #\b)
	       ((char-special) #\c)
	       ((fifo) #\p)
	       (else #\?)))
       (digits (lambda (n) (if (eq? n 0) 0 (1+ (ceiling (log10 n)))))))
    (format #t "~a~a ~vd ~va ~va ~vd ~a ~a\n"
	    type
	    (permission-string (stat:perms st))
	    (digits max-nlinks) (stat:nlink st)
	    max-uname-length (passwd:name (getpwuid (stat:uid st)))
	    max-groupname-length (group:name (getgrgid (stat:gid st)))
	    (digits max-size) (stat:size st)
	    (format-time (stat:mtime st))
	    (if (eq? type #\l) (format #f "~a -> ~a"
				       path (readlink path)) (basename path)))))

(define (ls-dir dir-name dir-stat recursive? all? print-header? printer)
  (let* ((not-hidden? (lambda (name) (not (string-starts-with? name #\.))))
	 (enter? (lambda (path st)
		   (or (and (or all? (not-hidden? (basename path))) recursive?)
		       (eq? (stat:ino st) (stat:ino dir-stat))))))
    (let recurse ((tree (file-system-tree dir-name enter?))
		  (parent-path `(,(dirname dir-name)))
		  (top-level? #t))
      ;; `file-system-tree' returns a structure of the form
      ;; (string basename, object stat, tree children)
      (let* ((path (cons (car tree) parent-path))
	     (path-string (string-join (reverse path) path-separator))
	     (children
	      (filter
	       (lambda (tree) (or all? (not-hidden? (car tree))))
	       (sort (let ((current-dir-path (path-append path-string "."))
			   (parent-dir-path (path-append path-string "..")))
		       (cons (list current-dir-path (lstat current-dir-path))
			     (cons (list parent-dir-path (lstat parent-dir-path))
				   (cddr tree))))
		     (lambda (a b) (string-locale-ci<? (car a) (car b))))))
	     ;; `max' throws an error if called without arguments;
	     ;; `max-above-0' just returns 0
	     (max-above-0 (lambda args (apply max (cons 0 args))))
	     (stats (map cadr children))
	     (max-nlinks (apply max-above-0 (map stat:nlink stats)))
	     (max-size (apply max-above-0 (map stat:size stats)))
	     (max-uname-length
	      (apply max-above-0 (map (compose string-length passwd:name
					       getpwuid stat:uid) stats)))
	     (max-groupname-length
	      (apply max-above-0 (map (compose string-length group:name
					       getgrgid stat:gid) stats))))
	(if (or (not top-level?) print-header?) (format #t "~a:~%" path-string))
	(for-each (lambda (child)
		    (printer
		     (path-append path-string (car child))
		     (cadr child)
		     max-nlinks max-size max-uname-length max-groupname-length))
		  children)
	(if recursive?
	    (for-each (lambda (child)
			(if (and (eq? (stat:type (cadr child)) 'directory)
				 (not (or (equal? (basename (car child)) ".")
					  (equal? (basename (car child)) ".."))))
			    (recurse child path #f)))
		      children))))))

(let* ((program-name (car (program-arguments)))
       (make-bool-option
	(lambda (opt-name flag)
	  (option `(,flag) #f #f (lambda (opt name arg result)
				   (acons opt-name #t result)))))
       ;; `getopt-long' requires the long option name to be provided,
       ;; but the real `ls' does not use long names. srfi-37 does not
       ;; have this restriction, so we use it instead.
       (args (args-fold
	      (cdr (program-arguments))
	      (map make-bool-option '(all? recursive? long?) '(#\a #\R #\l))
	      (lambda (opt name arg result)
		(perror "~a: illegal option -- ~a~%" program-name name)
		(perror "usage: ~a [-alR] [file ...]~%" program-name)
		(exit 1))
	      (lambda (opt result) (assq-set! result
					      'paths
					      (cons opt (assq-ref result 'paths))))
	      '((paths))))
       (paths (if (null? (assq-ref args 'paths)) '(".") (assq-ref args 'paths)))
       (printer (if (assq-ref args 'long?) long-printer default-printer))
       (abs-path? (lambda (path) (string-starts-with? path #\/)))
       (ls-dir-cut (cut ls-dir <> <>
			(assq-ref args 'recursive?) (assq-ref args 'all?)
			(> (length paths) 1)
			printer))
       (exit-code 0))
  (for-each
   (lambda (path)
     (catch 'system-error
       (lambda ()
	 (let ((st (lstat path)))
	   (case (stat:type st)
	     ((directory) (ls-dir-cut path st))
	     ((symlink) (if (assq-ref args 'long?)
			    (printer path st)
			    (ls-dir-cut
			     (let ((linked-path (readlink path)))
			       (if (abs-path? linked-path)
				   (linked-path)
				   (path-append (dirname path)
						linked-path)))
			     (stat path))))
	     (else (printer path st)))))
       (lambda args
	 (perror "~a: ~a: ~a~%"
		 program-name path (strerror (system-error-errno args)))
	 (set! exit-code 1)))) paths)
  (exit exit-code))

path-separator -- should use undocumented path-separator-string
path-append can be replaced with the undocumented in-vicinity
r6rs says eqv? should be used for equivalence of chars
r6rs says eqv? should be used for equivalence of numbers
string-start-with? -- check if string-prefix? is faster
(fold logior 0 masks) ≟ (apply logior masks)
abs-path? -- should use undocumented absolute-path?