342 lines
10 KiB
Scheme
342 lines
10 KiB
Scheme
; ls clone in scsh
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; Copyright (c) 1998 Michael Sperber.
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
; 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-crlf? (make-fluid #f))
|
|
|
|
(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)
|
|
(ls-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?) ;; go into directories
|
|
(or (and (file-name-directory? path) ;; path specifies directory
|
|
(file-directory? path #t)) ;; either as a symlink (if the names end with a slash)
|
|
(file-directory? path #f))) ;; or not
|
|
(ls-directory path all? recursive? long? directory? flag? columns? port))
|
|
(else
|
|
(if (or long? flag?) ;; see LS-DIRECTORY for details
|
|
(ls-file (cons path (file-info path #f)) long? flag? port)
|
|
(ls-file (cons path #f) long? flag? port)))))
|
|
|
|
(define (ls-directory directory all? recursive? long? directory? flag? columns? port)
|
|
; terminology: a FILE-NAME is the name of a file
|
|
; a FILE is a pair whose car is a file-name and whose cdr is
|
|
; either its file-info-object or #f (if not needed)
|
|
; a INFO is a file-info-object
|
|
|
|
;; This is actually a hack for the benefits of systems using AFS,
|
|
;; mainly to enable anonymous-upload directories: We don't list
|
|
;; a directory unless the Unix permissions would allow us to.
|
|
(if (not (file-readable? directory))
|
|
(errno-error errno/perm directory-files directory))
|
|
|
|
(let* ((directory (file-name-as-directory directory))
|
|
(substantial-directory (string-append directory "."))
|
|
(file-names (directory-files substantial-directory all?)))
|
|
(with-cwd*
|
|
substantial-directory
|
|
(lambda ()
|
|
(let ((files (if (or recursive? long? flag?) ; these are the flags for which we need the file-info
|
|
(map (lambda (file-name)
|
|
(cons file-name (file-info file-name #f)))
|
|
file-names)
|
|
(map (lambda (file-name) (cons file-name #f))
|
|
file-names))))
|
|
|
|
(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) (car file))
|
|
(filter (lambda (file)
|
|
(eq? (file-info:type (cdr file)) 'directory))
|
|
files))))
|
|
(if (not (null? directories))
|
|
(begin
|
|
(ls-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 (lambda (file) (string-length (car file))) 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* ((file (car tail))
|
|
(width (display-file file flag? port)))
|
|
(display-spaces (- column-width width) port)
|
|
(vector-set! tails column (cdr tail))))))
|
|
(ls-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 long? flag? port)
|
|
(if long?
|
|
(ls-file-long file flag? port)
|
|
(ls-file-short file flag? port)))
|
|
|
|
(define (ls-file-short file flag? port)
|
|
(display-file file flag? port)
|
|
(ls-newline port))
|
|
|
|
(define (ls-file-long file flag? port)
|
|
(let ((info (cdr file)))
|
|
(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 flag? port)
|
|
(if (eq? (file-info:type info) 'symlink)
|
|
(begin
|
|
(display " -> " port)
|
|
(display (read-symlink (car file)) port)))
|
|
(ls-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 flag? port)
|
|
(let ((file-name (car file)))
|
|
(display file-name port)
|
|
(if (maybe-display-flag (cdr file) flag? port)
|
|
(+ 1 (string-length file-name))
|
|
(string-length file-name))))
|
|
|
|
(define (maybe-display-flag info flag? port)
|
|
(and flag?
|
|
(begin
|
|
(cond
|
|
((eq? (file-info:type info) 'directory)
|
|
(write-char #\/ port))
|
|
((eq? (file-info:type info) 'symlink)
|
|
(write-char #\@ port))
|
|
; 'executable: bits 0, 3 or 6 are set:
|
|
; that means, 'AND' with 1+8+64=73 results in a nonzero-value
|
|
; note: there is no distinction between user's, group's and other's permissions
|
|
; (as the real GNU-ls does not)
|
|
((not (zero? (bitwise-and (file-info:mode info) 73)))
|
|
(write-char #\* port))
|
|
((eq? (file-info:type info) 'socket)
|
|
(write-char #\= port))
|
|
((eq? (file-info:type info) 'fifo)
|
|
(write-char #\| port)))
|
|
#t)))
|
|
|
|
(define (display-permissions info port)
|
|
(case (file-info:type info)
|
|
((directory)
|
|
(write-char #\d port))
|
|
((symlink)
|
|
(write-char #\l port))
|
|
((fifo)
|
|
(write-char #\p 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))))
|
|
|
|
(define (ls-newline port)
|
|
(if (fluid ls-crlf?)
|
|
(write-crlf port)
|
|
(newline port))) |