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 320d6f16944460e0c2986fe1b263a7b6323e9347..4c1f4a798271c0bf1ca4faedd4f4520d5c216d43 100644 (file)
--- 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))))
 \f
-
 (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)))))))))
 \f
-
 (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))))
 \f
-
 (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) '())
-
+\f
+;;;; 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)))
+\f
+;;;; 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 e0b1fbfe99795a8baaf57d37234284ed899f608b..b179841f3dca222fa1f70224a0c6708e7cd5e68c 100644 (file)
--- 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))))
 \f
-
 (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 #\#)))
-       
 \f
 (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
-
+\f
+;;;; 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