root/trunk/lisp/zwei/files.lisp @ 291

;;; -*- Mode:LISP; Package:ZWEI -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
;;; This file contains utility functions for manipulating files, and various
;;; commands to do I/O to intervals.  It does not know about buffers and such,
;;; just intervals.

;;; Get a pathname from the user, return as a pathname actor.
(DEFVAR *READING-PATHNAME-DEFAULTS*)
(DEFVAR *READING-PATHNAME-SPECIAL-TYPE*)
(DEFVAR *READING-PATHNAME-SPECIAL-VERSION*)
(DEFVAR *READING-PATHNAME-DIRECTION*)

(DEFUN READ-DEFAULTED-PATHNAME (PROMPT *READING-PATHNAME-DEFAULTS*
                                &OPTIONAL *READING-PATHNAME-SPECIAL-TYPE*
                                          *READING-PATHNAME-SPECIAL-VERSION*
                                          (*READING-PATHNAME-DIRECTION* ':READ)
                                          (MERGE-IN-SPECIAL-VERSION T)
                                &AUX (SPECIAL-VERSION *READING-PATHNAME-SPECIAL-VERSION*))
  (SETQ PROMPT (FORMAT NIL "~A (Default is ~A)" PROMPT
                       (FS:DEFAULT-PATHNAME *READING-PATHNAME-DEFAULTS* NIL
                         *READING-PATHNAME-SPECIAL-TYPE* *READING-PATHNAME-SPECIAL-VERSION*)))
  ;; MERGE-IN-SPECIAL-VERSION is for the case of wanting the default to have :OLDEST, but
  ;; not having pathnames typed in keeping to this.
  (AND (NOT MERGE-IN-SPECIAL-VERSION)
       (SETQ *READING-PATHNAME-SPECIAL-VERSION* NIL))   ;Don't complete from this
  (TEMP-KILL-RING *LAST-FILE-NAME-TYPED*
    (WITH-MINI-BUFFER-COMPLETION (*MINI-BUFFER-WINDOW*)
      (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL)
          (EDIT-IN-MINI-BUFFER *PATHNAME-READING-COMTAB* NIL NIL (NCONS PROMPT))
        (MAKE-DEFAULTED-PATHNAME (STRING-INTERVAL INTERVAL) *READING-PATHNAME-DEFAULTS*
                                 *READING-PATHNAME-SPECIAL-TYPE* SPECIAL-VERSION
                                 MERGE-IN-SPECIAL-VERSION)))))

(DEFUN READ-DEFAULTED-AUX-PATHNAME (PROMPT &OPTIONAL SPECIAL-TYPE SPECIAL-VERSION
                                                     (DIRECTION ':READ))
  (READ-DEFAULTED-PATHNAME PROMPT *AUX-PATHNAME-DEFAULTS* SPECIAL-TYPE SPECIAL-VERSION
                           DIRECTION))

(DEFUN MAKE-DEFAULTED-PATHNAME (STRING DEFAULTS &OPTIONAL SPECIAL-TYPE SPECIAL-VERSION
                                                          (MERGE-IN-SPECIAL-VERSION T))
  ;; STRING is what the user typed.  Remember it for next time if non-null.
  (IF (ZEROP (STRING-LENGTH STRING))
      ;; He didn't type anything, use the default.
      (FS:DEFAULT-PATHNAME DEFAULTS NIL SPECIAL-TYPE SPECIAL-VERSION)
      (SETQ *LAST-FILE-NAME-TYPED* STRING)
      (AND (NOT MERGE-IN-SPECIAL-VERSION)       ;Was only for nullstring case
           (SETQ SPECIAL-VERSION NIL))
      (FS:MERGE-AND-SET-PATHNAME-DEFAULTS STRING DEFAULTS
                                          (OR SPECIAL-TYPE ':UNSPECIFIC)
                                          (OR SPECIAL-VERSION ':NEWEST))))

;;; Canonicalize pathname for use as buffer name, etc.
(DEFUN EDITOR-FILE-NAME (FILE-NAME)
  (AND (STRINGP FILE-NAME)
       (SETQ FILE-NAME (FS:MERGE-PATHNAME-DEFAULTS FILE-NAME *PATHNAME-DEFAULTS*)))
  (SETQ FILE-NAME (FUNCALL FILE-NAME ':TRANSLATED-PATHNAME))
  (VALUES FILE-NAME (FUNCALL FILE-NAME ':STRING-FOR-EDITOR)))

;;; Special commands in the pathname mini-buffer
(DEFCOM COM-PATHNAME-COMPLETE "Try to complete the string so far as a pathname" ()
  (LET ((TEM (PATHNAME-COMPLETE)))
    (AND (NULL TEM) (BEEP)))
  DIS-TEXT)

(DEFCOM COM-PATHNAME-COMPLETE-AND-EXIT-IF-UNIQUE
        "Try to complete the string so far as a pathname and return if unique" ()
  (LET ((TEM (PATHNAME-COMPLETE)))
    (COND ((NULL TEM)
           (BEEP))
          ((EQ TEM ':OLD)
           (MUST-REDISPLAY *WINDOW* DIS-TEXT)
           (REDISPLAY *WINDOW* ':NONE)
           (*THROW 'RETURN-FROM-COMMAND-LOOP T))))
  DIS-TEXT)

(DEFUN PATHNAME-COMPLETE (&AUX STRING VALUE)
  (SETQ STRING (STRING-APPEND (BP-LINE (POINT))))
  (MULTIPLE-VALUE (STRING VALUE)
    (FS:COMPLETE-PATHNAME *READING-PATHNAME-DEFAULTS* STRING *READING-PATHNAME-SPECIAL-TYPE*
                          *READING-PATHNAME-SPECIAL-VERSION* *READING-PATHNAME-DIRECTION*))
  (DELETE-INTERVAL *INTERVAL*)
  (INSERT-MOVING (POINT) STRING)
  VALUE)

;COM-PATHNAME-LIST-COMPLETIONS someday

(DEFCOM COM-DOCUMENT-PATHNAME-READ "Help while getting a pathname" ()
  (FORMAT T "~&You are typing a pathname~%")
  (FORMAT T
"You are typing to a mini-buffer, with the following commands redefined:
Altmode causes the pathname to be completed and the completion inserted
into the mini-buffer.
End attempts completion and exits if that succeeds.  Return exits without completion.
")
  (AND *MINI-BUFFER-COMMAND-IN-PROGRESS*
       (COM-DOCUMENT-CONTAINING-COMMAND))
  DIS-NONE)

;;; Various file-related commands on INTERVALs.

(DEFCOM COM-INSERT-FILE "Insert the contents of the specified file at point.
Reads a file name from the mini-buffer, and inserts the contents of that
file at point. Leaves mark at the end of inserted text, and point at the 
beginning, unless given an argument.  Acts like Yank (Control-Y) with respect
to the region." ()
  (POINT-PDL-PUSH (POINT) *WINDOW* NIL NIL)
  (MOVE-BP (MARK) (POINT))
  (SETQ *CURRENT-COMMAND-TYPE* ':YANK)
  (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Insert file:")))
    (WITH-OPEN-FILE (STREAM PATHNAME '(IN))
      (MOVE-BP (POINT) (STREAM-INTO-BP STREAM (POINT))))
    (MAYBE-DISPLAY-DIRECTORY ':READ PATHNAME))
  (OR *NUMERIC-ARG-P* (SWAP-BPS (POINT) (MARK)))
  DIS-TEXT)

(DEFCOM COM-WRITE-REGION "Write out the region to the specified file." ()
  (REGION (BP1 BP2)
    (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Write region to:"
                                                 NIL NIL ':WRITE)))
      (WITH-OPEN-FILE (STREAM PATHNAME '(OUT))
        (STREAM-OUT-INTERVAL STREAM BP1 BP2 T))))
  DIS-NONE)

(DEFCOM COM-APPEND-TO-FILE "Append region to the end of the specified file." ()
  (REGION (BP1 BP2)
    (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Append region to end of file:"
                                                 NIL NIL ':NEW-OK)))
      (WITH-OPEN-FILE (OSTREAM PATHNAME '(:OUT))
        (WITH-OPEN-FILE (ISTREAM PATHNAME '(:IN :NOERROR))
          (IF (STRINGP ISTREAM)
              (MULTIPLE-VALUE-BIND (ERR NIL MSG)
                  (FS:FILE-PROCESS-ERROR ISTREAM PATHNAME NIL T)
                (IF (STRING-EQUAL ERR "FNF")
                    (TYPEIN-LINE "(New File)")
                    (BARF "Error: ~A" MSG)))
              (STREAM-COPY-UNTIL-EOF ISTREAM OSTREAM)))
        (STREAM-OUT-INTERVAL OSTREAM BP1 BP2 T))
      (MAYBE-DISPLAY-DIRECTORY ':READ PATHNAME)))
  DIS-NONE)

(DEFCOM COM-PREPEND-TO-FILE "Append region to the beginning of the specified file." ()
  (REGION (BP1 BP2)
    (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Append region to start of file:")))
      (WITH-OPEN-FILE (ISTREAM PATHNAME '(:IN))
        (WITH-OPEN-FILE (OSTREAM PATHNAME '(:OUT))
          (STREAM-OUT-INTERVAL OSTREAM BP1 BP2 T)
          (STREAM-COPY-UNTIL-EOF ISTREAM OSTREAM)))
      (MAYBE-DISPLAY-DIRECTORY ':READ PATHNAME)))
  DIS-NONE)

(DEFCOM COM-VIEW-FILE "View contents of a file." ()
  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "View file:" (PATHNAME-DEFAULTS))))
    (VIEW-FILE PATHNAME))
  DIS-NONE)

;;; Show the file in the "display window".
;;; The caller should set up a reasonable prompt.
(COMMENT
(DEFUN VIEW-FILE (FILENAME &OPTIONAL (OUTPUT-STREAM STANDARD-OUTPUT))
  (FUNCALL OUTPUT-STREAM ':HOME-CURSOR)
  (FUNCALL OUTPUT-STREAM ':CLEAR-EOL)
  (WITH-OPEN-FILE (STREAM FILENAME '(:READ))
    (STREAM-COPY-UNTIL-EOF STREAM OUTPUT-STREAM))
  (FUNCALL OUTPUT-STREAM ':CLEAR-EOF))
);COMMENT

(DEFUN VIEW-FILE (PATHNAME)
  (WITH-OPEN-FILE (STREAM PATHNAME ':PRESERVE-DATES T)
    (PROMPT-LINE "Viewing ~A" (FUNCALL STREAM ':TRUENAME))
    (VIEW-STREAM STREAM)))

(DEFUN VIEW-STREAM (STREAM &OPTIONAL (WINDOW (CREATE-OVERLYING-WINDOW *WINDOW*))
                           &AUX (INTERVAL (CREATE-BUFFER NIL)))
  (SETF (BUFFER-NAME INTERVAL) "")
  (FUNCALL (WINDOW-SHEET WINDOW) ':SET-LABEL "")
  (SET-WINDOW-INTERVAL WINDOW INTERVAL)
  (TEMPORARY-WINDOW-SELECT (WINDOW)
    (VIEW-WINDOW WINDOW STREAM)))

(DEFCOM COM-DELETE-FILE "Delete a file." ()
  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "Delete file:" (PATHNAME-DEFAULTS))))
    (LET ((TRUENAME (PROBEF PATHNAME)))
      (OR TRUENAME (SETQ TRUENAME PATHNAME))
      (AND (FQUERY NIL "Delete ~A? " TRUENAME)
           (LET ((ERROR (DELETEF TRUENAME NIL)))
             (IF (STRINGP ERROR)
                 (TYPEIN-LINE "Cannot delete ~A: ~A" TRUENAME ERROR)
                 (TYPEIN-LINE "~A deleted" TRUENAME))))))
  DIS-NONE)

(DEFCOM COM-RENAME-FILE "Rename one file to another." ()
  (MULTIPLE-VALUE-BIND (FROM TO)
      (READ-TWO-DEFAULTED-PATHNAMES "Rename" (PATHNAME-DEFAULTS))
    (LET ((FROM-NAME (PROBEF FROM)))
      (OR FROM-NAME (SETQ FROM-NAME FROM))
      (LET ((ERROR (RENAMEF FROM TO NIL)))
        (IF (STRINGP ERROR)
            (TYPEIN-LINE "Cannot rename ~A to ~A: ~A" FROM-NAME TO ERROR)
            (TYPEIN-LINE "~A renamed to ~A" FROM-NAME (OR (PROBEF TO) TO))))))
  DIS-NONE)

(DEFCOM COM-COPY-TEXT-FILE "Copy one ascii file to another." ()
  (MULTIPLE-VALUE-BIND (FROM TO)
      (READ-TWO-DEFAULTED-PATHNAMES "Copy" (PATHNAME-DEFAULTS))
    (WITH-OPEN-FILE (FROM-STREAM FROM '(:IN))
      (WITH-OPEN-FILE (TO-STREAM TO '(:OUT))
        (STREAM-COPY-UNTIL-EOF FROM-STREAM TO-STREAM NIL)
        (CLOSE TO-STREAM)
        (TYPEIN-LINE "~A copied to ~A"
                     (FUNCALL FROM-STREAM ':TRUENAME) (FUNCALL TO-STREAM ':TRUENAME)))))
  DIS-NONE)

(DEFCOM COM-COPY-BINARY-FILE "Copy one binary file to another." ()
  (MULTIPLE-VALUE-BIND (FROM TO)
      (READ-TWO-DEFAULTED-PATHNAMES "Copy" (PATHNAME-DEFAULTS))
    (WITH-OPEN-FILE (FROM-STREAM FROM '(:IN :FIXNUM))
      (WITH-OPEN-FILE (TO-STREAM TO '(:OUT :FIXNUM))
        (STREAM-COPY-UNTIL-EOF FROM-STREAM TO-STREAM NIL)
        (CLOSE TO-STREAM)
        (TYPEIN-LINE "~A copied to ~A"
                     (FUNCALL FROM-STREAM ':TRUENAME) (FUNCALL TO-STREAM ':TRUENAME)))))
  DIS-NONE)

(DEFUN READ-TWO-DEFAULTED-PATHNAMES (PROMPT DEFAULTS &AUX FROM TO)
  (SETQ FROM (READ-DEFAULTED-PATHNAME (FORMAT NIL "~A file:" PROMPT) DEFAULTS)
        TO (READ-DEFAULTED-PATHNAME (FORMAT NIL "~A ~A to:" PROMPT FROM) FROM
                                    NIL NIL ':WRITE))
  (VALUES FROM TO))

(DEFCOM COM-PRINT-FILE "Print a file on the local hardcopy device." ()
  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "Print file:" (PATHNAME-DEFAULTS))))
    (DIRED-PRINT-FILE-1 PATHNAME))
  DIS-NONE)

;;; Directory Listing stuff.

(DEFCOM COM-DISPLAY-DIRECTORY "Display current buffer's file's directory.
Use the directory listing function in the variable Directory Lister.
With an argument, accepts the name of a file to list." ()
  (FUNCALL *DIRECTORY-LISTER* (READ-DEFAULTED-WILD-PATHNAME "Display Directory:"
                                                            (DEFAULT-PATHNAME)
                                                            (NOT *NUMERIC-ARG-P*)))
  DIS-NONE)

(DEFUN READ-DEFAULTED-WILD-PATHNAME (PROMPT &OPTIONAL (DEFAULT (DEFAULT-PATHNAME))
                                                      DONT-READ-P)
    (SETQ DEFAULT (FUNCALL DEFAULT ':NEW-PATHNAME ':TYPE ':WILD ':VERSION ':WILD))
    (OR DONT-READ-P
        (SETQ DEFAULT (READ-DEFAULTED-PATHNAME PROMPT DEFAULT ':WILD ':WILD)))
    DEFAULT)

(DEFUN MAYBE-DISPLAY-DIRECTORY (TYPE &OPTIONAL (PATHNAME (DEFAULT-PATHNAME)))
  (COND ((OR (AND (EQ TYPE ':READ) (MEMQ *AUTO-DIRECTORY-DISPLAY* '(:READ T)))
             (AND (EQ TYPE ':WRITE) (MEMQ *AUTO-DIRECTORY-DISPLAY* '(:WRITE T))))
         (FUNCALL *DIRECTORY-LISTER* (FUNCALL PATHNAME ':NEW-PATHNAME ':TYPE ':WILD
                                                                      ':VERSION ':WILD)))))

;;; This is the default directory listing routine
(DEFUN DEFAULT-DIRECTORY-LISTER (PATHNAME)
  (FORMAT T "~&~A~%" PATHNAME)
  (LET ((DIRECTORY (FS:DIRECTORY-LIST PATHNAME ':SORTED)))
    (DOLIST (FILE DIRECTORY)
      (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* FILE)))
  (FORMAT T "Done.~%"))

;Note that *DIRECTORY-SINGLE-FILE-LISTER* is expected to output lines.

;Stream operations to editor stream are grossly slow.
;Make this faster by building a string then doing :LINE-OUT.
;Also try not to do the slower and more cretinously-implemented operations of FORMAT.
(DEFVAR *DIR-LISTING-BUFFER* (MAKE-ARRAY 128. ':TYPE 'ART-STRING ':LEADER-LENGTH 1))

(DEFUN DEFAULT-LIST-ONE-FILE (FILE &OPTIONAL (STREAM STANDARD-OUTPUT) &AUX PATHNAME)
  (COND ((AND (TYPEP STREAM ':CLOSURE) (EQ (CLOSURE-FUNCTION STREAM) 'INTERVAL-IO))
         (STORE-ARRAY-LEADER 0 *DIR-LISTING-BUFFER* 0)
         (WITH-OUTPUT-TO-STRING (S *DIR-LISTING-BUFFER*)
           (DEFAULT-LIST-ONE-FILE FILE S))
         (DECF (ARRAY-LEADER *DIR-LISTING-BUFFER* 0))   ;Flush the carriage return
         (FUNCALL STREAM ':LINE-OUT *DIR-LISTING-BUFFER*))
        ((NULL (SETQ PATHNAME (CAR FILE)))
         (COND ((GET FILE ':DISK-SPACE-DESCRIPTION)
                (FUNCALL STREAM ':LINE-OUT (GET FILE ':DISK-SPACE-DESCRIPTION)))
               ((GET FILE ':PHYSICAL-VOLUME-FREE-BLOCKS)
                (DO ((FREE (GET FILE ':PHYSICAL-VOLUME-FREE-BLOCKS) (CDR FREE))
                     (FLAG T NIL))
                    ((NULL FREE) (FUNCALL STREAM ':TYO #\CR))
                 (FORMAT STREAM "~A #~A=~D" (IF FLAG "Free:" ",") (CAAR FREE) (CDAR FREE))))
               (T
                (FUNCALL STREAM ':TYO #\CR))))
        (T (FUNCALL STREAM ':TYO (IF (GET FILE ':DELETED) #/D #\SP))
           (FORMAT STREAM " ~3A " (OR (GET FILE ':PHYSICAL-VOLUME) ""))
           (IF (FUNCALL STREAM ':OPERATION-HANDLED-P ':ITEM)
               (FUNCALL STREAM ':ITEM 'FILE PATHNAME "~A"
                        (FUNCALL PATHNAME ':STRING-FOR-DIRED))
               (FUNCALL STREAM ':STRING-OUT (FUNCALL PATHNAME ':STRING-FOR-DIRED)))
           (FORMAT STREAM "~20T")
           (LET ((LINK-TO (GET FILE ':LINK-TO)))
             (IF LINK-TO
                 (FORMAT STREAM "=> ~A~41T" LINK-TO)
                 (LET ((LENGTH (GET FILE ':LENGTH-IN-BLOCKS)))
                   (IF LENGTH
                       (FORMAT STREAM "~4D " LENGTH)
                       (FORMAT STREAM "~5X")))
                 (LET ((LENGTH (GET FILE ':LENGTH-IN-BYTES)))
                   (AND LENGTH
                        (FORMAT STREAM "~6D(~D)" LENGTH (GET FILE ':BYTE-SIZE))))
                 (FORMAT STREAM "~39T")
                 (FUNCALL STREAM ':TYO (IF (GET FILE ':NOT-BACKED-UP) #/! #\SP))
                 (FUNCALL STREAM ':TYO (IF (GET FILE ':DONT-REAP) #/$ #\SP))))
           (LET ((CREATION-DATE (GET FILE ':CREATION-DATE)))
             (IF CREATION-DATE
                 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
                     (TIME:DECODE-UNIVERSAL-TIME CREATION-DATE)
                   (FORMAT STREAM "~2,'0D//~2,'0D//~2,'0D ~2,'0D:~2,'0D:~2,'0D"
                           MONTH DAY (\ YEAR 100.) HOURS MINUTES SECONDS))
                 (FORMAT STREAM "~17X")))
           (LET ((REFERENCE-DATE (GET FILE ':REFERENCE-DATE)))
             (AND REFERENCE-DATE
                  (MULTIPLE-VALUE-BIND (NIL NIL NIL DAY MONTH YEAR)
                      (TIME:DECODE-UNIVERSAL-TIME REFERENCE-DATE)
                    (FORMAT STREAM " (~2,'0D//~2,'0D//~2,'0D)" MONTH DAY (\ YEAR 100.)))))
           (LET ((AUTHOR (GET FILE ':AUTHOR)))
             (AND AUTHOR (NOT (EQUAL AUTHOR (FUNCALL PATHNAME ':DIRECTORY)))
                  (FORMAT STREAM "~72T~A" AUTHOR)))
           (LET ((READER (GET FILE ':READER)))
             (AND READER (NOT (EQUAL READER (FUNCALL PATHNAME ':DIRECTORY)))
                  (FORMAT STREAM "~82T~A" READER)))
           (FUNCALL STREAM ':TYO #\CR))))

(DEFUN READ-DIRECTORY-NAME (PROMPT PATHNAME &AUX TYPEIN)
  (SETQ PATHNAME (FUNCALL PATHNAME ':NEW-PATHNAME ':NAME ':WILD
                                                  ':TYPE ':WILD
                                                  ':VERSION ':WILD)
        PROMPT (FORMAT NIL "~A (Default is ~A)" PROMPT PATHNAME))
  (LET ((*READING-PATHNAME-DEFAULTS* PATHNAME)
        (*READING-PATHNAME-SPECIAL-TYPE* ':WILD)
        (*READING-PATHNAME-SPECIAL-VERSION* ':WILD)
        (*READING-PATHNAME-DIRECTION* ':READ))
    (TEMP-KILL-RING *LAST-FILE-NAME-TYPED*
      (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL)
          (EDIT-IN-MINI-BUFFER *PATHNAME-READING-COMTAB* NIL NIL (NCONS PROMPT))
        (SETQ TYPEIN (STRING-INTERVAL INTERVAL)))))
  (COND ((EQUAL TYPEIN "") PATHNAME)
;       ((NOT (DO ((I 0 (1+ I))
;                  (LEN (STRING-LENGTH TYPEIN))
;                  (CH))
;                 (( I LEN) NIL)
;               (SETQ CH (AREF TYPEIN I))
;               (OR (AND ( CH #/A) ( CH #/Z))
;                   (AND ( CH #/a) ( CH #/z))
;                   (AND ( CH #/0) ( CH #/9))
;                   (= CH #/-)
;                   (RETURN T))))
;        ;;No funny characters, must be just a directory name
;        (FUNCALL PATHNAME ':NEW-DIRECTORY TYPEIN))
        (T
         (SETQ *LAST-FILE-NAME-TYPED* TYPEIN)
         (FS:MERGE-PATHNAME-DEFAULTS TYPEIN PATHNAME ':WILD ':WILD))))

(DEFCOM COM-LIST-FILES "Brief directory listing.
Lists several files per line" ()
  (LET* ((PATHNAME (READ-DIRECTORY-NAME "List Directory:" (DEFAULT-PATHNAME)))
         (LIST (FS:DIRECTORY-LIST PATHNAME)))
    (FORMAT T "~&~A~%" PATHNAME)
    (SETQ LIST (DELQ (ASSQ NIL LIST) LIST))     ;Don't care about system info
    (DO L LIST (CDR L) (NULL L)
      (SETF (CAR L) (CONS (FUNCALL (CAAR L) ':STRING-FOR-DIRED) (CAAR L))))
    (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FILE LIST))
  DIS-NONE)

(DEFUN VIEW-DIRECTORY (VIEWED-DIRECTORY)
  (SETQ VIEWED-DIRECTORY (FS:MERGE-PATHNAME-DEFAULTS VIEWED-DIRECTORY *PATHNAME-DEFAULTS*))
  (PROMPT-LINE "Viewing directory ~A" VIEWED-DIRECTORY)
  (VIEW-STREAM (DIRECTORY-INPUT-STREAM VIEWED-DIRECTORY))
  DIS-NONE)

;;; This gives an input stream that does output
(DEFUN DIRECTORY-INPUT-STREAM (DIRECTORY)
  (LET-CLOSED ((*DIRECTORY-LIST* DIRECTORY))
    'DIRECTORY-INPUT-STREAM-IO))

(DEFUN DIRECTORY-INPUT-STREAM-IO (OP &OPTIONAL ARG1 &REST REST)
  (DECLARE (SPECIAL *DIRECTORY-LIST*))
  REST
  (SELECTQ OP
    (:WHICH-OPERATIONS '(:LINE-IN))
    (:LINE-IN
     (IF (EQ *DIRECTORY-LIST* 'EOF) (VALUES NIL T)
         (LET ((STRING (MAKE-ARRAY 80. ':TYPE 'ART-STRING
                                       ':LEADER-LENGTH (IF (NUMBERP ARG1) ARG1 1)
                                       ':LEADER-LIST '(0))))
           (WITH-OUTPUT-TO-STRING (S STRING)
             (COND ((TYPEP *DIRECTORY-LIST* 'FS:PATHNAME)
                    (FUNCALL S ':STRING-OUT (STRING *DIRECTORY-LIST*))
                    (SETQ *DIRECTORY-LIST*
                          (OR (FUNCALL *DIRECTORY-LIST*
                                       ':SEND-IF-HANDLES
                                       ':DIRECTORY-LIST-STREAM)
                              (FS:DIRECTORY-LIST *DIRECTORY-LIST*))))
                   ((LISTP *DIRECTORY-LIST*)
                    (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* (POP *DIRECTORY-LIST*) S))
                   ((CLOSUREP *DIRECTORY-LIST*)
                    (LET ((TEM (FUNCALL *DIRECTORY-LIST*)))
                      (IF TEM
                          (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* TEM S)
                        (SETQ *DIRECTORY-LIST* 'EOF)
                        (FUNCALL S ':STRING-OUT "Done."))))
                   (T (SETQ *DIRECTORY-LIST* 'EOF)
                      (FUNCALL S ':STRING-OUT "Done."))))
           (IF (= (AREF STRING (1- (ARRAY-ACTIVE-LENGTH STRING))) #\CR)
               (DECF (ARRAY-LEADER STRING 0)))  ;Flush carriage return
           STRING)))))

;;; Obsolete ITS only functions
(DEFCOM COM-OLD-LIST-FILES "Brief directory listing.
Lists directory N entries to a line, with the following
special characters to the left of the filenames:
        : this is a link
        ! this file has not been backed up to tape yet
        * this file has really been deleted but not yet
          closed, or is otherwise locked.
        (blank) this is a plain normal file
Also the top line contains in order, the device being
listed from, the directory, Free: followed by the number of
free blocks on the device (separated into primary, secondary, etc.
packs), Used: followed by the number of blocks this directory is taking up." ()
  (LET ((PATHNAME (READ-DIRECTORY-NAME "List Directory:" (DEFAULT-PATHNAME)))
        (LINE NIL) (X NIL) (Y NIL) (X1 NIL) (Y1 NIL) (TEM1 NIL)
        (FREE-ARRAY (MAKE-ARRAY NIL 'ART-Q 10)) (USED-ARRAY (MAKE-ARRAY NIL 'ART-Q 10)))
    (WITH-OPEN-FILE (STREAM (FUNCALL PATHNAME ':DEFAULT-NAMESTRING ".FILE. (DIR)") '(READ))
      (SETQ LINE (FUNCALL STREAM ':LINE-IN))
      (SETQ LINE (FUNCALL STREAM ':LINE-IN))
      (DIRECTORY-FREE-SPACE LINE FREE-ARRAY)
      (FORMAT T "~6A ~6A  " (FUNCALL PATHNAME ':DEVICE) (FUNCALL PATHNAME ':DIRECTORY))
      (FORMAT-DISK-BLOCKS-ARRAY STANDARD-OUTPUT "Free: " FREE-ARRAY)
      (FORMAT T ", Used: ")                     ;Filled in later
      (MULTIPLE-VALUE (X Y) (FUNCALL STANDARD-OUTPUT ':READ-CURSORPOS ':PIXEL))
      ;; Make any pack that exists show up in the "used" display even if used=0
      (DOTIMES (IDX 10)
        (AND (AREF FREE-ARRAY IDX)
             (ASET 0 USED-ARRAY IDX)))
      (DO ((I 0 (\ (1+ I) 5)))
          (NIL)
        (AND (ZEROP I) (TERPRI))
        (SETQ LINE (FUNCALL STREAM ':LINE-IN))
        (COND ((OR (NULL LINE)
                   (ZEROP (ARRAY-ACTIVE-LENGTH LINE))
                   (= (AREF LINE 0) #\FF))
               (RETURN NIL)))
        (FUNCALL STANDARD-OUTPUT ':TYO
                 (COND ((= #/* (AREF LINE 0))
                        #/*)
                       ((= #/L (AREF LINE 2))
                        #/:)
                       (T (LET ((USED)
                                (PACK (PARSE-NUMBER LINE 2)))
                            (MULTIPLE-VALUE (USED TEM1) (PARSE-NUMBER LINE 20.))
                            (LET ((IDX (IF (OR (< PACK 10.) (> PACK 16.)) 0
                                           (- PACK 9.))))
                              (ASET (+ (OR (AREF USED-ARRAY IDX) 0) USED)
                                    USED-ARRAY IDX)))
                          (COND ((= #/! (AREF LINE (1+ TEM1)))
                                 #/!)
                                (T #\SP)))))
        (FUNCALL STANDARD-OUTPUT ':STRING-OUT (NSUBSTRING LINE 6 19.))
        (FUNCALL STANDARD-OUTPUT ':STRING-OUT "  "))
      (FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
      (MULTIPLE-VALUE (X1 Y1) (FUNCALL STANDARD-OUTPUT ':READ-CURSORPOS ':PIXEL))
      (FUNCALL STANDARD-OUTPUT ':SET-CURSORPOS X Y ':PIXEL)
      (FORMAT-DISK-BLOCKS-ARRAY STANDARD-OUTPUT "" USED-ARRAY)
      (FUNCALL STANDARD-OUTPUT ':SET-CURSORPOS X1 Y1 ':PIXEL)))
  DIS-NONE)

(DEFUN SUBSET-DIRECTORY-LISTING (PATHNAME)
  (LET ((FN1 (FUNCALL PATHNAME ':NAME))
        (FN2 (FUNCALL PATHNAME ':FN2)))
    (FORMAT T "~&~A~%" PATHNAME)
    (LET ((LINE NIL)
          (FREE-ARRAY (MAKE-ARRAY NIL 'ART-Q 10))
          (USED-ARRAY (MAKE-ARRAY NIL 'ART-Q 10)))
      (WITH-OPEN-FILE (STREAM (FUNCALL PATHNAME ':NEW-STRUCTURED-NAME '(".FILE." "(DIR)"))
                              '(READ))
        ;; First find out how much space is free.
        (SETQ LINE (FUNCALL STREAM ':LINE-IN))
        (SETQ LINE (FUNCALL STREAM ':LINE-IN))
        (DIRECTORY-FREE-SPACE LINE FREE-ARRAY)
        ;; Make any pack that exists show up in the "used" display even if used=0
        (DOTIMES (IDX 10)
          (AND (AREF FREE-ARRAY IDX)
               (ASET 0 USED-ARRAY IDX)))
        ;; Next, go through lines of dir, counting USED and printing some lines.
        (DO ((KEY (STRING-APPEND " "
                                 (IF (STRING-EQUAL FN1 "TS") FN2 FN1)
                                 " "))
             (LINE) (EOF))
            (NIL)
          (MULTIPLE-VALUE (LINE EOF)
            (FUNCALL STREAM ':LINE-IN))
          (AND (OR EOF (ZEROP (STRING-LENGTH LINE))) (RETURN NIL))
          (AND (STRING-SEARCH KEY LINE)
               (FUNCALL STANDARD-OUTPUT ':LINE-OUT LINE))
          (OR (= (AREF LINE 2) #/L)
              (LET ((USED (PARSE-NUMBER LINE 20.))
                    (PACK (PARSE-NUMBER LINE 2)))
                (LET ((IDX (IF (OR (< PACK 10.) (> PACK 16.)) 0
                               (- PACK 9.))))
                  (ASET (+ (OR (AREF USED-ARRAY IDX) 0) USED) USED-ARRAY IDX)))))
        (FORMAT-DISK-BLOCKS-ARRAY T "Free: " FREE-ARRAY)
        (FORMAT-DISK-BLOCKS-ARRAY T ", Used: " USED-ARRAY)))))

;Element 0 of FREE-ARRAY is for packs other than 10.-16.
(DEFUN DIRECTORY-FREE-SPACE (LINE FREE-ARRAY)
  (DO ((I (STRING-SEARCH-CHAR #/# LINE)
          (STRING-SEARCH-CHAR #/# LINE I))
       (NUM) (IDX) (BLKS))
      ((NULL I))
    (MULTIPLE-VALUE (NUM I)
      (PARSE-NUMBER LINE (1+ I)))
    (MULTIPLE-VALUE (BLKS I)
      (PARSE-NUMBER LINE (1+ I)))
    (SETQ IDX (IF (OR (< NUM 10.) (> NUM 16.)) 0
                  (- NUM 9.)))
    (ASET (+ (OR (AREF FREE-ARRAY IDX) 0) BLKS) FREE-ARRAY IDX)))

(DEFUN FORMAT-DISK-BLOCKS-ARRAY (STREAM TITLE ARRAY)
  (FORMAT STREAM TITLE)
  (DO ((IDX 0 (1+ IDX))
       (LIM (ARRAY-LENGTH ARRAY))
       (FIRSTP T)
       (BLKS))
      ((= IDX LIM))
    (COND ((SETQ BLKS (AREF ARRAY IDX))
           (FORMAT STREAM "~:[+~]~D" FIRSTP BLKS)
           (SETQ FIRSTP NIL)))))

(DEFUN ROTATED-DIRECTORY-LISTING (PATHNAME)
  (*CATCH 'ABORT
     (LET ((DEV (FUNCALL PATHNAME ':DEVICE))
           (DIR (FUNCALL PATHNAME ':DIRECTORY))
           (FN1 (FUNCALL PATHNAME ':NAME))
           (FN NIL))
       (SETQ FN (FUNCALL PATHNAME ':NEW-STRUCTURED-NAME '(".FILE." "(DIR)")))
       (PROMPT-LINE "Directory Listing")
       (FORMAT T "~&~A  ~A    --   ~A~%" DEV DIR PATHNAME)
       (LET ((LINE NIL) (X 0) (Y 0))
         (WITH-OPEN-FILE (STREAM FN '(IN))
           (SETQ LINE (FUNCALL STREAM ':LINE-IN))
           (FORMAT T "~A~%" (FUNCALL STREAM ':LINE-IN))
           (DO ((LINE (SETQ LINE (FUNCALL STREAM ':LINE-IN))
                      (SETQ LINE (FUNCALL STREAM ':LINE-IN)))
                (LFN1 (STRING-LENGTH FN1))
                (LFN16 (+ (STRING-LENGTH FN1) 6))
                )
               ((NULL LINE)
                (FORMAT T "There is no file named ~A in the directory.~%" FN1))
             (COND ((STRING-EQUAL LINE FN1 6 0 LFN16 LFN1)
                    ;; Found one.
                    (LET ((FIRST LINE))
                      (SETQ LINE (DO ((LINE LINE (FUNCALL STREAM ':LINE-IN)))
                                     ((OR (= (AREF LINE 0) #\FF)
                                          (NOT (STRING-EQUAL LINE FN1 6 0 LFN16 LFN1)))
                                      LINE)
                                   (FORMAT T "~A~%" LINE)))
                      (FORMAT T "==MORE==")
                      (OR (= (FUNCALL STANDARD-INPUT ':TYI) #\SP)
                          (*THROW 'ABORT NIL))
                      (MULTIPLE-VALUE (X Y)
                        (FUNCALL STANDARD-OUTPUT ':READ-CURSORPOS))
                      (FUNCALL STANDARD-OUTPUT ':SET-CURSORPOS 0 Y)
                      (FUNCALL STANDARD-OUTPUT ':CLEAR-EOL)
                      (DO ((LINE LINE (FUNCALL STREAM ':LINE-IN)))
                          ((EQUAL LINE FIRST))
                        (COND ((ZEROP (STRING-LENGTH LINE))
                               (FORMAT T "------------------------------------------------~%")
                               (CLOSE STREAM)
                               (SETQ STREAM (OPEN FN '(IN)))
                               (FUNCALL STREAM ':LINE-IN)
                               (FUNCALL STREAM ':LINE-IN)
                               (SETQ LINE (FUNCALL STREAM ':LINE-IN))))
                        (FORMAT T "~A~%" LINE)))
                    (RETURN NIL)))))))))

(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* DIRECTORY "Edit" DIRECTORY-EDIT-1
                          T "Run DIRED on this directory.")

(DEFUN DIRECTORY-EDIT-1 (DIRECTORY)
  (DIRECTORY-EDIT DIRECTORY)
  NIL)

(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* DIRECTORY "View" VIEW-DIRECTORY
                          NIL "View this directory")

(DEFCOM COM-LIST-ALL-DIRECTORY-NAMES "List names of all disk directories." ()
  (LET* ((DEFAULT (FUNCALL (DEFAULT-PATHNAME) ':NEW-PATHNAME
                           ':DIRECTORY ':WILD ':NAME ':UNSPECIFIC
                           ':TYPE ':UNSPECIFIC ':VERSION ':UNSPECIFIC))
         (PATHNAME (IF (OR *NUMERIC-ARG-P*
                           (NULL (ZWEI:BUFFER-PATHNAME *INTERVAL*)))
                       (READ-DEFAULTED-PATHNAME "List directories:" DEFAULT
                                                ':UNSPECIFIC ':UNSPECIFIC)
                       DEFAULT))
         (DIRS (FS:ALL-DIRECTORIES PATHNAME ':NOERROR)))
    (IF (STRINGP DIRS)
        (BARF "Error: ~A" DIRS)
        (SETQ DIRS (SORTCAR DIRS #'FS:PATHNAME-LESSP))
        (FUNCALL STANDARD-OUTPUT ':ITEM-LIST 'DIRECTORY
                 (LOOP FOR (PATHNAME) IN DIRS
                       COLLECT `(,(FUNCALL PATHNAME ':STRING-FOR-DIRECTORY)
                                 . ,(FUNCALL PATHNAME ':NEW-PATHNAME ':NAME ':WILD
                                             ':TYPE ':WILD ':VERSION ':WILD))))))
  DIS-NONE)

(DEFCOM COM-EXPUNGE-DIRECTORY "Expunge deleted files from a directory" ()
  (LET* ((DIRECTORY (READ-DIRECTORY-NAME "Expunge directory" (DEFAULT-PATHNAME)))
         (RESULT (FS:EXPUNGE-DIRECTORY DIRECTORY ':ERROR NIL)))
    (IF (STRINGP RESULT) (BARF "Cannot expunge ~A: ~A" DIRECTORY RESULT)
        (TYPEIN-LINE "~A: ~D block~:P freed" DIRECTORY RESULT)))
  DIS-NONE)