Skip to content

Commit 1438ddb

Browse files
rmkaplanrmkaplan
committed
UFS, CMLFILESYS: Honor default extension and version for subdirectory enumeration
1 parent ae3851c commit 1438ddb

File tree

4 files changed

+519
-180
lines changed

4 files changed

+519
-180
lines changed

‎sources/CMLFILESYS‎

Lines changed: 137 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,37 +1,139 @@
11
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
2-
(filecreated " 8-Jun-90 16:41:26" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;4| 4326
32

4-
|changes| |to:| (functions cl:directory cl:user-homedir-pathname)
5-
6-
|previous| |date:| " 4-Jun-90 14:56:58" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;3|)
7-
8-
9-
; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
10-
11-
(prettycomprint cmlfilesyscoms)
12-
13-
(rpaqq cmlfilesyscoms ((functions cl:directory cl:file-author cl:file-length cl:file-position cl:user-homedir-pathname cl:file-write-date) (functions cl:probe-file cl:rename-file cl:delete-file) (prop filetype cmlfilesys)))
14-
15-
(cl:defun cl:directory (pathname) (let (generator file) (declare (cl:special generator)) (resetlst (|if| (eql \\machinetype \\maiko) |then| (resetsave nil (quote (and resetstate (\\ufs.abort.cl-directory))))) (cl:setq generator (\\generatefiles (directory.fill.pattern (cl:namestring pathname)) nil (quote (sort resetlst)))) (|while| (setq file (\\generatenextfile generator)) |collect| (pathname file)))))
16-
17-
(cl:defun cl:file-author (cl::file) (* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.") (let ((cl::author (getfileinfo cl::file (quote author)))) (cl:if cl::author (coerce cl::author (quote cl:simple-string)) nil)))
18-
19-
(cl:defun cl:file-length (file-stream) (|if| (and (streamp file-stream) (openp file-stream)) |then| (geteofptr file-stream)))
20-
21-
(cl:defun cl:file-position (cl::file-stream &optional (cl:position nil cl::positionp)) (cl:unless (streamp cl::file-stream) (\\illegal.arg cl::file-stream)) (cl:if cl::positionp (cl:if (randaccessp cl::file-stream) (progn (setfileptr cl::file-stream (case cl:position (:start 0) (:end (geteofptr cl::file-stream)) (t cl:position))) t) nil) (getfileptr cl::file-stream)))
22-
23-
(cl:defun cl:user-homedir-pathname (&optional host) (declare (globalvars loginhost/dir *default-pathname-defaults*)) (cl:if (machinetype (quote maiko)) (cl:if (and host (cl:string-not-equal (string host) (unix-getparm "HOSTNAME"))) nil (cl:make-pathname :host :dsk :directory (unpackfilename.string (unix-getenv "HOME") (quote directory) (quote return)))) (pathname (or loginhost/dir *default-pathname-defaults*))))
24-
25-
(cl:defun cl:file-write-date (file) (* |;;| "Return file's creation date, or NIL if it doesn't exist.") (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time") (let ((tn (cl:probe-file file))) (cl:when tn (%convert-internal-time-to-clut (getfileinfo tn (quote icreationdate))))))
26-
27-
(cl:defun cl:probe-file (file) (* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.") (if (streamp file) then (if (openp file) then (pathname (fetch (stream fullname) of file)) else (let ((namestring-if-exists (infilep (fetch (stream fullname) of file)))) (and namestring-if-exists (pathname namestring-if-exists)))) else (let ((infilep (\\getfilename file (quote old)))) (if infilep then (pathname infilep) else nil))))
28-
29-
(cl:defun cl:rename-file (file new-name) (* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.") (let ((old-pathname (pathname file)) (cl::new-fullname)) (if (streamp file) then (if (openp file) then (cl:error "Renaming open streams is not supported: ~S" file) else (setq cl::new-fullname (renamefile (setq file (fetch (stream fullname) of file)) new-name))) else (setq cl::new-fullname (renamefile file new-name))) (if cl::new-fullname then (cl:values (cl:merge-pathnames new-name file) old-pathname (pathname cl::new-fullname)) else (cl:error "Rename failed"))))
30-
31-
(cl:defun cl:delete-file (file) (* * "Delete the specified file.") (let ((tn (cl:probe-file file))) (cl:when (streamp file) (cl:close file :abort t)) (cl:if tn (let ((ns (interlisp-namestring tn))) (cl:unless (delfile ns) (cl:error "Could not delete the file ~S" file))) (cl:unless (streamp file) (cl:error "File to be deleted does not exist: ~S" file)))) t)
32-
33-
(putprops cmlfilesys filetype cl:compile-file)
34-
(putprops cmlfilesys copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990))
35-
(declare\: dontcopy
36-
(filemap (nil)))
37-
stop
3+
(FILECREATED "23-Jan-2022 12:32:16" 
4+
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;4| 6055
5+
6+
:CHANGES-TO (FUNCTIONS CL:DIRECTORY)
7+
8+
:PREVIOUS-DATE "22-Jan-2022 09:26:49"
9+
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;3|)
10+
11+
12+
; Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
13+
14+
(PRETTYCOMPRINT CMLFILESYSCOMS)
15+
16+
(RPAQQ CMLFILESYSCOMS ((FUNCTIONS CL:DIRECTORY CL:FILE-AUTHOR CL:FILE-LENGTH CL:FILE-POSITION
17+
CL:USER-HOMEDIR-PATHNAME CL:FILE-WRITE-DATE)
18+
(FUNCTIONS CL:PROBE-FILE CL:RENAME-FILE CL:DELETE-FILE)
19+
(PROP FILETYPE CMLFILESYS)))
20+
21+
(CL:DEFUN CL:DIRECTORY (PATHNAME &KEY CL::DEFAULTEXT CL::DEFAULTVERS)
22+
(* \; "Edited 23-Jan-2022 12:32 by rmk")
23+
(* \; "Edited 22-Jan-2022 09:26 by rmk")
24+
(LET (GENERATOR FILE)
25+
(DECLARE (CL:SPECIAL GENERATOR))
26+
(RESETLST
27+
(CL:WHEN (EQL \\MACHINETYPE \\MAIKO)
28+
(RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY))))
29+
(CL:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (CL:NAMESTRING PATHNAME)
30+
CL::DEFAULTEXT CL::DEFAULTVERS)
31+
NIL
32+
'(SORT RESETLST)))
33+
(|while| (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect| (PATHNAME FILE)))))
34+
35+
(CL:DEFUN CL:FILE-AUTHOR (CL::FILE)
36+
37+
(* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.")
38+
39+
(LET ((CL::AUTHOR (GETFILEINFO CL::FILE 'AUTHOR)))
40+
(CL:IF CL::AUTHOR
41+
(COERCE CL::AUTHOR 'CL:SIMPLE-STRING)
42+
NIL)))
43+
44+
(CL:DEFUN CL:FILE-LENGTH (FILE-STREAM)
45+
(|if| (AND (STREAMP FILE-STREAM)
46+
(OPENP FILE-STREAM))
47+
|then| (GETEOFPTR FILE-STREAM)))
48+
49+
(CL:DEFUN CL:FILE-POSITION (CL::FILE-STREAM &OPTIONAL (CL:POSITION NIL CL::POSITIONP))
50+
(CL:UNLESS (STREAMP CL::FILE-STREAM)
51+
(\\ILLEGAL.ARG CL::FILE-STREAM))
52+
(CL:IF CL::POSITIONP
53+
(CL:IF (RANDACCESSP CL::FILE-STREAM)
54+
(PROGN (SETFILEPTR CL::FILE-STREAM (CASE CL:POSITION
55+
(:START 0)
56+
(:END (GETEOFPTR CL::FILE-STREAM))
57+
(T CL:POSITION)))
58+
T)
59+
NIL)
60+
(GETFILEPTR CL::FILE-STREAM)))
61+
62+
(CL:DEFUN CL:USER-HOMEDIR-PATHNAME (&OPTIONAL HOST)
63+
(DECLARE (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))
64+
(CL:IF (MACHINETYPE 'MAIKO)
65+
(CL:IF (AND HOST (CL:STRING-NOT-EQUAL (STRING HOST)
66+
(UNIX-GETPARM "HOSTNAME")))
67+
NIL
68+
(CL:MAKE-PATHNAME :HOST :DSK :DIRECTORY (UNPACKFILENAME.STRING (UNIX-GETENV "HOME")
69+
'DIRECTORY
70+
'RETURN)))
71+
(PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))))
72+
73+
(CL:DEFUN CL:FILE-WRITE-DATE (FILE)
74+
75+
(* |;;| "Return file's creation date, or NIL if it doesn't exist.")
76+
77+
(* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time")
78+
79+
(LET ((TN (CL:PROBE-FILE FILE)))
80+
(CL:WHEN TN
81+
(%CONVERT-INTERNAL-TIME-TO-CLUT (GETFILEINFO TN 'ICREATIONDATE)))))
82+
83+
(CL:DEFUN CL:PROBE-FILE (FILE)
84+
85+
(* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.")
86+
87+
(IF (STREAMP FILE)
88+
THEN (IF (OPENP FILE)
89+
THEN (PATHNAME (FETCH (STREAM FULLNAME) OF FILE))
90+
ELSE (LET ((NAMESTRING-IF-EXISTS (INFILEP (FETCH (STREAM FULLNAME) OF FILE))))
91+
(AND NAMESTRING-IF-EXISTS (PATHNAME NAMESTRING-IF-EXISTS))))
92+
ELSE (LET ((INFILEP (\\GETFILENAME FILE 'OLD)))
93+
(IF INFILEP
94+
THEN (PATHNAME INFILEP)
95+
ELSE NIL))))
96+
97+
(CL:DEFUN CL:RENAME-FILE (FILE NEW-NAME)
98+
99+
(* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.")
100+
101+
(LET ((OLD-PATHNAME (PATHNAME FILE))
102+
(CL::NEW-FULLNAME))
103+
(IF (STREAMP FILE)
104+
THEN (IF (OPENP FILE)
105+
THEN (CL:ERROR "Renaming open streams is not supported: ~S" FILE)
106+
ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE (SETQ FILE (FETCH (STREAM FULLNAME)
107+
OF FILE))
108+
NEW-NAME)))
109+
ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE FILE NEW-NAME)))
110+
(IF CL::NEW-FULLNAME
111+
THEN (CL:VALUES (CL:MERGE-PATHNAMES NEW-NAME FILE)
112+
OLD-PATHNAME
113+
(PATHNAME CL::NEW-FULLNAME))
114+
ELSE (CL:ERROR "Rename failed"))))
115+
116+
(CL:DEFUN CL:DELETE-FILE (FILE)
117+
118+
(* * "Delete the specified file.")
119+
120+
(LET ((TN (CL:PROBE-FILE FILE)))
121+
(CL:WHEN (STREAMP FILE)
122+
(CL:CLOSE FILE :ABORT T))
123+
(CL:IF TN
124+
(LET ((NS (INTERLISP-NAMESTRING TN)))
125+
(CL:UNLESS (DELFILE NS)
126+
(CL:ERROR "Could not delete the file ~S" FILE)))
127+
(CL:UNLESS (STREAMP FILE)
128+
(CL:ERROR "File to be deleted does not exist: ~S" FILE))))
129+
T)
130+
131+
(PUTPROPS CMLFILESYS FILETYPE CL:COMPILE-FILE)
132+
(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
133+
(DECLARE\: DONTCOPY
134+
(FILEMAP (NIL (751 1642 (CL:DIRECTORY 751 . 1642)) (1644 1950 (CL:FILE-AUTHOR 1644 . 1950)) (1952 2113
135+
(CL:FILE-LENGTH 1952 . 2113)) (2115 2709 (CL:FILE-POSITION 2115 . 2709)) (2711 3302 (
136+
CL:USER-HOMEDIR-PATHNAME 2711 . 3302)) (3304 3662 (CL:FILE-WRITE-DATE 3304 . 3662)) (3664 4329 (
137+
CL:PROBE-FILE 3664 . 4329)) (4331 5387 (CL:RENAME-FILE 4331 . 5387)) (5389 5894 (CL:DELETE-FILE 5389
138+
. 5894)))))
139+
STOP

‎sources/CMLFILESYS.LCOM‎

260 Bytes
Binary file not shown.

0 commit comments

Comments
 (0)