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

even less STAT-calls 

(removed STAT-calls when called with RECURSIVE)
This commit is contained in:
interp 2001-09-07 16:38:38 +00:00
parent 5973322619
commit 3c200d4db9
1 changed files with 81 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

147
ls.scm
View File

@ -61,31 +61,43 @@
(file-directory? path #f))) ;; or not (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 (cons path (file-info path #f)) 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) ; 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
(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?))) (file-names (directory-files substantial-directory all?)))
(with-cwd* (with-cwd*
substantial-directory substantial-directory
(lambda () (lambda ()
(if (and (not long?) (let ((files (if (or recursive? long? flag?) ; these are the flags for which we need the file-info
columns?) (map (lambda (file-name)
(ls-files-columns files flag? port) (cons file-name (file-info file-name #f)))
(ls-files-column files long? flag? port)) file-names)
(map (lambda (file-name) (cons file-name #f))
file-names))))
(if recursive? (if (and (not long?)
(let ((directories columns?)
(filter (lambda (file) (file-directory? file #f)) (ls-files-columns files flag? port)
files))) (ls-files-column files long? flag? port))
(if (not (null? directories))
(begin (if recursive?
(newline port) (let ((directories
(real-ls directories directory (map (lambda (file) (car file))
all? recursive? long? directory? flag? columns? (filter (lambda (file)
port))))))))) (eq? (file-info:type (cdr file)) 'directory))
files))))
(if (not (null? directories))
(begin
(newline port)
(real-ls directories directory
all? recursive? long? directory? flag? columns?
port))))))))))
(define *width* 79) (define *width* 79)
@ -93,7 +105,7 @@
(let* ((max-file-name-width (let* ((max-file-name-width
(if (null? files) (if (null? files)
0 0
(apply max (map string-length files)))) (apply max (map (lambda (file) (string-length (car file))) files))))
(max-file-name-width (max-file-name-width
(if flag? (if flag?
(+ 1 max-file-name-width) (+ 1 max-file-name-width)
@ -125,8 +137,8 @@
((= column columns)) ((= column columns))
(let ((tail (vector-ref tails column))) (let ((tail (vector-ref tails column)))
(if (not (null? tail)) (if (not (null? tail))
(let* ((file-name (car tail)) (let* ((file (car tail))
(width (display-file file-name (file-info file-name) flag? port))) (width (display-file file flag? port)))
(display-spaces (- column-width width) port) (display-spaces (- column-width width) port)
(vector-set! tails column (cdr tail)))))) (vector-set! tails column (cdr tail))))))
(newline port)))) (newline port))))
@ -144,50 +156,50 @@
(ls-file file long? flag? port)) (ls-file file long? flag? port))
files)) files))
(define (ls-file file-name long? flag? port) (define (ls-file file long? flag? port)
(let ((info (file-info file-name #f))) (if long?
(if long? (ls-file-long file flag? port)
(ls-file-long file-name info flag? port) (ls-file-short file flag? port)))
(ls-file-short file-name info flag? port))))
(define (ls-file-short file-name info flag? port) (define (ls-file-short file flag? port)
(display-file file-name info flag? port) (display-file file flag? port)
(newline port)) (newline port))
(define (ls-file-long file-name info flag? port) (define (ls-file-long file flag? port)
(display-permissions info port) (let ((info (cdr file)))
(display-decimal-justified (file-info:nlinks info) 4 port) (display-permissions info port)
(write-char #\space port) (display-decimal-justified (file-info:nlinks info) 4 port)
(let* ((uid (file-info:uid info)) (write-char #\space port)
(user-name (let* ((uid (file-info:uid info))
(call-with-current-continuation (user-name
(lambda (escape) (call-with-current-continuation
(with-handler (lambda (escape)
(lambda (condition more) (with-handler
(escape (number->string uid))) (lambda (condition more)
(lambda () (escape (number->string uid)))
(user-info:name (user-info uid)))))))) (lambda ()
(display-padded user-name 9 port)) (user-info:name (user-info uid))))))))
(let* ((gid (file-info:gid info)) (display-padded user-name 9 port))
(group-name (let* ((gid (file-info:gid info))
(call-with-current-continuation (group-name
(lambda (escape) (call-with-current-continuation
(with-handler (lambda (escape)
(lambda (condition more) (with-handler
(escape (number->string gid))) (lambda (condition more)
(lambda () (escape (number->string gid)))
(group-info:name (group-info gid)))))))) (lambda ()
(display-padded group-name 9 port)) (group-info:name (group-info gid))))))))
(display-decimal-justified (file-info:size info) 7 port) (display-padded group-name 9 port))
(write-char #\space port) (display-decimal-justified (file-info:size info) 7 port)
(display-time (file-info:mtime info) port) (write-char #\space port)
(write-char #\space port) (display-time (file-info:mtime info) port)
(display-file file-name info flag? port) (write-char #\space port)
(if (eq? (file-info:type info) 'symlink) (display-file file flag? port)
(begin (if (eq? (file-info:type info) 'symlink)
(display " -> " port) (begin
(display (read-symlink file-name) port))) (display " -> " port)
(newline port)) (display (read-symlink (car file) port))))
(newline port)))
(define *year-seconds* (* 365 24 60 60)) (define *year-seconds* (* 365 24 60 60))
@ -198,11 +210,12 @@
(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 info flag? port) (define (display-file file flag? port)
(display file-name port) (let ((file-name (car file)))
(if (maybe-display-flag info flag? port) (display file-name port)
(+ 1 (string-length file-name)) (if (maybe-display-flag (cdr file) flag? port)
(string-length file-name))) (+ 1 (string-length file-name))
(string-length file-name))))
(define (maybe-display-flag info flag? port) (define (maybe-display-flag info flag? port)
(and flag? (and flag?
@ -230,6 +243,8 @@
(write-char #\d port)) (write-char #\d port))
((symlink) ((symlink)
(write-char #\l port)) (write-char #\l port))
((fifo)
(write-char #\p port))
(else (else
(write-char #\- port))) (write-char #\- port)))
(let ((mode (file-info:mode info)) (let ((mode (file-info:mode info))