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

Revision 291, 25.0 KB (checked in by rjs, 3 years ago)

Y2K fixes.

RevLine 
[257]1;;; -*- Mode:LISP; Package:ZWEI -*-
2;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
3;;; This file contains utility functions for manipulating files, and various
4;;; commands to do I/O to intervals.  It does not know about buffers and such,
5;;; just intervals.
6
[273]7;;; Get a pathname from the user, return as a pathname actor.
8(DEFVAR *READING-PATHNAME-DEFAULTS*)
9(DEFVAR *READING-PATHNAME-SPECIAL-TYPE*)
10(DEFVAR *READING-PATHNAME-SPECIAL-VERSION*)
11(DEFVAR *READING-PATHNAME-DIRECTION*)
[257]12
[273]13(DEFUN READ-DEFAULTED-PATHNAME (PROMPT *READING-PATHNAME-DEFAULTS*
14                                &OPTIONAL *READING-PATHNAME-SPECIAL-TYPE*
15                                          *READING-PATHNAME-SPECIAL-VERSION*
16                                          (*READING-PATHNAME-DIRECTION* ':READ)
17                                          (MERGE-IN-SPECIAL-VERSION T)
18                                &AUX (SPECIAL-VERSION *READING-PATHNAME-SPECIAL-VERSION*))
19  (SETQ PROMPT (FORMAT NIL "~A (Default is ~A)" PROMPT
20                       (FS:DEFAULT-PATHNAME *READING-PATHNAME-DEFAULTS* NIL
21                         *READING-PATHNAME-SPECIAL-TYPE* *READING-PATHNAME-SPECIAL-VERSION*)))
22  ;; MERGE-IN-SPECIAL-VERSION is for the case of wanting the default to have :OLDEST, but
23  ;; not having pathnames typed in keeping to this.
24  (AND (NOT MERGE-IN-SPECIAL-VERSION)
25       (SETQ *READING-PATHNAME-SPECIAL-VERSION* NIL))   ;Don't complete from this
26  (TEMP-KILL-RING *LAST-FILE-NAME-TYPED*
27    (WITH-MINI-BUFFER-COMPLETION (*MINI-BUFFER-WINDOW*)
28      (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL)
29          (EDIT-IN-MINI-BUFFER *PATHNAME-READING-COMTAB* NIL NIL (NCONS PROMPT))
30        (MAKE-DEFAULTED-PATHNAME (STRING-INTERVAL INTERVAL) *READING-PATHNAME-DEFAULTS*
31                                 *READING-PATHNAME-SPECIAL-TYPE* SPECIAL-VERSION
32                                 MERGE-IN-SPECIAL-VERSION)))))
[257]33
[273]34(DEFUN READ-DEFAULTED-AUX-PATHNAME (PROMPT &OPTIONAL SPECIAL-TYPE SPECIAL-VERSION
35                                                     (DIRECTION ':READ))
36  (READ-DEFAULTED-PATHNAME PROMPT *AUX-PATHNAME-DEFAULTS* SPECIAL-TYPE SPECIAL-VERSION
37                           DIRECTION))
[257]38
[273]39(DEFUN MAKE-DEFAULTED-PATHNAME (STRING DEFAULTS &OPTIONAL SPECIAL-TYPE SPECIAL-VERSION
40                                                          (MERGE-IN-SPECIAL-VERSION T))
[257]41  ;; STRING is what the user typed.  Remember it for next time if non-null.
42  (IF (ZEROP (STRING-LENGTH STRING))
43      ;; He didn't type anything, use the default.
[273]44      (FS:DEFAULT-PATHNAME DEFAULTS NIL SPECIAL-TYPE SPECIAL-VERSION)
[257]45      (SETQ *LAST-FILE-NAME-TYPED* STRING)
[273]46      (AND (NOT MERGE-IN-SPECIAL-VERSION)       ;Was only for nullstring case
47           (SETQ SPECIAL-VERSION NIL))
48      (FS:MERGE-AND-SET-PATHNAME-DEFAULTS STRING DEFAULTS
49                                          (OR SPECIAL-TYPE ':UNSPECIFIC)
50                                          (OR SPECIAL-VERSION ':NEWEST))))
[257]51
[273]52;;; Canonicalize pathname for use as buffer name, etc.
[257]53(DEFUN EDITOR-FILE-NAME (FILE-NAME)
54  (AND (STRINGP FILE-NAME)
[273]55       (SETQ FILE-NAME (FS:MERGE-PATHNAME-DEFAULTS FILE-NAME *PATHNAME-DEFAULTS*)))
56  (SETQ FILE-NAME (FUNCALL FILE-NAME ':TRANSLATED-PATHNAME))
57  (VALUES FILE-NAME (FUNCALL FILE-NAME ':STRING-FOR-EDITOR)))
58
59;;; Special commands in the pathname mini-buffer
60(DEFCOM COM-PATHNAME-COMPLETE "Try to complete the string so far as a pathname" ()
61  (LET ((TEM (PATHNAME-COMPLETE)))
62    (AND (NULL TEM) (BEEP)))
63  DIS-TEXT)
64
65(DEFCOM COM-PATHNAME-COMPLETE-AND-EXIT-IF-UNIQUE
66        "Try to complete the string so far as a pathname and return if unique" ()
67  (LET ((TEM (PATHNAME-COMPLETE)))
68    (COND ((NULL TEM)
69           (BEEP))
70          ((EQ TEM ':OLD)
71           (MUST-REDISPLAY *WINDOW* DIS-TEXT)
72           (REDISPLAY *WINDOW* ':NONE)
73           (*THROW 'RETURN-FROM-COMMAND-LOOP T))))
74  DIS-TEXT)
75
76(DEFUN PATHNAME-COMPLETE (&AUX STRING VALUE)
77  (SETQ STRING (STRING-APPEND (BP-LINE (POINT))))
78  (MULTIPLE-VALUE (STRING VALUE)
79    (FS:COMPLETE-PATHNAME *READING-PATHNAME-DEFAULTS* STRING *READING-PATHNAME-SPECIAL-TYPE*
80                          *READING-PATHNAME-SPECIAL-VERSION* *READING-PATHNAME-DIRECTION*))
81  (DELETE-INTERVAL *INTERVAL*)
82  (INSERT-MOVING (POINT) STRING)
83  VALUE)
84
85;COM-PATHNAME-LIST-COMPLETIONS someday
86
87(DEFCOM COM-DOCUMENT-PATHNAME-READ "Help while getting a pathname" ()
88  (FORMAT T "~&You are typing a pathname~%")
89  (FORMAT T
90"You are typing to a mini-buffer, with the following commands redefined:
91Altmode causes the pathname to be completed and the completion inserted
92into the mini-buffer.
93End attempts completion and exits if that succeeds.  Return exits without completion.
94")
95  (AND *MINI-BUFFER-COMMAND-IN-PROGRESS*
96       (COM-DOCUMENT-CONTAINING-COMMAND))
97  DIS-NONE)
[257]98
99;;; Various file-related commands on INTERVALs.
100
101(DEFCOM COM-INSERT-FILE "Insert the contents of the specified file at point.
102Reads a file name from the mini-buffer, and inserts the contents of that
[273]103file at point. Leaves mark at the end of inserted text, and point at the
104beginning, unless given an argument.  Acts like Yank (Control-Y) with respect
105to the region." ()
[257]106  (POINT-PDL-PUSH (POINT) *WINDOW* NIL NIL)
107  (MOVE-BP (MARK) (POINT))
108  (SETQ *CURRENT-COMMAND-TYPE* ':YANK)
[273]109  (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Insert file:")))
110    (WITH-OPEN-FILE (STREAM PATHNAME '(IN))
111      (MOVE-BP (POINT) (STREAM-INTO-BP STREAM (POINT))))
112    (MAYBE-DISPLAY-DIRECTORY ':READ PATHNAME))
113  (OR *NUMERIC-ARG-P* (SWAP-BPS (POINT) (MARK)))
[257]114  DIS-TEXT)
115
116(DEFCOM COM-WRITE-REGION "Write out the region to the specified file." ()
117  (REGION (BP1 BP2)
[273]118    (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Write region to:"
119                                                 NIL NIL ':WRITE)))
120      (WITH-OPEN-FILE (STREAM PATHNAME '(OUT))
121        (STREAM-OUT-INTERVAL STREAM BP1 BP2 T))))
[257]122  DIS-NONE)
123
124(DEFCOM COM-APPEND-TO-FILE "Append region to the end of the specified file." ()
125  (REGION (BP1 BP2)
[273]126    (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Append region to end of file:"
127                                                 NIL NIL ':NEW-OK)))
128      (WITH-OPEN-FILE (OSTREAM PATHNAME '(:OUT))
129        (WITH-OPEN-FILE (ISTREAM PATHNAME '(:IN :NOERROR))
130          (IF (STRINGP ISTREAM)
131              (MULTIPLE-VALUE-BIND (ERR NIL MSG)
132                  (FS:FILE-PROCESS-ERROR ISTREAM PATHNAME NIL T)
133                (IF (STRING-EQUAL ERR "FNF")
134                    (TYPEIN-LINE "(New File)")
135                    (BARF "Error: ~A" MSG)))
136              (STREAM-COPY-UNTIL-EOF ISTREAM OSTREAM)))
137        (STREAM-OUT-INTERVAL OSTREAM BP1 BP2 T))
138      (MAYBE-DISPLAY-DIRECTORY ':READ PATHNAME)))
[257]139  DIS-NONE)
140
141(DEFCOM COM-PREPEND-TO-FILE "Append region to the beginning of the specified file." ()
142  (REGION (BP1 BP2)
[273]143    (LET ((PATHNAME (READ-DEFAULTED-AUX-PATHNAME "Append region to start of file:")))
144      (WITH-OPEN-FILE (ISTREAM PATHNAME '(:IN))
145        (WITH-OPEN-FILE (OSTREAM PATHNAME '(:OUT))
146          (STREAM-OUT-INTERVAL OSTREAM BP1 BP2 T)
147          (STREAM-COPY-UNTIL-EOF ISTREAM OSTREAM)))
148      (MAYBE-DISPLAY-DIRECTORY ':READ PATHNAME)))
[257]149  DIS-NONE)
150
151(DEFCOM COM-VIEW-FILE "View contents of a file." ()
[273]152  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "View file:" (PATHNAME-DEFAULTS))))
153    (VIEW-FILE PATHNAME))
[257]154  DIS-NONE)
155
156;;; Show the file in the "display window".
157;;; The caller should set up a reasonable prompt.
158(COMMENT
159(DEFUN VIEW-FILE (FILENAME &OPTIONAL (OUTPUT-STREAM STANDARD-OUTPUT))
160  (FUNCALL OUTPUT-STREAM ':HOME-CURSOR)
161  (FUNCALL OUTPUT-STREAM ':CLEAR-EOL)
[273]162  (WITH-OPEN-FILE (STREAM FILENAME '(:READ))
[257]163    (STREAM-COPY-UNTIL-EOF STREAM OUTPUT-STREAM))
164  (FUNCALL OUTPUT-STREAM ':CLEAR-EOF))
165);COMMENT
166
[273]167(DEFUN VIEW-FILE (PATHNAME)
168  (WITH-OPEN-FILE (STREAM PATHNAME ':PRESERVE-DATES T)
169    (PROMPT-LINE "Viewing ~A" (FUNCALL STREAM ':TRUENAME))
[257]170    (VIEW-STREAM STREAM)))
171
172(DEFUN VIEW-STREAM (STREAM &OPTIONAL (WINDOW (CREATE-OVERLYING-WINDOW *WINDOW*))
173                           &AUX (INTERVAL (CREATE-BUFFER NIL)))
174  (SETF (BUFFER-NAME INTERVAL) "")
175  (FUNCALL (WINDOW-SHEET WINDOW) ':SET-LABEL "")
176  (SET-WINDOW-INTERVAL WINDOW INTERVAL)
177  (TEMPORARY-WINDOW-SELECT (WINDOW)
178    (VIEW-WINDOW WINDOW STREAM)))
179
180(DEFCOM COM-DELETE-FILE "Delete a file." ()
[273]181  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "Delete file:" (PATHNAME-DEFAULTS))))
182    (LET ((TRUENAME (PROBEF PATHNAME)))
183      (OR TRUENAME (SETQ TRUENAME PATHNAME))
184      (AND (FQUERY NIL "Delete ~A? " TRUENAME)
185           (LET ((ERROR (DELETEF TRUENAME NIL)))
186             (IF (STRINGP ERROR)
187                 (TYPEIN-LINE "Cannot delete ~A: ~A" TRUENAME ERROR)
188                 (TYPEIN-LINE "~A deleted" TRUENAME))))))
[257]189  DIS-NONE)
190
191(DEFCOM COM-RENAME-FILE "Rename one file to another." ()
192  (MULTIPLE-VALUE-BIND (FROM TO)
[273]193      (READ-TWO-DEFAULTED-PATHNAMES "Rename" (PATHNAME-DEFAULTS))
194    (LET ((FROM-NAME (PROBEF FROM)))
195      (OR FROM-NAME (SETQ FROM-NAME FROM))
196      (LET ((ERROR (RENAMEF FROM TO NIL)))
197        (IF (STRINGP ERROR)
198            (TYPEIN-LINE "Cannot rename ~A to ~A: ~A" FROM-NAME TO ERROR)
199            (TYPEIN-LINE "~A renamed to ~A" FROM-NAME (OR (PROBEF TO) TO))))))
[257]200  DIS-NONE)
201
[273]202(DEFCOM COM-COPY-TEXT-FILE "Copy one ascii file to another." ()
[257]203  (MULTIPLE-VALUE-BIND (FROM TO)
[273]204      (READ-TWO-DEFAULTED-PATHNAMES "Copy" (PATHNAME-DEFAULTS))
205    (WITH-OPEN-FILE (FROM-STREAM FROM '(:IN))
206      (WITH-OPEN-FILE (TO-STREAM TO '(:OUT))
207        (STREAM-COPY-UNTIL-EOF FROM-STREAM TO-STREAM NIL)
[257]208        (CLOSE TO-STREAM)
[273]209        (TYPEIN-LINE "~A copied to ~A"
210                     (FUNCALL FROM-STREAM ':TRUENAME) (FUNCALL TO-STREAM ':TRUENAME)))))
211  DIS-NONE)
[257]212
[273]213(DEFCOM COM-COPY-BINARY-FILE "Copy one binary file to another." ()
214  (MULTIPLE-VALUE-BIND (FROM TO)
215      (READ-TWO-DEFAULTED-PATHNAMES "Copy" (PATHNAME-DEFAULTS))
216    (WITH-OPEN-FILE (FROM-STREAM FROM '(:IN :FIXNUM))
217      (WITH-OPEN-FILE (TO-STREAM TO '(:OUT :FIXNUM))
218        (STREAM-COPY-UNTIL-EOF FROM-STREAM TO-STREAM NIL)
219        (CLOSE TO-STREAM)
220        (TYPEIN-LINE "~A copied to ~A"
221                     (FUNCALL FROM-STREAM ':TRUENAME) (FUNCALL TO-STREAM ':TRUENAME)))))
222  DIS-NONE)
223
224(DEFUN READ-TWO-DEFAULTED-PATHNAMES (PROMPT DEFAULTS &AUX FROM TO)
225  (SETQ FROM (READ-DEFAULTED-PATHNAME (FORMAT NIL "~A file:" PROMPT) DEFAULTS)
226        TO (READ-DEFAULTED-PATHNAME (FORMAT NIL "~A ~A to:" PROMPT FROM) FROM
227                                    NIL NIL ':WRITE))
228  (VALUES FROM TO))
229
230(DEFCOM COM-PRINT-FILE "Print a file on the local hardcopy device." ()
231  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "Print file:" (PATHNAME-DEFAULTS))))
232    (DIRED-PRINT-FILE-1 PATHNAME))
233  DIS-NONE)
[257]234
235;;; Directory Listing stuff.
236
237(DEFCOM COM-DISPLAY-DIRECTORY "Display current buffer's file's directory.
238Use the directory listing function in the variable Directory Lister.
[273]239With an argument, accepts the name of a file to list." ()
240  (FUNCALL *DIRECTORY-LISTER* (READ-DEFAULTED-WILD-PATHNAME "Display Directory:"
241                                                            (DEFAULT-PATHNAME)
242                                                            (NOT *NUMERIC-ARG-P*)))
[257]243  DIS-NONE)
244
[273]245(DEFUN READ-DEFAULTED-WILD-PATHNAME (PROMPT &OPTIONAL (DEFAULT (DEFAULT-PATHNAME))
246                                                      DONT-READ-P)
247    (SETQ DEFAULT (FUNCALL DEFAULT ':NEW-PATHNAME ':TYPE ':WILD ':VERSION ':WILD))
248    (OR DONT-READ-P
249        (SETQ DEFAULT (READ-DEFAULTED-PATHNAME PROMPT DEFAULT ':WILD ':WILD)))
250    DEFAULT)
251
252(DEFUN MAYBE-DISPLAY-DIRECTORY (TYPE &OPTIONAL (PATHNAME (DEFAULT-PATHNAME)))
[257]253  (COND ((OR (AND (EQ TYPE ':READ) (MEMQ *AUTO-DIRECTORY-DISPLAY* '(:READ T)))
254             (AND (EQ TYPE ':WRITE) (MEMQ *AUTO-DIRECTORY-DISPLAY* '(:WRITE T))))
[273]255         (FUNCALL *DIRECTORY-LISTER* (FUNCALL PATHNAME ':NEW-PATHNAME ':TYPE ':WILD
256                                                                      ':VERSION ':WILD)))))
[257]257
[273]258;;; This is the default directory listing routine
259(DEFUN DEFAULT-DIRECTORY-LISTER (PATHNAME)
260  (FORMAT T "~&~A~%" PATHNAME)
261  (LET ((DIRECTORY (FS:DIRECTORY-LIST PATHNAME ':SORTED)))
262    (DOLIST (FILE DIRECTORY)
263      (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* FILE)))
264  (FORMAT T "Done.~%"))
[257]265
[273]266;Note that *DIRECTORY-SINGLE-FILE-LISTER* is expected to output lines.
[257]267
[273]268;Stream operations to editor stream are grossly slow.
269;Make this faster by building a string then doing :LINE-OUT.
270;Also try not to do the slower and more cretinously-implemented operations of FORMAT.
271(DEFVAR *DIR-LISTING-BUFFER* (MAKE-ARRAY 128. ':TYPE 'ART-STRING ':LEADER-LENGTH 1))
[257]272
[273]273(DEFUN DEFAULT-LIST-ONE-FILE (FILE &OPTIONAL (STREAM STANDARD-OUTPUT) &AUX PATHNAME)
274  (COND ((AND (TYPEP STREAM ':CLOSURE) (EQ (CLOSURE-FUNCTION STREAM) 'INTERVAL-IO))
275         (STORE-ARRAY-LEADER 0 *DIR-LISTING-BUFFER* 0)
276         (WITH-OUTPUT-TO-STRING (S *DIR-LISTING-BUFFER*)
277           (DEFAULT-LIST-ONE-FILE FILE S))
278         (DECF (ARRAY-LEADER *DIR-LISTING-BUFFER* 0))   ;Flush the carriage return
279         (FUNCALL STREAM ':LINE-OUT *DIR-LISTING-BUFFER*))
280        ((NULL (SETQ PATHNAME (CAR FILE)))
281         (COND ((GET FILE ':DISK-SPACE-DESCRIPTION)
282                (FUNCALL STREAM ':LINE-OUT (GET FILE ':DISK-SPACE-DESCRIPTION)))
283               ((GET FILE ':PHYSICAL-VOLUME-FREE-BLOCKS)
284                (DO ((FREE (GET FILE ':PHYSICAL-VOLUME-FREE-BLOCKS) (CDR FREE))
285                     (FLAG T NIL))
286                    ((NULL FREE) (FUNCALL STREAM ':TYO #\CR))
287                 (FORMAT STREAM "~A #~A=~D" (IF FLAG "Free:" ",") (CAAR FREE) (CDAR FREE))))
288               (T
289                (FUNCALL STREAM ':TYO #\CR))))
290        (T (FUNCALL STREAM ':TYO (IF (GET FILE ':DELETED) #/D #\SP))
291           (FORMAT STREAM " ~3A " (OR (GET FILE ':PHYSICAL-VOLUME) ""))
292           (IF (FUNCALL STREAM ':OPERATION-HANDLED-P ':ITEM)
293               (FUNCALL STREAM ':ITEM 'FILE PATHNAME "~A"
294                        (FUNCALL PATHNAME ':STRING-FOR-DIRED))
295               (FUNCALL STREAM ':STRING-OUT (FUNCALL PATHNAME ':STRING-FOR-DIRED)))
296           (FORMAT STREAM "~20T")
297           (LET ((LINK-TO (GET FILE ':LINK-TO)))
298             (IF LINK-TO
299                 (FORMAT STREAM "=> ~A~41T" LINK-TO)
300                 (LET ((LENGTH (GET FILE ':LENGTH-IN-BLOCKS)))
301                   (IF LENGTH
302                       (FORMAT STREAM "~4D " LENGTH)
303                       (FORMAT STREAM "~5X")))
304                 (LET ((LENGTH (GET FILE ':LENGTH-IN-BYTES)))
305                   (AND LENGTH
306                        (FORMAT STREAM "~6D(~D)" LENGTH (GET FILE ':BYTE-SIZE))))
307                 (FORMAT STREAM "~39T")
308                 (FUNCALL STREAM ':TYO (IF (GET FILE ':NOT-BACKED-UP) #/! #\SP))
309                 (FUNCALL STREAM ':TYO (IF (GET FILE ':DONT-REAP) #/$ #\SP))))
310           (LET ((CREATION-DATE (GET FILE ':CREATION-DATE)))
311             (IF CREATION-DATE
312                 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
313                     (TIME:DECODE-UNIVERSAL-TIME CREATION-DATE)
314                   (FORMAT STREAM "~2,'0D//~2,'0D//~2,'0D ~2,'0D:~2,'0D:~2,'0D"
[291]315                           MONTH DAY (\ YEAR 100.) HOURS MINUTES SECONDS))
[273]316                 (FORMAT STREAM "~17X")))
317           (LET ((REFERENCE-DATE (GET FILE ':REFERENCE-DATE)))
318             (AND REFERENCE-DATE
319                  (MULTIPLE-VALUE-BIND (NIL NIL NIL DAY MONTH YEAR)
320                      (TIME:DECODE-UNIVERSAL-TIME REFERENCE-DATE)
[291]321                    (FORMAT STREAM " (~2,'0D//~2,'0D//~2,'0D)" MONTH DAY (\ YEAR 100.)))))
[273]322           (LET ((AUTHOR (GET FILE ':AUTHOR)))
323             (AND AUTHOR (NOT (EQUAL AUTHOR (FUNCALL PATHNAME ':DIRECTORY)))
324                  (FORMAT STREAM "~72T~A" AUTHOR)))
325           (LET ((READER (GET FILE ':READER)))
326             (AND READER (NOT (EQUAL READER (FUNCALL PATHNAME ':DIRECTORY)))
327                  (FORMAT STREAM "~82T~A" READER)))
328           (FUNCALL STREAM ':TYO #\CR))))
329
330(DEFUN READ-DIRECTORY-NAME (PROMPT PATHNAME &AUX TYPEIN)
331  (SETQ PATHNAME (FUNCALL PATHNAME ':NEW-PATHNAME ':NAME ':WILD
332                                                  ':TYPE ':WILD
333                                                  ':VERSION ':WILD)
334        PROMPT (FORMAT NIL "~A (Default is ~A)" PROMPT PATHNAME))
335  (LET ((*READING-PATHNAME-DEFAULTS* PATHNAME)
336        (*READING-PATHNAME-SPECIAL-TYPE* ':WILD)
337        (*READING-PATHNAME-SPECIAL-VERSION* ':WILD)
338        (*READING-PATHNAME-DIRECTION* ':READ))
339    (TEMP-KILL-RING *LAST-FILE-NAME-TYPED*
340      (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL)
341          (EDIT-IN-MINI-BUFFER *PATHNAME-READING-COMTAB* NIL NIL (NCONS PROMPT))
342        (SETQ TYPEIN (STRING-INTERVAL INTERVAL)))))
343  (COND ((EQUAL TYPEIN "") PATHNAME)
344;       ((NOT (DO ((I 0 (1+ I))
345;                  (LEN (STRING-LENGTH TYPEIN))
346;                  (CH))
347;                 (( I LEN) NIL)
348;               (SETQ CH (AREF TYPEIN I))
349;               (OR (AND ( CH #/A) ( CH #/Z))
350;                   (AND ( CH #/a) ( CH #/z))
351;                   (AND ( CH #/0) ( CH #/9))
352;                   (= CH #/-)
353;                   (RETURN T))))
354;        ;;No funny characters, must be just a directory name
355;        (FUNCALL PATHNAME ':NEW-DIRECTORY TYPEIN))
356        (T
357         (SETQ *LAST-FILE-NAME-TYPED* TYPEIN)
358         (FS:MERGE-PATHNAME-DEFAULTS TYPEIN PATHNAME ':WILD ':WILD))))
359
[257]360(DEFCOM COM-LIST-FILES "Brief directory listing.
[273]361Lists several files per line" ()
362  (LET* ((PATHNAME (READ-DIRECTORY-NAME "List Directory:" (DEFAULT-PATHNAME)))
363         (LIST (FS:DIRECTORY-LIST PATHNAME)))
364    (FORMAT T "~&~A~%" PATHNAME)
365    (SETQ LIST (DELQ (ASSQ NIL LIST) LIST))     ;Don't care about system info
366    (DO L LIST (CDR L) (NULL L)
367      (SETF (CAR L) (CONS (FUNCALL (CAAR L) ':STRING-FOR-DIRED) (CAAR L))))
368    (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FILE LIST))
369  DIS-NONE)
370
371(DEFUN VIEW-DIRECTORY (VIEWED-DIRECTORY)
372  (SETQ VIEWED-DIRECTORY (FS:MERGE-PATHNAME-DEFAULTS VIEWED-DIRECTORY *PATHNAME-DEFAULTS*))
373  (PROMPT-LINE "Viewing directory ~A" VIEWED-DIRECTORY)
374  (VIEW-STREAM (DIRECTORY-INPUT-STREAM VIEWED-DIRECTORY))
375  DIS-NONE)
376
377;;; This gives an input stream that does output
378(DEFUN DIRECTORY-INPUT-STREAM (DIRECTORY)
379  (LET-CLOSED ((*DIRECTORY-LIST* DIRECTORY))
380    'DIRECTORY-INPUT-STREAM-IO))
381
382(DEFUN DIRECTORY-INPUT-STREAM-IO (OP &OPTIONAL ARG1 &REST REST)
383  (DECLARE (SPECIAL *DIRECTORY-LIST*))
384  REST
385  (SELECTQ OP
386    (:WHICH-OPERATIONS '(:LINE-IN))
387    (:LINE-IN
388     (IF (EQ *DIRECTORY-LIST* 'EOF) (VALUES NIL T)
389         (LET ((STRING (MAKE-ARRAY 80. ':TYPE 'ART-STRING
390                                       ':LEADER-LENGTH (IF (NUMBERP ARG1) ARG1 1)
391                                       ':LEADER-LIST '(0))))
392           (WITH-OUTPUT-TO-STRING (S STRING)
393             (COND ((TYPEP *DIRECTORY-LIST* 'FS:PATHNAME)
394                    (FUNCALL S ':STRING-OUT (STRING *DIRECTORY-LIST*))
395                    (SETQ *DIRECTORY-LIST*
396                          (OR (FUNCALL *DIRECTORY-LIST*
397                                       ':SEND-IF-HANDLES
398                                       ':DIRECTORY-LIST-STREAM)
399                              (FS:DIRECTORY-LIST *DIRECTORY-LIST*))))
400                   ((LISTP *DIRECTORY-LIST*)
401                    (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* (POP *DIRECTORY-LIST*) S))
402                   ((CLOSUREP *DIRECTORY-LIST*)
403                    (LET ((TEM (FUNCALL *DIRECTORY-LIST*)))
404                      (IF TEM
405                          (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* TEM S)
406                        (SETQ *DIRECTORY-LIST* 'EOF)
407                        (FUNCALL S ':STRING-OUT "Done."))))
408                   (T (SETQ *DIRECTORY-LIST* 'EOF)
409                      (FUNCALL S ':STRING-OUT "Done."))))
410           (IF (= (AREF STRING (1- (ARRAY-ACTIVE-LENGTH STRING))) #\CR)
411               (DECF (ARRAY-LEADER STRING 0)))  ;Flush carriage return
412           STRING)))))
413
414;;; Obsolete ITS only functions
415(DEFCOM COM-OLD-LIST-FILES "Brief directory listing.
[257]416Lists directory N entries to a line, with the following
417special characters to the left of the filenames:
418        : this is a link
419        ! this file has not been backed up to tape yet
420        * this file has really been deleted but not yet
421          closed, or is otherwise locked.
422        (blank) this is a plain normal file
423Also the top line contains in order, the device being
424listed from, the directory, Free: followed by the number of
425free blocks on the device (separated into primary, secondary, etc.
426packs), Used: followed by the number of blocks this directory is taking up." ()
[273]427  (LET ((PATHNAME (READ-DIRECTORY-NAME "List Directory:" (DEFAULT-PATHNAME)))
[257]428        (LINE NIL) (X NIL) (Y NIL) (X1 NIL) (Y1 NIL) (TEM1 NIL)
429        (FREE-ARRAY (MAKE-ARRAY NIL 'ART-Q 10)) (USED-ARRAY (MAKE-ARRAY NIL 'ART-Q 10)))
[273]430    (WITH-OPEN-FILE (STREAM (FUNCALL PATHNAME ':DEFAULT-NAMESTRING ".FILE. (DIR)") '(READ))
[257]431      (SETQ LINE (FUNCALL STREAM ':LINE-IN))
432      (SETQ LINE (FUNCALL STREAM ':LINE-IN))
433      (DIRECTORY-FREE-SPACE LINE FREE-ARRAY)
[273]434      (FORMAT T "~6A ~6A  " (FUNCALL PATHNAME ':DEVICE) (FUNCALL PATHNAME ':DIRECTORY))
[257]435      (FORMAT-DISK-BLOCKS-ARRAY STANDARD-OUTPUT "Free: " FREE-ARRAY)
436      (FORMAT T ", Used: ")                     ;Filled in later
437      (MULTIPLE-VALUE (X Y) (FUNCALL STANDARD-OUTPUT ':READ-CURSORPOS ':PIXEL))
438      ;; Make any pack that exists show up in the "used" display even if used=0
439      (DOTIMES (IDX 10)
440        (AND (AREF FREE-ARRAY IDX)
441             (ASET 0 USED-ARRAY IDX)))
442      (DO ((I 0 (\ (1+ I) 5)))
443          (NIL)
444        (AND (ZEROP I) (TERPRI))
445        (SETQ LINE (FUNCALL STREAM ':LINE-IN))
446        (COND ((OR (NULL LINE)
447                   (ZEROP (ARRAY-ACTIVE-LENGTH LINE))
448                   (= (AREF LINE 0) #\FF))
449               (RETURN NIL)))
450        (FUNCALL STANDARD-OUTPUT ':TYO
451                 (COND ((= #/* (AREF LINE 0))
452                        #/*)
453                       ((= #/L (AREF LINE 2))
454                        #/:)
455                       (T (LET ((USED)
456                                (PACK (PARSE-NUMBER LINE 2)))
457                            (MULTIPLE-VALUE (USED TEM1) (PARSE-NUMBER LINE 20.))
458                            (LET ((IDX (IF (OR (< PACK 10.) (> PACK 16.)) 0
459                                           (- PACK 9.))))
460                              (ASET (+ (OR (AREF USED-ARRAY IDX) 0) USED)
461                                    USED-ARRAY IDX)))
462                          (COND ((= #/! (AREF LINE (1+ TEM1)))
463                                 #/!)
464                                (T #\SP)))))
465        (FUNCALL STANDARD-OUTPUT ':STRING-OUT (NSUBSTRING LINE 6 19.))
466        (FUNCALL STANDARD-OUTPUT ':STRING-OUT "  "))
467      (FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
468      (MULTIPLE-VALUE (X1 Y1) (FUNCALL STANDARD-OUTPUT ':READ-CURSORPOS ':PIXEL))
469      (FUNCALL STANDARD-OUTPUT ':SET-CURSORPOS X Y ':PIXEL)
470      (FORMAT-DISK-BLOCKS-ARRAY STANDARD-OUTPUT "" USED-ARRAY)
471      (FUNCALL STANDARD-OUTPUT ':SET-CURSORPOS X1 Y1 ':PIXEL)))
472  DIS-NONE)
[273]473
474(DEFUN SUBSET-DIRECTORY-LISTING (PATHNAME)
475  (LET ((FN1 (FUNCALL PATHNAME ':NAME))
476        (FN2 (FUNCALL PATHNAME ':FN2)))
477    (FORMAT T "~&~A~%" PATHNAME)
478    (LET ((LINE NIL)
479          (FREE-ARRAY (MAKE-ARRAY NIL 'ART-Q 10))
480          (USED-ARRAY (MAKE-ARRAY NIL 'ART-Q 10)))
481      (WITH-OPEN-FILE (STREAM (FUNCALL PATHNAME ':NEW-STRUCTURED-NAME '(".FILE." "(DIR)"))
482                              '(READ))
483        ;; First find out how much space is free.
484        (SETQ LINE (FUNCALL STREAM ':LINE-IN))
485        (SETQ LINE (FUNCALL STREAM ':LINE-IN))
486        (DIRECTORY-FREE-SPACE LINE FREE-ARRAY)
487        ;; Make any pack that exists show up in the "used" display even if used=0
488        (DOTIMES (IDX 10)
489          (AND (AREF FREE-ARRAY IDX)
490               (ASET 0 USED-ARRAY IDX)))
491        ;; Next, go through lines of dir, counting USED and printing some lines.
492        (DO ((KEY (STRING-APPEND " "
493                                 (IF (STRING-EQUAL FN1 "TS") FN2 FN1)
494                                 " "))
495             (LINE) (EOF))
496            (NIL)
497          (MULTIPLE-VALUE (LINE EOF)
498            (FUNCALL STREAM ':LINE-IN))
499          (AND (OR EOF (ZEROP (STRING-LENGTH LINE))) (RETURN NIL))
500          (AND (STRING-SEARCH KEY LINE)
501               (FUNCALL STANDARD-OUTPUT ':LINE-OUT LINE))
502          (OR (= (AREF LINE 2) #/L)
503              (LET ((USED (PARSE-NUMBER LINE 20.))
504                    (PACK (PARSE-NUMBER LINE 2)))
505                (LET ((IDX (IF (OR (< PACK 10.) (> PACK 16.)) 0
506                               (- PACK 9.))))
507                  (ASET (+ (OR (AREF USED-ARRAY IDX) 0) USED) USED-ARRAY IDX)))))
508        (FORMAT-DISK-BLOCKS-ARRAY T "Free: " FREE-ARRAY)
509        (FORMAT-DISK-BLOCKS-ARRAY T ", Used: " USED-ARRAY)))))
[257]510
[273]511;Element 0 of FREE-ARRAY is for packs other than 10.-16.
512(DEFUN DIRECTORY-FREE-SPACE (LINE FREE-ARRAY)
513  (DO ((I (STRING-SEARCH-CHAR #/# LINE)
514          (STRING-SEARCH-CHAR #/# LINE I))
515       (NUM) (IDX) (BLKS))
516      ((NULL I))
517    (MULTIPLE-VALUE (NUM I)
518      (PARSE-NUMBER LINE (1+ I)))
519    (MULTIPLE-VALUE (BLKS I)
520      (PARSE-NUMBER LINE (1+ I)))
521    (SETQ IDX (IF (OR (< NUM 10.) (> NUM 16.)) 0
522                  (- NUM 9.)))
523    (ASET (+ (OR (AREF FREE-ARRAY IDX) 0) BLKS) FREE-ARRAY IDX)))
524
525(DEFUN FORMAT-DISK-BLOCKS-ARRAY (STREAM TITLE ARRAY)
526  (FORMAT STREAM TITLE)
527  (DO ((IDX 0 (1+ IDX))
528       (LIM (ARRAY-LENGTH ARRAY))
529       (FIRSTP T)
530       (BLKS))
531      ((= IDX LIM))
532    (COND ((SETQ BLKS (AREF ARRAY IDX))
533           (FORMAT STREAM "~:[+~]~D" FIRSTP BLKS)
534           (SETQ FIRSTP NIL)))))
535
536(DEFUN ROTATED-DIRECTORY-LISTING (PATHNAME)
[257]537  (*CATCH 'ABORT
[273]538     (LET ((DEV (FUNCALL PATHNAME ':DEVICE))
539           (DIR (FUNCALL PATHNAME ':DIRECTORY))
540           (FN1 (FUNCALL PATHNAME ':NAME))
[257]541           (FN NIL))
[273]542       (SETQ FN (FUNCALL PATHNAME ':NEW-STRUCTURED-NAME '(".FILE." "(DIR)")))
[257]543       (PROMPT-LINE "Directory Listing")
[273]544       (FORMAT T "~&~A  ~A    --   ~A~%" DEV DIR PATHNAME)
[257]545       (LET ((LINE NIL) (X 0) (Y 0))
[273]546         (WITH-OPEN-FILE (STREAM FN '(IN))
[257]547           (SETQ LINE (FUNCALL STREAM ':LINE-IN))
548           (FORMAT T "~A~%" (FUNCALL STREAM ':LINE-IN))
549           (DO ((LINE (SETQ LINE (FUNCALL STREAM ':LINE-IN))
550                      (SETQ LINE (FUNCALL STREAM ':LINE-IN)))
551                (LFN1 (STRING-LENGTH FN1))
552                (LFN16 (+ (STRING-LENGTH FN1) 6))
553                )
554               ((NULL LINE)
555                (FORMAT T "There is no file named ~A in the directory.~%" FN1))
556             (COND ((STRING-EQUAL LINE FN1 6 0 LFN16 LFN1)
557                    ;; Found one.
558                    (LET ((FIRST LINE))
559                      (SETQ LINE (DO ((LINE LINE (FUNCALL STREAM ':LINE-IN)))
560                                     ((OR (= (AREF LINE 0) #\FF)
561                                          (NOT (STRING-EQUAL LINE FN1 6 0 LFN16 LFN1)))
562                                      LINE)
563                                   (FORMAT T "~A~%" LINE)))
564                      (FORMAT T "==MORE==")
[273]565                      (OR (= (FUNCALL STANDARD-INPUT ':TYI) #\SP)
566                          (*THROW 'ABORT NIL))
[257]567                      (MULTIPLE-VALUE (X Y)
[273]568                        (FUNCALL STANDARD-OUTPUT ':READ-CURSORPOS))
569                      (FUNCALL STANDARD-OUTPUT ':SET-CURSORPOS 0 Y)
[257]570                      (FUNCALL STANDARD-OUTPUT ':CLEAR-EOL)
571                      (DO ((LINE LINE (FUNCALL STREAM ':LINE-IN)))
572                          ((EQUAL LINE FIRST))
[273]573                        (COND ((ZEROP (STRING-LENGTH LINE))
[257]574                               (FORMAT T "------------------------------------------------~%")
575                               (CLOSE STREAM)
576                               (SETQ STREAM (OPEN FN '(IN)))
577                               (FUNCALL STREAM ':LINE-IN)
578                               (FUNCALL STREAM ':LINE-IN)
579                               (SETQ LINE (FUNCALL STREAM ':LINE-IN))))
580                        (FORMAT T "~A~%" LINE)))
581                    (RETURN NIL)))))))))
[273]582
583(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* DIRECTORY "Edit" DIRECTORY-EDIT-1
584                          T "Run DIRED on this directory.")
585
586(DEFUN DIRECTORY-EDIT-1 (DIRECTORY)
587  (DIRECTORY-EDIT DIRECTORY)
588  NIL)
589
590(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* DIRECTORY "View" VIEW-DIRECTORY
591                          NIL "View this directory")
592
593(DEFCOM COM-LIST-ALL-DIRECTORY-NAMES "List names of all disk directories." ()
594  (LET* ((DEFAULT (FUNCALL (DEFAULT-PATHNAME) ':NEW-PATHNAME
595                           ':DIRECTORY ':WILD ':NAME ':UNSPECIFIC
596                           ':TYPE ':UNSPECIFIC ':VERSION ':UNSPECIFIC))
597         (PATHNAME (IF (OR *NUMERIC-ARG-P*
598                           (NULL (ZWEI:BUFFER-PATHNAME *INTERVAL*)))
599                       (READ-DEFAULTED-PATHNAME "List directories:" DEFAULT
600                                                ':UNSPECIFIC ':UNSPECIFIC)
601                       DEFAULT))
602         (DIRS (FS:ALL-DIRECTORIES PATHNAME ':NOERROR)))
603    (IF (STRINGP DIRS)
604        (BARF "Error: ~A" DIRS)
605        (SETQ DIRS (SORTCAR DIRS #'FS:PATHNAME-LESSP))
606        (FUNCALL STANDARD-OUTPUT ':ITEM-LIST 'DIRECTORY
607                 (LOOP FOR (PATHNAME) IN DIRS
608                       COLLECT `(,(FUNCALL PATHNAME ':STRING-FOR-DIRECTORY)
609                                 . ,(FUNCALL PATHNAME ':NEW-PATHNAME ':NAME ':WILD
610                                             ':TYPE ':WILD ':VERSION ':WILD))))))
611  DIS-NONE)
612
613(DEFCOM COM-EXPUNGE-DIRECTORY "Expunge deleted files from a directory" ()
614  (LET* ((DIRECTORY (READ-DIRECTORY-NAME "Expunge directory" (DEFAULT-PATHNAME)))
615         (RESULT (FS:EXPUNGE-DIRECTORY DIRECTORY ':ERROR NIL)))
616    (IF (STRINGP RESULT) (BARF "Cannot expunge ~A: ~A" DIRECTORY RESULT)
617        (TYPEIN-LINE "~A: ~D block~:P freed" DIRECTORY RESULT)))
618  DIS-NONE)
Note: See TracBrowser for help on using the browser.