From aec18b197f048c80f251e82a1b931ff16ef5b078 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 24 Apr 1996 02:38:58 +0000 Subject: [PATCH] Implement new procedure FILE-TIME->LS-STRING, to generate a time string like that produced by the unix `ls' program. Change Dired and VC to use this string where appropriate. Consequently rewrite the DOS directory listing program to be more like that used for OS/2. --- v7/src/edwin/dos.scm | 89 +++++++++++++++++++++++------------------- v7/src/edwin/os2.scm | 88 +++++++++++++---------------------------- v7/src/edwin/unix.scm | 17 +------- v7/src/edwin/utils.scm | 49 ++++++++++++++++------- v7/src/edwin/vc.scm | 8 ++-- 5 files changed, 116 insertions(+), 135 deletions(-) diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index a46517360..569bc6af7 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dos.scm,v 1.34 1996/02/28 16:42:39 adams Exp $ +;;; $Id: dos.scm,v 1.35 1996/04/24 02:38:58 cph Exp $ ;;; -;;; Copyright (c) 1992-95 Massachusetts Institute of Technology +;;; Copyright (c) 1992-96 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -200,47 +200,54 @@ string?) (define (insert-directory! file switches mark type) - switches ; ignored ;; Insert directory listing for FILE at MARK. + ;; SWITCHES are examined for the presence of "t". ;; TYPE can have one of three values: ;; 'WILDCARD means treat FILE as shell wildcard. ;; 'DIRECTORY means FILE is a directory and a full listing is expected. ;; 'FILE means FILE itself should be listed, and not its contents. - ;; SWITCHES are ignored. - (generate-dired-listing! (if (eq? type 'DIRECTORY) - (pathname-as-directory file) - file) - mark)) - -(define (generate-dired-listing! pathname point) - (let ((files (directory-read pathname))) - (for-each (lambda (file) (generate-dired-entry! file point)) - files))) - -(define (generate-dired-entry! file point) - (define (file-attributes/ls-time-string attr) - (let ((time-string - (file-time->string (file-attributes/modification-time attr)))) - ;; Move the year from end to start, carrying leading space. - (let ((index (fix:- (string-length time-string) 5))) - (string-append (string-tail time-string index) - " " - (string-head time-string index))))) - - (let ((name (file-namestring file)) - (attr (or (file-attributes file) (dummy-file-attributes)))) - (let ((entry (string-append - (string-pad-right ; Mode string - (file-attributes/mode-string attr) 12 #\Space) - (string-pad-left ; Length - (number->string (file-attributes/length attr)) 10 #\Space) - (string-pad-right ; Mod time - (file-attributes/ls-time-string attr) 26 #\Space) - name))) - (let ((point (mark-left-inserting-copy point))) - (insert-string entry point) - (insert-newline point) - (mark-temporary! point))))) - -(define-integrable (dummy-file-attributes) - '#(#f 0 0 0 0 0 0 0 "----------" 0)) \ No newline at end of file + (let ((mark (mark-left-inserting-copy mark)) + (now (get-universal-time))) + (call-with-current-continuation + (lambda (k) + (bind-condition-handler (list condition-type:file-error) + (lambda (condition) + (insert-string (condition/report-string condition) mark) + (insert-newline mark) + (k unspecific)) + (lambda () + (for-each + (lambda (entry) + (insert-string + (dos/dired-line-string (car entry) (cdr entry) now) + mark) + (insert-newline mark)) + (let ((make-entry + (lambda (pathname) + (let ((attributes (file-attributes pathname))) + (if attributes + (list (cons (file-namestring pathname) + attributes)) + '()))))) + (if (eq? 'FILE type) + (make-entry file) + (sort (append-map make-entry (directory-read file)) + (if (string-find-next-char switches #\t) + (lambda (x y) + (> (file-attributes/modification-time (cdr x)) + (file-attributes/modification-time (cdr y)))) + (lambda (x y) + (string-cistring (file-attributes/length attr)) + 10 #\Space) + " " + (file-time->ls-string (file-attributes/modification-time attr) now) + " " + name)) \ No newline at end of file diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm index d1b350f78..3cf3c3b81 100644 --- a/v7/src/edwin/os2.scm +++ b/v7/src/edwin/os2.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: os2.scm,v 1.28 1996/04/24 02:30:14 cph Exp $ +;;; $Id: os2.scm,v 1.29 1996/04/24 02:38:48 cph Exp $ ;;; -;;; Copyright (c) 1994-95 Massachusetts Institute of Technology +;;; Copyright (c) 1994-96 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -179,45 +179,39 @@ ;; 'WILDCARD means treat FILE as shell wildcard. ;; 'DIRECTORY means FILE is a directory and a full listing is expected. ;; 'FILE means FILE itself should be listed, and not its contents. - (let ((mark (mark-left-inserting-copy mark))) - (call-with-current-continuation - (lambda (k) - (bind-condition-handler (list condition-type:file-error) - (lambda (condition) - (insert-string (condition/report-string condition) mark) - (insert-newline mark) - (k unspecific)) - (lambda () - (for-each - (let ((now (os2/file-time->nmonths (current-file-time)))) - (lambda (entry) - (insert-string - (os2/dired-line-string (car entry) (cdr entry) now) - mark) - (insert-newline mark))) - (if (eq? 'FILE type) - (let ((attributes (file-attributes file))) - (if attributes - (list (cons (file-namestring file) attributes)) - '())) - (sort (os2/read-dired-files file - (string-find-next-char switches - #\a)) - (if (string-find-next-char switches #\t) - (lambda (x y) - (> (file-attributes/modification-time (cdr x)) - (file-attributes/modification-time (cdr y)))) - (lambda (x y) - (string-ci (file-attributes/modification-time (cdr x)) + (file-attributes/modification-time (cdr y)))) + (lambda (x y) + (string-cistring (file-attributes/length attr)) 10 #\space) " " - (os/ls-file-time-string (file-attributes/modification-time attr) now) + (file-time->ls-string (file-attributes/modification-time attr) now) " " name)) @@ -241,32 +235,6 @@ (cons (cons (file-namestring (car pathnames)) attr) result) result)))))) -;;;; Time - -(define (os/ls-file-time-string time #!optional now) - (let ((now - (if (or (default-object? now) (not now)) - (os2/file-time->nmonths (current-file-time)) - now)) - (dt (decode-file-time time)) - (ns (lambda (n m c) (string-pad-left (number->string n) m c)))) - (string-append (month/short-string (decoded-time/month dt)) - " " - (ns (decoded-time/day dt) 2 #\space) - " " - (if (<= -6 (- (os2/file-time->nmonths time) now) 0) - (string-append (ns (decoded-time/hour dt) 2 #\0) - ":" - (ns (decoded-time/minute dt) 2 #\0)) - (string-append " " - (number->string - (decoded-time/year dt))))))) - -(define (os2/file-time->nmonths time) - (let ((time (quotient time #x200000))) - (+ (* (quotient time 16) 12) - (remainder time 16)))) - ;;;; Compressed Files (define (os/read-file-methods) diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index 229610907..95d0c5900 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: unix.scm,v 1.67 1996/04/24 02:29:50 cph Exp $ +;;; $Id: unix.scm,v 1.68 1996/04/24 02:38:37 cph Exp $ ;;; ;;; Copyright (c) 1989-96 Massachusetts Institute of Technology ;;; @@ -784,21 +784,6 @@ option, instead taking -P ." (or ((ucode-primitive full-hostname 0)) ((ucode-primitive hostname 0)))) -(define (os/ls-file-time-string time) - (let ((dt (decode-file-time time)) - (ns (lambda (n m c) (string-pad-left (number->string n) m c)))) - (string-append (month/short-string (decoded-time/month dt)) - " " - (ns (decoded-time/day dt) 2 #\space) - " " - (if (<= (- (get-universal-time) time) (* 60 60 24 180)) - (string-append (ns (decoded-time/hour dt) 2 #\0) - ":" - (ns (decoded-time/minute dt) 2 #\0)) - (string-append " " - (number->string - (decoded-time/year dt))))))) - (define (os/newsrc-file-name server) (let ((homedir (user-homedir-pathname))) (let ((specific diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 4c1d8bf38..87efeb418 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: utils.scm,v 1.38 1994/08/24 19:57:15 adams Exp $ +;;; $Id: utils.scm,v 1.39 1996/04/24 02:38:19 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-94 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -279,16 +279,6 @@ (for-each write-string strings) (loop)) -(define (catch-file-errors if-error thunk) - (call-with-protected-continuation - (lambda (continuation) - (bind-condition-handler (list condition-type:file-error - condition-type:port-error) - (lambda (condition) - condition - (continuation (if-error))) - thunk)))) - (define (delete-directory-no-errors filename) (catch-file-errors (lambda () #f) (lambda () (delete-directory filename) #t))) @@ -311,7 +301,7 @@ (begin (procedure i) (loop (1+ i))))) (loop 0)) - + (define make-strong-eq-hash-table (strong-hash-table/constructor eq-hash-mod eq? #t)) @@ -323,4 +313,35 @@ (and (not (null? alist)) (if (eq? (weak-car (car alist)) item) (car alist) - (loop (cdr alist)))))) \ No newline at end of file + (loop (cdr alist)))))) + +(define (file-time->ls-string time #!optional now) + ;; Returns a time string like that used by unix `ls -l'. + (let ((time (file-time->universal-time time)) + (now + (if (or (default-object? now) (not now)) + (get-universal-time) + now))) + (let ((dt (decode-universal-time time)) + (d2 (lambda (n c) (string-pad-left (number->string n) 2 c)))) + (string-append (month/short-string (decoded-time/month dt)) + " " + (d2 (decoded-time/day dt) #\space) + " " + (if (<= 0 (- now time) (* 180 24 60 60)) + (string-append (d2 (decoded-time/hour dt) #\0) + ":" + (d2 (decoded-time/minute dt) #\0)) + (string-append " " + (number->string + (decoded-time/year dt)))))))) + +(define (catch-file-errors if-error thunk) + (call-with-protected-continuation + (lambda (continuation) + (bind-condition-handler (list condition-type:file-error + condition-type:port-error) + (if (procedure-arity-valid? if-error 0) + (lambda (condition) condition (continuation (if-error))) + (lambda (condition) (continuation (if-error condition)))) + thunk)))) \ No newline at end of file diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm index 17dfeb731..99ab0e4d7 100644 --- a/v7/src/edwin/vc.scm +++ b/v7/src/edwin/vc.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: vc.scm,v 1.21 1995/04/30 06:54:43 cph Exp $ +;;; $Id: vc.scm,v 1.22 1996/04/24 02:38:08 cph Exp $ ;;; -;;; Copyright (c) 1994-95 Massachusetts Institute of Technology +;;; Copyright (c) 1994-96 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -452,7 +452,7 @@ files in or below it." ".") #t) (begin - (pop-up-vc-command-buffer #f) + (pop-up-vc-command-buffer #t) #f))))) (define-command vc-version-other-window @@ -638,7 +638,7 @@ Normally shows only locked files; prefix arg says to show all files." " " (pad-on-left-to (number->string (file-attributes/length attr)) 8) " " - (os/ls-file-time-string (file-attributes/modification-time attr)) + (file-time->ls-string (file-attributes/modification-time attr)) " " (file-namestring file) "\n") -- 2.25.1