From: Chris Hanson Date: Wed, 16 Mar 1994 23:26:54 +0000 (+0000) Subject: * Enhance dired to allow specification of a list of files in a X-Git-Tag: 20090517-FFI~7229 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b78711895631b4edc01d12e4493f3cfb2ce142fa;p=mit-scheme.git * 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 b2a3a8635..59330bca8 100644 --- 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))) (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 (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 75700e04b..ef1d08b5c 100644 --- 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))) - -;;;; 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 da9bb1b76..d3e197825 100644 --- 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 13f732cc8..d0e26393d 100644 --- 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 aed6ae66d..2c5e1840a 100644 --- 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)))) - + (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?))