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.

diff --git a/v7/src/edwin/diros2.scm b/v7/src/edwin/diros2.scm
index 417b226adc4f25c9c7a1facd4fdaa6fd7e41d09a..68b3696efd4df21eb17f81b37381a87b1af44878 100644 (file)
--- 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))
 \f
 (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)))
+\f
+(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 a780727aeeb06c8e69ac8713026c725ea5bb0706..f55d0caa3fd4c2703bb48c20563cc11b564c24eb 100644 (file)
--- 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<? (car x) (car y))))))))))
+           (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<? (car x) (car y)))))))))))
     (mark-temporary! mark)))
 \f
+(define (os2/dired-line-string name attr now)
+  (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))
+
+(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))))))
+\f
 ;;;; Time
 
 (define (os/ls-file-time-string time #!optional now)