sunet/ls.scm

; ls clone in scsh

; Mike Sperber <sperber@informatik.uni-tuebingen.de>
; Copyright (c) 1998 Michael Sperber.

; This currently does a whole bunch of stats on every file in some
; cases.  In a decent OS implementation, this stuff is cached, so
; there isn't any problem, at least not in theory :-)

; FLAGS is a list of symbols from:
;
; all        - include stuff starting with "."
; recursive  - guess what
; long       - output interesting information per file
; directory  - display only the information for the directory named
; flag       - flag files as per their types
; columns    - sorts output vertically in a multicolumn format

(define (ls flags paths . maybe-port)
  (let* ((port (optional maybe-port (current-output-port)))
	 (paths (if (null? paths)
		    (list (cwd))
		    paths))
	 (only-one? (null? (cdr paths))))
    (call-with-values
     (lambda () (parse-flags flags))
     (lambda (all? recursive? long? directory? flag? columns?)
       (real-ls paths
		(if only-one? #f "")
		all? recursive? long? directory? flag? columns?
		port)))))

(define (parse-flags flags)
  (let ((all? (memq 'all flags))
	(recursive? (memq 'recursive flags))
	(long? (memq 'long flags))
	(directory? (memq 'directory flags))
	(flag? (memq 'flag flags))
	(columns? (memq 'columns flags)))
    (values all? recursive? long? directory? flag? columns?)))

(define (real-ls paths prefix
		 all? recursive? long? directory? flag? columns?
		 port)
  (let ((first #t))
    (for-each
     (lambda (path)
       (if first
	   (set! first #f)
	   (newline port))
       (if prefix
	   (format port "~A~A:~%" prefix path))
       (ls-path path all? recursive? long? directory? flag? columns? port))
     paths)))

(define (ls-path path all? recursive? long? directory? flag? columns? port)
  (cond
   ((and (not directory?)
	 (or (and (file-name-directory? path)
		  (file-directory? path #t))
	     (file-directory? path #f)))
    (ls-directory path all? recursive? long? directory? flag? columns? port))
   (else
    (ls-file path long? flag? port))))

(define (ls-directory directory all? recursive? long? directory? flag? columns? port)
  (let* ((directory (file-name-as-directory directory))
	 (substantial-directory (string-append directory "."))
	 (files (directory-files substantial-directory all?)))
    (with-cwd*
     substantial-directory
     (lambda ()
       (if (and (not long?)
		columns?)
	   (ls-files-columns files flag? port)
	   (ls-files-column files long? flag? port))
       
       (if recursive?
	   (let ((directories
		  (map (lambda (file-name)
			 (string-append directory file-name))
		       (filter (lambda (file)
				 (file-directory? file #f))
			       files))))
	     (if (not (null? directories))
		 (begin
		   (newline port)
		   (real-ls directories directory
			    all? recursive? long? directory? flag? columns?
			    port)))))))))

(define *width* 79)

(define (ls-files-columns files flag? port)
  (let* ((max-file-name-width
	  (if (null? files)
	      0
	      (apply max (map string-length files))))
	 (max-file-name-width
	  (if flag?
	      (+ 1 max-file-name-width)
	      max-file-name-width))

	 (column-width (+ 2 max-file-name-width))

	 (columns (quotient *width*
			    column-width))
	 (columns (if (zero? columns)
		      1
		      columns))

	 (number-of-files (length files))
	 (rows (quotient (+ number-of-files (- columns 1))
			 columns))

	 (tails
	  (do ((column 0 (+ 1 column))
	       (tails (make-vector columns)))
	      ((= column columns)
	       tails)
	    (vector-set! tails column
			 (list-tail-or-null files (* rows column))))))

    (do ((row 0 (+ 1 row)))
	((= row rows))
      (do ((column 0 (+ 1 column)))
	  ((= column columns))
	(let ((tail (vector-ref tails column)))
	  (if (not (null? tail))
	      (let ((width (display-file (car tail) flag? port)))
		(display-spaces (- column-width width) port)
		(vector-set! tails column (cdr tail))))))
      (newline port))))

(define (list-tail-or-null list index)
  (let loop ((list list) (index index))
    (cond
     ((null? list) list)
     ((zero? index) list)
     (else (loop (cdr list) (- index 1))))))

(define (ls-files-column files long? flag? port)
  (for-each
   (lambda (file)
     (ls-file file long? flag? port))
   files))

(define (ls-file file-name long? flag? port)
  (if long?
      (ls-file-long file-name flag? port)
      (ls-file-short file-name flag? port)))

(define (ls-file-short file-name flag? port)
  (display-file file-name flag? port)
  (newline port))

(define (ls-file-long file-name flag? port)
  (let ((info (file-info file-name #f)))
    (display-permissions info port)
    (display-decimal-justified (file-info:nlinks info) 4 port)
    (write-char #\space port)
    (let* ((uid (file-info:uid info))
	   (user-name
	    (call-with-current-continuation
	     (lambda (escape)
	       (with-handler
		(lambda (condition more)
		  (escape (number->string uid)))
		(lambda ()
		  (user-info:name (user-info uid))))))))
      (display-padded user-name 9 port))
    (let* ((gid (file-info:gid info))
	   (group-name
	    (call-with-current-continuation
	     (lambda (escape)
	       (with-handler
		(lambda (condition more)
		  (escape (number->string gid)))
		(lambda ()
		  (group-info:name (group-info gid))))))))
      (display-padded group-name 9 port))
    (display-decimal-justified (file-info:size info) 7 port)
    (write-char #\space port)
    (display-time  (file-info:mtime info) port)
    (write-char #\space port)
    (display-file file-name flag? port)
    (if (file-symlink? file-name)
	(begin
	  (display " -> " port)
	  (display (read-symlink file-name) port)))
    (newline port)))

(define *year-seconds* (* 365 24 60 60))

(define (display-time the-time port)
  (let ((time-difference (abs (- (time) the-time)))
	(date (date the-time 0)))
    (if (< time-difference *year-seconds*)
	(display (format-date "~b ~d ~H:~M" date) port)
	(display (format-date "~b ~d ~Y " date) port))))

(define (display-file file-name flag? port)
  (display file-name port)
  (if (maybe-display-flag file-name flag? port)
      (+ 1 (string-length file-name))
      (string-length file-name)))

(define (maybe-display-flag file-name flag? port)
  (if (not (and flag?
		(not (file-regular? file-name))))
      #f
      (begin
	(cond
	 ((file-directory? file-name)
	  (write-char #\/ port))
	 ((file-symlink? file-name)
	  (write-char #\@ port))
	 ((file-executable? file-name)
	  (write-char #\* port))
	 ((file-socket? file-name)
	  (write-char #\= port))
	 ((file-fifo? file-name)
	  (write-char #\| port)))
	#t)))

(define (display-permissions info port)
  (case (file-info:type info)
    ((directory)
     (write-char #\d port))
    ((symlink)
     (write-char #\l port))
    (else
     (write-char #\- port)))
  (let ((mode (file-info:mode info))
	(bit 8))
    (for-each
     (lambda (id)
       (if (not (zero? (bitwise-and (arithmetic-shift 1 bit)
				    mode)))
	   (write-char id port)
	   (write-char #\- port))
       (set! bit (- bit 1)))
     '(#\r #\w #\x #\r #\w #\x #\r #\w #\x))))

(define (display-decimal-justified number width port)
  (display-justified (number->string number) width port))

(define (display-justified string width port)
  (let ((length (string-length string)))
    (if (< length width)
	(display-spaces (- width length) port))
    (display string port)))

(define (display-padded string width port)
  (let ((length (string-length string)))
    (display string port)
    (if (< length width)
	(display-spaces (- width length) port))))

(define (display-spaces number port)
  (do ((i 0 (+ 1 i)))
      ((= i number))
    (write-char #\space port)))

;; Convert Unix-style arguments to flags suitable for LS.

(define (arguments->ls-flags args)
  (let loop ((args args) (flags '()))
    (if (null? args)
	flags
	(cond
	 ((argument->ls-flags (car args))
	  => (lambda (new-flags)
	       (loop (cdr args) (append new-flags flags))))
	 (else #f)))))

(define (argument->ls-flags arg)
  (let ((arg (if (symbol? arg)
		 (symbol->string arg)
		 arg)))
    (if (or (string=? "" arg)
	    (not (char=? #\- (string-ref arg 0))))
	#f
	(let loop ((chars (cdr (string->list arg))) (flags '()))
	  (cond
	   ((null? chars)
	    flags)
	   ((char->flag (car chars))
	    => (lambda (flag)
		 (loop (cdr chars) (cons flag flags))))
	   (else #f))))))

(define (char->flag char)
  (case char
    ((#\a) 'all)
    ((#\R) 'recursive)
    ((#\l) 'long)
    ((#\d) 'directory)
    ((#\F) 'flag)
    ((#\C) 'columns)
    (else #f)))

(define (optional maybe-arg default-exp)
  (cond
   ((null? maybe-arg) default-exp)
   ((null? (cdr maybe-arg)) (car maybe-arg))
   (else (error "too many optional arguments" maybe-arg))))