From: Guillermo J. Rozas Date: Wed, 23 Sep 1992 23:05:22 +0000 (+0000) Subject: Move dired system-dependent stuff elsewhere (dos.scm, unix.scm, dirunx.scm). X-Git-Tag: 20090517-FFI~8920 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6828de9f340c3df9546c6525876c401ffa7d3c4d;p=mit-scheme.git Move dired system-dependent stuff elsewhere (dos.scm, unix.scm, dirunx.scm). --- diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index 320d6f169..4c1f4a798 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dos.scm,v 1.2 1992/06/04 03:08:17 mhwu Exp $ +;;; $Id: dos.scm,v 1.3 1992/09/23 23:05:22 jinx Exp $ ;;; ;;; Copyright (c) 1992 Massachusetts Institute of Technology ;;; @@ -83,7 +83,6 @@ Includes the new backup. Must be > 0." 2 (lambda (n) (and (exact-integer? n) (> n 0)))) - (define os/directory-char-set (char-set #\\ #\/)) (define (os/trim-pathname-string string) @@ -251,7 +250,6 @@ Includes the new backup. Must be > 0." '()))) (no-versions))))))))) - (define (os/directory-list-completions directory prefix) (define (->directory-namestring s) (->namestring (pathname-as-directory (->pathname s)))) @@ -359,7 +357,6 @@ Includes the new backup. Must be > 0." ("txt" . text) ("y" . c)))) - (define (os/init-file-name) (let* ((home (dos/current-home-directory)) (user-init-file (merge-pathnames "edwin.ini" home))) @@ -380,4 +377,65 @@ Includes the new backup. Must be > 0." (define (os/read-file-methods) '()) (define (os/write-file-methods) '()) - + +;;;; Dired customization + +(define-variable dired-listing-switches + "Dired listing format -- Ignored under DOS." + #f + false?) + +(define-variable list-directory-brief-switches + "list-directory brief listing format -- Ignored under DOS." + #f + false?) + +(define-variable list-directory-verbose-switches + "list-directory verbose listing format -- Ignored under DOS." + #f + false?) + +(define (read-directory pathname switches mark) + (let ((directory (directory-pathname pathname))) + (if (file-directory? pathname) + (let ((dir (->namestring (pathname-as-directory pathname)))) + (generate-dired-listing! (string-append dir "*.*") 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 + +(define (generate-dired-listing! pathname point) + (let ((files (directory-read (->namestring (merge-pathnames pathname))))) + (for-each (lambda (file) (generate-dired-entry! file point)) + files))) + +(define (generate-dired-entry! file point) + (define (file-attributes/ls-time-string attr) + ;; Swap year around to the start + (let ((time-string ((ucode-primitive file-time->string 1) + (file-attributes/modification-time attr)))) + (if (string? time-string) + (or (let ((len (string-length time-string))) + (and (fix:> len 5) ;; Grap the space char as well + (string-append (substring time-string (fix:- len 5) len) + " " + (substring time-string 0 (fix:- len 5))))) + "")))) + + (let ((name (file-namestring file)) (attr (file-attributes file))) + (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))) + (insert-string entry point) + (insert-newline point)))) \ No newline at end of file diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index e0b1fbfe9..b179841f3 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.26 1992/04/29 21:23:37 bal Exp $ +;;; $Id: unix.scm,v 1.27 1992/09/23 23:05:15 jinx Exp $ ;;; -;;; Copyright (c) 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1989-1992 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -279,7 +279,6 @@ Includes the new backup. Must be > 0." (substring filename (+ index 1) end) filename)))) - (define unix/encoding-pathname-types '("Z")) @@ -356,7 +355,6 @@ Includes the new backup. Must be > 0." ;; code was originally doing. (and (string? filename) (string-find-next-char filename #\#))) - (define (os/read-file-methods) (list maybe-read-compressed-file @@ -485,4 +483,48 @@ filename suffix \".KY\"." (write-string the-encrypted-file))))) ;;; End of encrypted files - + +;;;; Dired customization + +(define-variable dired-listing-switches + "Switches passed to ls for dired. MUST contain the 'l' option. +CANNOT contain the 'F' option." + "-al" + string?) + +(define-variable list-directory-brief-switches + "Switches for list-directory to pass to `ls' for brief listing," + "-CF" + string?) + +(define-variable list-directory-verbose-switches + "Switches for list-directory to pass to `ls' for verbose listing," + "-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 " + 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) + (->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)))) \ No newline at end of file