* Enhance dired to allow specification of a list of files in a

  specific directory in place of a directory.

* Change OS-specific code for dired to be a single entry point,
  INSERT-DIRECTORY!, that can insert the listing for a single file, a
  whole directory, or a wildcarded expression.

* Add new procedure, FOR-EACH-DIRED-MARK, that maps a procedure over
  the marked files in a dired buffer, and unmarks each file as it is
  processed.

diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm
index b2a3a8635270a1176689d7700b13787faccef60a..59330bca8bf215fcc0cfffed545be62457e75ab1 100644 (file)
--- a/v7/src/edwin/dired.scm
+++ b/v7/src/edwin/dired.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: dired.scm,v 1.143 1994/03/11 05:23:29 cph Exp $
+;;;    $Id: dired.scm,v 1.144 1994/03/16 23:26:45 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-94 Massachusetts Institute of Technology
 ;;;
@@ -138,27 +138,32 @@ Type `h' after entering dired for more info."
   (lambda (directory)
     (select-buffer-other-window (make-dired-buffer directory))))
 
-(define (make-dired-buffer directory)
-  (let ((directory (pathname-simplify directory)))
-    (let ((buffer (get-dired-buffer directory)))
-      (set-buffer-major-mode! buffer (ref-mode-object dired))
-      (set-buffer-default-directory! buffer (directory-pathname directory))
-      (buffer-put! buffer 'REVERT-BUFFER-METHOD revert-dired-buffer)
-      (buffer-put! buffer 'DIRED-DIRECTORY directory)
-      (fill-dired-buffer! buffer directory)
-      buffer)))
-
-(define (get-dired-buffer directory)
+(define (make-dired-buffer directory #!optional file-list)
+  (let ((directory (pathname-simplify directory))
+       (file-list (if (default-object? file-list) 'ALL file-list)))
+    (let ((directory-spec (cons directory file-list)))
+      (let ((buffer (get-dired-buffer directory-spec)))
+       (set-buffer-major-mode! buffer (ref-mode-object dired))
+       (set-buffer-default-directory! buffer (directory-pathname directory))
+       (buffer-put! buffer 'DIRED-DIRECTORY-SPEC directory-spec)
+       (buffer-put! buffer 'REVERT-BUFFER-METHOD revert-dired-buffer)
+       (fill-dired-buffer! buffer directory-spec)
+       buffer))))
+
+(define (get-dired-buffer directory-spec)
   (or (list-search-positive (buffer-list)
        (lambda (buffer)
-         (equal? directory (buffer-get buffer 'DIRED-DIRECTORY))))
-      (new-buffer (pathname->buffer-name directory))))
+         (equal? directory-spec (buffer-get buffer 'DIRED-DIRECTORY-SPEC))))
+      (new-buffer (pathname->buffer-name (car directory-spec)))))
+
+(define (dired-buffer-directory-spec buffer)
+  (or (buffer-get buffer 'DIRED-DIRECTORY-SPEC)
+      (let ((directory-spec (cons (buffer-default-directory buffer) 'ALL)))
+       (buffer-put! buffer 'DIRED-DIRECTORY-SPEC directory-spec)
+       directory-spec)))
 
 (define (dired-buffer-directory buffer)
-  (or (buffer-get buffer 'DIRED-DIRECTORY)
-      (let ((directory (buffer-default-directory buffer)))
-       (buffer-put! buffer 'DIRED-DIRECTORY directory)
-       directory)))
+  (car (dired-buffer-directory-spec buffer)))
 
 (define (revert-dired-buffer buffer dont-use-auto-save? dont-confirm?)
   dont-use-auto-save? dont-confirm?    ;ignore
@@ -166,7 +171,7 @@ Type `h' after entering dired for more info."
     (let ((filename
           (and (dired-filename-start lstart)
                (region->string (dired-filename-region lstart)))))
-      (fill-dired-buffer! buffer (dired-buffer-directory buffer))
+      (fill-dired-buffer! buffer (dired-buffer-directory-spec buffer))
       (set-current-point!
        (line-start
        (or (and filename
@@ -186,35 +191,61 @@ Type `h' after entering dired for more info."
   2
   exact-nonnegative-integer?)
 
-(define (fill-dired-buffer! buffer pathname)
-  (set-buffer-writable! buffer)
-  (region-delete! (buffer-region buffer))
-  (temporary-message
-   (string-append "Reading directory " (->namestring pathname) "..."))
-  (read-directory pathname
-                 (ref-variable dired-listing-switches buffer)
-                 (buffer-point buffer))
-  (append-message "done")
-  (let ((point (mark-left-inserting-copy (buffer-point buffer)))
-       (group (buffer-group buffer)))
-    (let ((index (mark-index (buffer-start buffer))))
-      (if (not (group-end-index? group index))
-         (let loop ((index index))
-           (set-mark-index! point index)
-           (group-insert-string! group index "  ")
-           (let ((index (1+ (line-end-index group (mark-index point)))))
-             (if (not (group-end-index? group index))
-                 (loop index)))))))
-  (set-buffer-point! buffer (buffer-start buffer))
-  (buffer-not-modified! buffer)
-  (set-buffer-read-only! buffer))
+(define (fill-dired-buffer! buffer directory-spec)
+  (let ((pathname (car directory-spec))
+       (file-list (cdr directory-spec)))
+    (set-buffer-writable! buffer)
+    (region-delete! (buffer-region buffer))
+    (temporary-message
+     (string-append "Reading directory " (->namestring pathname) "..."))
+    (read-directory pathname
+                   file-list
+                   (ref-variable dired-listing-switches buffer)
+                   (buffer-point buffer))
+    (append-message "done")
+    (let ((point (mark-left-inserting-copy (buffer-point buffer)))
+         (group (buffer-group buffer)))
+      (let ((index (mark-index (buffer-start buffer))))
+       (if (not (group-end-index? group index))
+           (let loop ((index index))
+             (set-mark-index! point index)
+             (group-insert-string! group index "  ")
+             (let ((index (1+ (line-end-index group (mark-index point)))))
+               (if (not (group-end-index? group index))
+                   (loop index)))))))
+    (set-buffer-point! buffer (buffer-start buffer))
+    (buffer-not-modified! buffer)
+    (set-buffer-read-only! buffer)))
+
+(define (read-directory pathname file-list switches mark)
+  (if (eq? 'ALL file-list)
+      (insert-directory! pathname switches mark
+                        (if (file-directory? pathname)
+                            'DIRECTORY
+                            'WILDCARD))
+      (let ((mark (mark-left-inserting-copy mark)))
+       (for-each (lambda (file)
+                   (insert-directory! (merge-pathnames file pathname)
+                                      switches
+                                      mark
+                                      'FILE))
+                 file-list)
+       (mark-temporary! mark))))
 
 (define (add-dired-entry pathname)
-  (let ((lstart (line-start (current-point) 0))
-       (directory (directory-pathname pathname)))
+  (let ((lstart (line-start (current-point) 0)))
     (if (pathname=? (buffer-default-directory (mark-buffer lstart))
-                   directory)
-       (insert-dired-entry! pathname directory lstart))))
+                   (directory-pathname pathname))
+       (insert-dired-entry! pathname lstart))))
+
+(define (insert-dired-entry! pathname mark)
+  (let ((mark (mark-left-inserting-copy mark)))
+    (insert-string "  " mark)
+    (insert-directory! pathname
+                      (ref-variable dired-listing-switches mark)
+                      mark
+                      'FILE)
+    (mark-temporary! mark)))
 \f
 (define-command dired-find-file
   "Read the current file into a buffer."
@@ -597,6 +628,7 @@ Actions controlled by variables list-directory-brief-switches
        (insert-string (->namestring directory) point)
        (insert-newline point)
        (read-directory directory
+                       'ALL
                        (if argument
                            (ref-variable list-directory-verbose-switches)
                            (ref-variable list-directory-brief-switches))
@@ -640,7 +672,7 @@ Actions controlled by variables list-directory-brief-switches
 
 (define (dired-pathname lstart)
   (merge-pathnames
-   (directory-pathname (dired-buffer-directory (current-buffer)))
+   (directory-pathname (dired-buffer-directory (mark-buffer lstart)))
    (region->string (dired-filename-region lstart))))
 
 (define (dired-mark char n)
@@ -742,9 +774,12 @@ Actions controlled by variables list-directory-brief-switches
 \f
 (define (dired-marked-files #!optional mark marker-char)
   (let ((mark
-        (if (or (default-object? mark) (not mark))
-            (buffer-start (current-buffer))
-            mark))
+        (cond ((or (default-object? mark) (not mark))
+               (buffer-start (current-buffer)))
+              ((buffer? mark)
+               (buffer-start mark))
+              (else
+               mark)))
        (marker-char
         (if (or (default-object? marker-char) (not marker-char))
             dired-marker-char
@@ -788,4 +823,10 @@ Actions controlled by variables list-directory-brief-switches
             mark)))
     (let ((start (line-start mark 0)))
       (and (dired-filename-start start)
-          (cons (dired-pathname start) start)))))
\ No newline at end of file
+          (cons (dired-pathname start) start)))))
+
+(define (for-each-dired-mark buffer procedure)
+  (for-each (lambda (file)
+             (procedure (car file))
+             (dired-mark-1 (cdr file) #\space))
+           (dired-marked-files buffer)))
\ No newline at end of file

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index 75700e04b8e079a8abacd23b420edf59b1be6148..ef1d08b5ce06b116f188e2847cf5d8cf63826b93 100644 (file)
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: dos.scm,v 1.13 1994/01/29 22:40:46 gjr Exp $
+;;;    $Id: dos.scm,v 1.14 1994/03/16 23:26:47 cph Exp $
 ;;;
 ;;;    Copyright (c) 1992-1994 Massachusetts Institute of Technology
 ;;;
@@ -418,22 +418,26 @@ Includes the new backup.  Must be > 0."
   #f
   false?)
 
-(define (read-directory pathname switches mark)
+(define (insert-directory! file switches mark type)
   switches                             ; ignored
-  (if (file-directory? pathname)
-      (generate-dired-listing!
-       (string-append (->namestring (pathname-as-directory pathname))
-                     "*.*")
-       mark)
-      (generate-dired-listing! pathname mark)))
-
-(define (insert-dired-entry! pathname directory lstart)
-  directory                            ; ignored
-  (let ((start (mark-left-inserting lstart)))
-    (insert-string "  " start)
-    (generate-dired-entry! pathname start)))
-\f
-;;;; Scheme version of ls
+  ;; Insert directory listing for FILE at MARK.
+  ;; 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.
+  (case type
+    ((WILDCARD)
+     (generate-dired-listing! file mark))
+    ((DIRECTORY)
+     (generate-dired-listing!
+      (string-append (->namestring (pathname-as-directory file))
+                    "*.*")
+      mark))
+    (else
+     (generate-dired-entry! file mark))))
+
+;;; Scheme version of ls
 
 (define (generate-dired-listing! pathname point)
   (let ((files (directory-read (->namestring (merge-pathnames pathname)))))
@@ -464,8 +468,10 @@ Includes the new backup.  Must be > 0."
                  (string-pad-right   ; Mod time
                   (file-attributes/ls-time-string attr) 26 #\Space)
                  name)))
-      (insert-string entry point)
-      (insert-newline point))))
+      (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))

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index da9bb1b76bf0356968c2e8efaeed07a696256de4..d3e19782564bc5c2a63bcdcd0e08358496c925a5 100644 (file)
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.145 1994/03/10 00:50:39 cph Exp $
+$Id: edwin.pkg,v 1.146 1994/03/16 23:26:50 cph Exp $
 
 Copyright (c) 1989-1994 Massachusetts Institute of Technology
 
@@ -684,6 +684,7 @@ MIT in each case. |#
          dired-filename-start
          dired-marked-files
          dired-next-files
+         dired-pathname
          dired-this-file
          edwin-command$dired
          edwin-command$dired-abort
@@ -717,6 +718,8 @@ MIT in each case. |#
          edwin-variable$dired-copy-preserve-time
          edwin-variable$dired-kept-versions
          edwin-variable$dired-mode-hook
+         for-each-dired-mark
+         insert-dired-entry!
          make-dired-buffer))
 
 (define-package (edwin info)

diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm
index 13f732cc8e527affea43687173d2e0b19f3d9c7f..d0e26393d99570c5966b44fdca03aea437549d90 100644 (file)
--- a/v7/src/edwin/filcom.scm
+++ b/v7/src/edwin/filcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: filcom.scm,v 1.178 1993/10/15 05:35:22 cph Exp $
+;;;    $Id: filcom.scm,v 1.179 1994/03/16 23:26:52 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -327,11 +327,8 @@ Argument means don't offer to use auto-save file."
                            " not current"))
          (if (not (call-with-temporary-buffer "*Directory*"
                     (lambda (buffer)
-                      (insert-dired-entry! pathname
-                                           (directory-pathname pathname)
-                                           (buffer-end buffer))
+                      (insert-dired-entry! pathname (buffer-end buffer))
                       (insert-dired-entry! auto-save-pathname
-                                           (directory-pathname pathname)
                                            (buffer-end buffer))
                       (set-buffer-point! buffer (buffer-start buffer))
                       (buffer-not-modified! buffer)

diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index aed6ae66d7fc1f61d37478eb832f7b3bd2c5005e..2c5e1840a8885852985b860b619563cd37202534 100644 (file)
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: unix.scm,v 1.41 1994/03/08 20:18:58 cph Exp $
+;;;    $Id: unix.scm,v 1.42 1994/03/16 23:26:54 cph Exp $
 ;;;
 ;;;    Copyright (c) 1989-94 Massachusetts Institute of Technology
 ;;;
@@ -575,33 +575,58 @@ CANNOT contain the 'F' option."
   "-l"
   string?)
 
-(define (read-directory pathname switches mark)
-  (let ((directory (directory-pathname pathname)))
-    (if (file-directory? pathname)
-       (run-synchronous-process false mark directory false
-                                (find-program "ls" false)
-                                switches
-                                (->namestring pathname))
-       (shell-command false mark directory false
-                      (string-append "ls "
+(define-variable insert-directory-program
+  "Absolute or relative name of the `ls' program used by `insert-directory'."
+  "ls"
+  string?)
+
+(define (insert-directory! file switches mark type)
+  ;; Insert directory listing for FILE, formatted according to SWITCHES.
+  ;; The listing is inserted at MARK.
+  ;; 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 must not contain "-d".
+  (let ((directory (directory-pathname (merge-pathnames file)))
+       (program (ref-variable insert-directory-program mark))
+       (switches
+        (if (eq? 'DIRECTORY type)
+            switches
+            (string-append-separated "-d" switches))))
+    (if (eq? 'WILDCARD type)
+       (shell-command #f mark directory #f
+                      (string-append program
+                                     " "
                                      switches
                                      " "
-                                     (file-namestring pathname))))))
-
-(define (insert-dired-entry! pathname directory lstart)
-  (let ((start (mark-right-inserting lstart)))
-    (run-synchronous-process false lstart directory false
-                            (find-program "ls" directory)
-                            "-d"
-                            (ref-variable dired-listing-switches lstart)
-                            (->namestring pathname))
-    (insert-string "  " start)
-    (let ((start (mark-right-inserting (dired-filename-start start))))
-      (insert-string
-       (file-namestring
-       (extract-and-delete-string start (line-end start 0)))
-       start))))
-\f
+                                     (file-namestring file)))
+       (apply run-synchronous-process
+              #f mark directory #f
+              (find-program program #f)
+              (append
+               (split-unix-switch-string switches)
+               (list
+                (if (eq? 'DIRECTORY type)
+                    ;; If FILE is a symbolic link, this reads the
+                    ;; directory that it points to.
+                    (->namestring
+                     (pathname-new-directory file
+                                             (append (pathname-directory file)
+                                                     (list "."))))
+                    (file-namestring file))))))))
+
+(define (split-unix-switch-string switches)
+  (let ((end (string-length switches)))
+    (let loop ((start 0))
+      (if (fix:< start end)
+         (let ((space (substring-find-next-char switches start end #\space)))
+           (if space
+               (cons (substring switches start space)
+                     (loop (fix:+ space 1)))
+               (list (substring switches start end))))
+         '()))))
+
 (define (os/scheme-can-quit?)
   (subprocess-job-control-available?))