From 3b8b19a13fe7310d4955cd672f91edc0e3c9878b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 7 Dec 1996 22:24:29 +0000 Subject: [PATCH] Implement remaining Dired customizations for Win32. (All further customizations require subprocess support.) --- v7/src/edwin/decls.scm | 3 +- v7/src/edwin/dos.scm | 102 +++++++++++++++++++++++++--------------- v7/src/edwin/ed-ffi.scm | 4 +- v7/src/edwin/edwin.ldr | 5 +- v7/src/edwin/edwin.pkg | 12 ++++- 5 files changed, 83 insertions(+), 43 deletions(-) diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 221147cd6..e0509a67b 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.57 1996/04/23 22:38:47 cph Exp $ +$Id: decls.scm,v 1.58 1996/12/07 22:24:13 cph Exp $ Copyright (c) 1989-96 Massachusetts Institute of Technology @@ -142,6 +142,7 @@ MIT in each case. |# "dired" "diros2" "dirunx" + "dirw32" "docstr" "dos" "doscom" diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index 0c6a53616..135020381 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dos.scm,v 1.41 1996/10/10 10:29:20 cph Exp $ +;;; $Id: dos.scm,v 1.42 1996/12/07 22:23:42 cph Exp $ ;;; ;;; Copyright (c) 1992-96 Massachusetts Institute of Technology ;;; @@ -42,7 +42,7 @@ ;;; of that license should have been included along with this file. ;;; -;;;; DOS Customizations for Edwin +;;;; Win32 Customizations for Edwin (declare (usual-integrations)) @@ -177,62 +177,70 @@ ;;;; Dired customization (define-variable dired-listing-switches - "Dired listing format -- Ignored under DOS." + "Dired listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." "-l" string?) (define-variable list-directory-brief-switches - "list-directory brief listing format -- Ignored under DOS." + "list-directory brief listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." "-l" string?) (define-variable list-directory-verbose-switches - "list-directory verbose listing format -- Ignored under DOS." + "list-directory verbose listing format. +Recognized switches are: + -a show all files including system and hidden files + -t sort files according to modification time + -l ignored (but allowed for unix compatibility) +Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." "-l" string?) (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. ;; 'FILE means FILE itself should be listed, and not its contents. (let ((mark (mark-left-inserting-copy mark)) (now (get-universal-time))) - (call-with-current-continuation - (lambda (k) - (bind-condition-handler (list condition-type:file-error) - (lambda (condition) - (insert-string (condition/report-string condition) mark) - (insert-newline mark) - (k unspecific)) - (lambda () - (for-each - (lambda (entry) - (insert-string - (dos/dired-line-string (car entry) (cdr entry) now) - mark) - (insert-newline mark)) - (let ((make-entry - (lambda (pathname) - (let ((attributes (file-attributes pathname))) - (if attributes - (list (cons (file-namestring pathname) - attributes)) - '()))))) - (if (eq? 'FILE type) - (make-entry file) - (sort (append-map make-entry (directory-read file)) - (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 (file-attributes/modification-time (cdr x)) + (file-attributes/modification-time (cdr y)))) + (lambda (x y) + (string-cils-string (file-attributes/modification-time attr) now) " " name)) + +(define (win32/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 nt-file-mode/hidden nt-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)))))) (define dired-pathname-wild? pathname-wild?) \ No newline at end of file diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index 0de7cd096..8c46570b7 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ed-ffi.scm,v 1.40 1996/04/23 22:38:39 cph Exp $ +$Id: ed-ffi.scm,v 1.41 1996/12/07 22:24:20 cph Exp $ Copyright (c) 1990-96 Massachusetts Institute of Technology @@ -119,6 +119,8 @@ of that license should have been included along with this file. edwin-syntax-table) ("dirunx" (edwin dired) edwin-syntax-table) + ("dirw32" (edwin dired) + edwin-syntax-table) ("display" (edwin display-type) syntax-table/system-internal) ("docstr" (edwin) diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index 4245bb1ce..bb78d9f28 100644 --- a/v7/src/edwin/edwin.ldr +++ b/v7/src/edwin/edwin.ldr @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.ldr,v 1.57 1996/12/06 22:34:08 cph Exp $ +$Id: edwin.ldr,v 1.58 1996/12/07 22:24:04 cph Exp $ Copyright (c) 1989-96 Massachusetts Institute of Technology @@ -207,7 +207,8 @@ MIT in each case. |# (load "dired" env) (case (lookup 'OS-TYPE) ((UNIX) (load "dirunx" env)) - ((OS/2) (load "diros2" env)))) + ((OS/2) (load "diros2" env)) + ((NT) (load "dirw32" env)))) (load "argred" (->environment '(EDWIN COMMAND-ARGUMENT))) (load "autold" environment) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 7fa27d840..fb9b4ae8f 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.200 1996/10/15 19:05:46 cph Exp $ +$Id: edwin.pkg,v 1.201 1996/12/07 22:24:29 cph Exp $ Copyright (c) 1989-96 Massachusetts Institute of Technology @@ -1147,6 +1147,12 @@ MIT in each case. |# (extend-package (edwin) (files "dos" "dosfile")) + (extend-package (edwin dired) + (files "dirw32") + (export (edwin) + edwin-command$dired-chmod + edwin-command$dired-hidden-toggle)) + (extend-package (edwin screen console-screen) (files "ansi" "bios")) @@ -1239,7 +1245,9 @@ MIT in each case. |# (extend-package (edwin dired) (files "diros2") (export (edwin) - edwin-command$dired-do-compress)) + edwin-command$dired-chmod + edwin-command$dired-do-compress + edwin-command$dired-hidden-toggle)) (extend-package (edwin process) (files "process")) -- 2.25.1