scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

changes made to 

* avoid too many STAT-calls
* show executable-flag (*) for regular files
This commit is contained in:
interp 2001-09-07 15:08:37 +00:00
parent 669e5ab4a8
commit a9a269043f
1 changed files with 58 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
ls.scm
View File

@ -55,15 +55,16 @@
(define (ls-path path all? recursive? long? directory? flag? columns? port) (define (ls-path path all? recursive? long? directory? flag? columns? port)
(cond (cond
((and (not directory?) ((and (not directory?) ;; go into directories
(or (and (file-name-directory? path) (or (and (file-name-directory? path) ;; path specifies directory
(file-directory? path #t)) (file-directory? path #t)) ;; either as a symlink (if the names end with a slash)
(file-directory? path #f))) (file-directory? path #f))) ;; or not
(ls-directory path all? recursive? long? directory? flag? columns? port)) (ls-directory path all? recursive? long? directory? flag? columns? port))
(else (else
(ls-file path long? flag? port)))) (ls-file path long? flag? port))))
(define (ls-directory directory all? recursive? long? directory? flag? columns? port) (define (ls-directory directory all? recursive? long? directory? flag? columns? port)
; (display (list "starting ls-directory:" directory)) (newline)
(let* ((directory (file-name-as-directory directory)) (let* ((directory (file-name-as-directory directory))
(substantial-directory (string-append directory ".")) (substantial-directory (string-append directory "."))
(files (directory-files substantial-directory all?))) (files (directory-files substantial-directory all?)))
@ -146,49 +147,49 @@
files)) files))
(define (ls-file file-name long? flag? port) (define (ls-file file-name long? flag? port)
(if long? (let ((info (file-info file-name #f)))
(ls-file-long file-name flag? port) (if long?
(ls-file-short file-name flag? port))) (ls-file-long file-name info flag? port)
(ls-file-short file-name info flag? port))))
(define (ls-file-short file-name flag? port) (define (ls-file-short file-name info flag? port)
(display-file file-name flag? port) (display-file file-name info flag? port)
(newline port)) (newline port))
(define (ls-file-long file-name flag? port) (define (ls-file-long file-name info flag? port)
(let ((info (file-info file-name #f))) (display-permissions info port)
(display-permissions info port) (display-decimal-justified (file-info:nlinks info) 4 port)
(display-decimal-justified (file-info:nlinks info) 4 port) (write-char #\space port)
(write-char #\space port) (let* ((uid (file-info:uid info))
(let* ((uid (file-info:uid info)) (user-name
(user-name (call-with-current-continuation
(call-with-current-continuation (lambda (escape)
(lambda (escape) (with-handler
(with-handler (lambda (condition more)
(lambda (condition more) (escape (number->string uid)))
(escape (number->string uid))) (lambda ()
(lambda () (user-info:name (user-info uid))))))))
(user-info:name (user-info uid)))))))) (display-padded user-name 9 port))
(display-padded user-name 9 port)) (let* ((gid (file-info:gid info))
(let* ((gid (file-info:gid info)) (group-name
(group-name (call-with-current-continuation
(call-with-current-continuation (lambda (escape)
(lambda (escape) (with-handler
(with-handler (lambda (condition more)
(lambda (condition more) (escape (number->string gid)))
(escape (number->string gid))) (lambda ()
(lambda () (group-info:name (group-info gid))))))))
(group-info:name (group-info gid)))))))) (display-padded group-name 9 port))
(display-padded group-name 9 port)) (display-decimal-justified (file-info:size info) 7 port)
(display-decimal-justified (file-info:size info) 7 port) (write-char #\space port)
(write-char #\space port) (display-time (file-info:mtime info) port)
(display-time (file-info:mtime info) port) (write-char #\space port)
(write-char #\space port) (display-file file-name info flag? port)
(display-file file-name flag? port) (if (eq? (file-info:type info) 'symlink)
(if (file-symlink? file-name) (begin
(begin (display " -> " port)
(display " -> " port) (display (read-symlink file-name) port)))
(display (read-symlink file-name) port))) (newline port))
(newline port)))
(define *year-seconds* (* 365 24 60 60)) (define *year-seconds* (* 365 24 60 60))
@ -199,27 +200,29 @@
(display (format-date "~b ~d ~H:~M" date) port) (display (format-date "~b ~d ~H:~M" date) port)
(display (format-date "~b ~d ~Y " date) port)))) (display (format-date "~b ~d ~Y " date) port))))
(define (display-file file-name flag? port) (define (display-file file-name info flag? port)
(display file-name port) (display file-name port)
(if (maybe-display-flag file-name flag? port) (if (maybe-display-flag info flag? port)
(+ 1 (string-length file-name)) (+ 1 (string-length file-name))
(string-length file-name))) (string-length file-name)))
(define (maybe-display-flag file-name flag? port) (define (maybe-display-flag info flag? port)
(if (not (and flag? (and flag?
(not (file-regular? file-name))))
#f
(begin (begin
(cond (cond
((file-directory? file-name) ((eq? (file-info:type info) 'directory)
(write-char #\/ port)) (write-char #\/ port))
((file-symlink? file-name) ((eq? (file-info:type info) 'symlink)
(write-char #\@ port)) (write-char #\@ port))
((file-executable? file-name) ; '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)) (write-char #\* port))
((file-socket? file-name) ((eq? (file-info:type info) 'socket)
(write-char #\= port)) (write-char #\= port))
((file-fifo? file-name) ((eq? (file-info:type info) 'fifo)
(write-char #\| port))) (write-char #\| port)))
#t))) #t)))