From a5c0267f884097eeb68bab6132950ea68abbc414 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 31 Oct 1995 08:08:33 +0000 Subject: [PATCH] Implement M command for Dired. Change Dired to show system/hidden files only when the "a" listing switch is given; by default these files are hidden. Implement S command to toggle the switch off and on. --- v7/src/edwin/diros2.scm | 67 +++++++++++++++++++++++++++++++++-- v7/src/edwin/os2.scm | 77 +++++++++++++++++++++++++---------------- 2 files changed, 112 insertions(+), 32 deletions(-) diff --git a/v7/src/edwin/diros2.scm b/v7/src/edwin/diros2.scm index 417b226ad..68b3696ef 100644 --- a/v7/src/edwin/diros2.scm +++ b/v7/src/edwin/diros2.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: diros2.scm,v 1.1 1995/02/14 00:30:59 cph Exp $ +;;; $Id: diros2.scm,v 1.2 1995/10/31 08:08:33 cph Exp $ ;;; ;;; Copyright (c) 1992-95 Massachusetts Institute of Technology ;;; @@ -48,6 +48,8 @@ (declare (usual-integrations)) (define-key 'dired #\Z 'dired-do-compress) +(define-key 'dired #\S 'dired-hidden-toggle) +(define-key 'dired #\M 'dired-chmod) (define-command dired-do-compress "Compress or uncompress marked (or next ARG) files. @@ -77,4 +79,65 @@ The files are compressed or uncompressed using gzip." "gz"))) lstart)))))))) (if (positive? n) - (message "Compressed or uncompressed " n " files."))))) \ No newline at end of file + (message "Compressed or uncompressed " n " files."))))) + +(define-command dired-hidden-toggle + "Toggle display of hidden/system files on and off." + () + (lambda () (dired-toggle-switch #\a))) + +(define-command dired-chmod + "Change mode of this file." + "sChange to Mode\nP" + (lambda (spec argument) + (call-with-values (lambda () (os2/parse-attributes-spec spec)) + (lambda (plus minus) + (dired-change-files "change attributes of" argument + (lambda (pathname lstart) + (set-file-modes! pathname + (fix:or (fix:andc (file-modes pathname) + minus) + plus)) + (dired-redisplay pathname lstart))))))) + +(define (os2/parse-attributes-spec spec) + (let ((end (string-length spec)) + (plus '()) + (minus '())) + (let loop ((index 0) (state #f)) + (if (< index end) + (let ((char (char-downcase (string-ref spec index))) + (index (+ index 1))) + (case char + ((#\+ #\-) + (loop index char)) + ((#\a #\h #\r #\s) + (set! plus (delv! char plus)) + (set! minus (delv! char minus)) + (case state + ((#\+) + (set! plus (cons char plus)) + (loop index state)) + ((#\-) + (set! minus (cons char minus)) + (loop index state)) + (else #f))) + (else #f))) + (values (os2/attribute-letters-to-mask plus) + (os2/attribute-letters-to-mask minus)))))) + +(define (os2/attribute-letters-to-mask letters) + (let ((mask 0)) + (for-each (lambda (letter) + (set! mask + (fix:or (case letter + ((#\a) os2-file-mode/archived) + ((#\d) os2-file-mode/directory) + ((#\h) os2-file-mode/hidden) + ((#\r) os2-file-mode/read-only) + ((#\s) os2-file-mode/system) + (else (error "Unknown mode letter:" letter))) + mask)) + unspecific) + letters) + mask)) \ No newline at end of file diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm index a780727ae..f55d0caa3 100644 --- a/v7/src/edwin/os2.scm +++ b/v7/src/edwin/os2.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: os2.scm,v 1.25 1995/10/25 03:25:55 cph Exp $ +;;; $Id: os2.scm,v 1.26 1995/10/31 08:08:14 cph Exp $ ;;; ;;; Copyright (c) 1994-95 Massachusetts Institute of Technology ;;; @@ -172,7 +172,7 @@ (define (insert-directory! file switches mark type) ;; Insert directory listing for FILE at MARK. - ;; SWITCHES are examined for the presence of "t". + ;; SWITCHES are examined for the presence of "a" and "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. @@ -190,38 +190,55 @@ (let ((now (os2/file-time->nmonths (current-file-time)))) (lambda (entry) (insert-string - (let ((name (car entry)) - (attr (cdr entry))) - (string-append - (file-attributes/mode-string attr) - " " - (string-pad-left (number->string - (file-attributes/length attr)) - 10 #\space) - " " - (os/ls-file-time-string - (file-attributes/modification-time attr) - now) - " " - name)) + (os2/dired-line-string (car entry) (cdr entry) now) mark) (insert-newline mark))) - (sort (list-transform-positive - (map (lambda (pathname) - (cons (file-namestring pathname) - (file-attributes pathname))) - (if (eq? 'FILE type) - (list file) - (directory-read file #f))) - cdr) - (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) + " " + name)) + +(define (os2/read-dired-files file all-files?) + (let loop + ((pathnames + (let ((pathnames (directory-read file #f))) + (if all-files? + pathnames + (list-transform-positive pathnames + (let ((mask + (fix:or os2-file-mode/hidden os2-file-mode/system))) + (lambda (pathname) + (fix:= (fix:and (file-modes pathname) mask) 0))))))) + (result '())) + (if (null? pathnames) + result + (loop (cdr pathnames) + (let ((attr (file-attributes (car pathnames)))) + (if attr + (cons (cons (file-namestring (car pathnames)) attr) result) + result)))))) + ;;;; Time (define (os/ls-file-time-string time #!optional now) -- 2.25.1