UFS, CMLFILESYS: Honor default extension and version for subdirectory enumeration
This commit is contained in:
rmkaplan
@@ -1,37 +1,139 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(filecreated " 8-Jun-90 16:41:26" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;4| 4326
|
||||
|
||||
|changes| |to:| (functions cl:directory cl:user-homedir-pathname)
|
||||
(FILECREATED "23-Jan-2022 12:32:16"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;4| 6055
|
||||
|
||||
|previous| |date:| " 4-Jun-90 14:56:58" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;3|)
|
||||
:CHANGES-TO (FUNCTIONS CL:DIRECTORY)
|
||||
|
||||
:PREVIOUS-DATE "22-Jan-2022 09:26:49"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;3|)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
|
||||
|
||||
(prettycomprint cmlfilesyscoms)
|
||||
(PRETTYCOMPRINT CMLFILESYSCOMS)
|
||||
|
||||
(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)))
|
||||
(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)))
|
||||
|
||||
(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)))))
|
||||
(CL:DEFUN CL:DIRECTORY (PATHNAME &KEY CL::DEFAULTEXT CL::DEFAULTVERS)
|
||||
(* \; "Edited 23-Jan-2022 12:32 by rmk")
|
||||
(* \; "Edited 22-Jan-2022 09:26 by rmk")
|
||||
(LET (GENERATOR FILE)
|
||||
(DECLARE (CL:SPECIAL GENERATOR))
|
||||
(RESETLST
|
||||
(CL:WHEN (EQL \\MACHINETYPE \\MAIKO)
|
||||
(RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY))))
|
||||
(CL:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (CL:NAMESTRING PATHNAME)
|
||||
CL::DEFAULTEXT CL::DEFAULTVERS)
|
||||
NIL
|
||||
'(SORT RESETLST)))
|
||||
(|while| (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect| (PATHNAME FILE)))))
|
||||
|
||||
(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)))
|
||||
(CL:DEFUN CL:FILE-AUTHOR (CL::FILE)
|
||||
|
||||
(cl:defun cl:file-length (file-stream) (|if| (and (streamp file-stream) (openp file-stream)) |then| (geteofptr file-stream)))
|
||||
(* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.")
|
||||
|
||||
(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)))
|
||||
(LET ((CL::AUTHOR (GETFILEINFO CL::FILE 'AUTHOR)))
|
||||
(CL:IF CL::AUTHOR
|
||||
(COERCE CL::AUTHOR 'CL:SIMPLE-STRING)
|
||||
NIL)))
|
||||
|
||||
(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*))))
|
||||
(CL:DEFUN CL:FILE-LENGTH (FILE-STREAM)
|
||||
(|if| (AND (STREAMP FILE-STREAM)
|
||||
(OPENP FILE-STREAM))
|
||||
|then| (GETEOFPTR FILE-STREAM)))
|
||||
|
||||
(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))))))
|
||||
(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)))
|
||||
|
||||
(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))))
|
||||
(CL:DEFUN CL:USER-HOMEDIR-PATHNAME (&OPTIONAL HOST)
|
||||
(DECLARE (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))
|
||||
(CL:IF (MACHINETYPE '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")
|
||||
'DIRECTORY
|
||||
'RETURN)))
|
||||
(PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))))
|
||||
|
||||
(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"))))
|
||||
(CL:DEFUN CL:FILE-WRITE-DATE (FILE)
|
||||
|
||||
(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)
|
||||
(* |;;| "Return file's creation date, or NIL if it doesn't exist.")
|
||||
|
||||
(putprops cmlfilesys filetype cl:compile-file)
|
||||
(putprops cmlfilesys copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990))
|
||||
(declare\: dontcopy
|
||||
(filemap (nil)))
|
||||
stop
|
||||
(* |;;| "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 'ICREATIONDATE)))))
|
||||
|
||||
(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 'OLD)))
|
||||
(IF INFILEP
|
||||
THEN (PATHNAME INFILEP)
|
||||
ELSE NIL))))
|
||||
|
||||
(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"))))
|
||||
|
||||
(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)
|
||||
|
||||
(PUTPROPS CMLFILESYS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (751 1642 (CL:DIRECTORY 751 . 1642)) (1644 1950 (CL:FILE-AUTHOR 1644 . 1950)) (1952 2113
|
||||
(CL:FILE-LENGTH 1952 . 2113)) (2115 2709 (CL:FILE-POSITION 2115 . 2709)) (2711 3302 (
|
||||
CL:USER-HOMEDIR-PATHNAME 2711 . 3302)) (3304 3662 (CL:FILE-WRITE-DATE 3304 . 3662)) (3664 4329 (
|
||||
CL:PROBE-FILE 3664 . 4329)) (4331 5387 (CL:RENAME-FILE 4331 . 5387)) (5389 5894 (CL:DELETE-FILE 5389
|
||||
. 5894)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
523
sources/UFS
523
sources/UFS
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Apr-2021 11:36:54" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>UFS.;5 69271
|
||||
|
||||
changes to%: (FNS \UFSeol)
|
||||
(FILECREATED "22-Jan-2022 09:06:35" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>UFS.;4 79559
|
||||
|
||||
previous date%: "20-Apr-2021 12:11:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>UFS.;4)
|
||||
:CHANGES-TO (FNS \UFSGenerateFiles \UFS.NEXTFILEFN)
|
||||
|
||||
:PREVIOUS-DATE "22-Jan-2022 08:36:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>UFS.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -19,7 +20,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
|
||||
DIRECTORY FILEIO))
|
||||
(INITVARS (\UFS.DEFAULT.EOLC NIL))
|
||||
(COMS (* ; "Create FDEV function.")
|
||||
(COMS (* ; "Create FDEV function.")
|
||||
(FNS \UFSCreateDevice \UFS.CREATE.DEVICE \UFSOpenDevice \UFSCloseDevice)
|
||||
(INITVARS (\UFSdevice)
|
||||
(\UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor")))
|
||||
@@ -27,15 +28,14 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS UFSGENFILESTATE)))
|
||||
(INITRECORDS UFSGENFILESTATE)
|
||||
(SYSRECORDS UFSGENFILESTATE))
|
||||
(COMS (* ;
|
||||
"UNIX File System's FDEV methods.")
|
||||
(COMS (* ; "UNIX File System's FDEV methods.")
|
||||
(FNS \UFSOpenFile \UFS.OPENP \UFS.RECOGNIZE.FILE \UFS.DIRECTORY.NAME \UFSCloseFile
|
||||
\UFSGetFileName \UFSDeleteFile \UFSRenameFile \UFSReadPages \UFSWritePages
|
||||
\UFSTruncateFile \UFSDirectoryNameP \UFSEventFn \UFSGetFileInfo \UFS.CREATE.PROPS
|
||||
\UFSSetFileInfo \UFSGenerateFiles \UFS.NEXTFILEFN \UFS.FILEINFOFN \UFS.VALID.PROPP
|
||||
\UFS.REGISTER.GFS \UFS.UNREGISTER.GFS \UFS.ABORT.DIRECTORY \UFS.ABORT.CL-DIRECTORY
|
||||
\UFS.CLEANUP.GFS.TABLE))
|
||||
(COMS (* ; "File Name parsing")
|
||||
(COMS (* ; "File Name parsing")
|
||||
(FNS \UFSMakeUnixFormatName \UFSParseNameString \UFSParse-Directory \UFS.PARSE.BODY
|
||||
\UFS.ADJUST.HOST \UFS.FULLNAME \UFS.ADD.HOST.FIELD \UFS.REMOVE.HOST.FIELD
|
||||
\UFS.HANDLE.RELATIVEDIRECTORY)
|
||||
@@ -56,22 +56,22 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
\UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE
|
||||
*DSK-HOST-NAME* *UFS-HOST-NAME*))
|
||||
(COMS
|
||||
(* ;; "Change UNIX Curent Directory")
|
||||
(* ;; "Change UNIX Curent Directory")
|
||||
|
||||
(FNS CHDIR)
|
||||
|
||||
(* ;; "To access UNIX special files by like {UNIX}/dev/ttya.")
|
||||
(* ;; "To access UNIX special files by like {UNIX}/dev/ttya.")
|
||||
|
||||
(FNS \DEVICEFILE.EOSERROR)
|
||||
|
||||
(* ;; "flush/revalidate unvisible stream, like dribble files.")
|
||||
(* ;; "flush/revalidate unvisible stream, like dribble files.")
|
||||
|
||||
(FNS \UNVISIBLE.PAGED.REVALIDATEFILELST \UNVISIBLE.FLUSH.OPEN.STREAMS)
|
||||
|
||||
(* ;; " Error handler")
|
||||
(* ;; " Error handler")
|
||||
|
||||
(FNS \UFSError))
|
||||
(COMS (* ; "File Type and EOL handling")
|
||||
(COMS (* ; "File Type and EOL handling")
|
||||
(FNS \UFSGetFileType \UFSSetFileType \UFSeol)
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DEFAULTFILETYPE 'BINARY)
|
||||
(DEFAULTFILETYPELIST '((NIL . BINARY)
|
||||
@@ -110,11 +110,11 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(VM . BINARY]
|
||||
(GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (COMS * UFSDECLS))
|
||||
(COMS (* ; "Filetypepatch functions. ")
|
||||
(COMS (* ; "Filetypepatch functions. ")
|
||||
(FNS \UFSGetPrintFileType \UFSGetFileTypeConfirm \UFSPrintTypeMenu)
|
||||
(* ; "for hardcopy")
|
||||
(* ; "for hardcopy")
|
||||
(FNS \UFStoOtherCopyMess \UFStoOtherRenameMess)
|
||||
(* ; "for copyfile,renamefile")
|
||||
(* ; "for copyfile,renamefile")
|
||||
(INITVARS (FileTypeConfirmFlg T))
|
||||
(GLOBALVARS FileTypeMenu FileTypeConfirmFlg))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
@@ -166,35 +166,38 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE UFSGENFILESTATE (
|
||||
(* ;;
|
||||
"Holds the file-directory-generator state for %"Unix%" file system enumeration.")
|
||||
(* ;;
|
||||
"Holds the file-directory-generator state for %"Unix%" file system enumeration.")
|
||||
|
||||
(FINFOID FIXP)
|
||||
(FILEID FIXP) (* ;
|
||||
"Current file in list of 1 to TOTALNUM files.")
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS (* ;
|
||||
"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.")
|
||||
CURRENT-DEPTH (* ;
|
||||
"Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH")
|
||||
MAX-DEPTH (* ;
|
||||
"Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.")
|
||||
))
|
||||
(FINFOID FIXP)
|
||||
(FILEID FIXP) (* ;
|
||||
"Current file in list of 1 to TOTALNUM files.")
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS (* ;
|
||||
"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.")
|
||||
CURRENT-DEPTH (* ;
|
||||
"Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH")
|
||||
MAX-DEPTH (* ;
|
||||
"Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.")
|
||||
DEFAULTEXT (* ;
|
||||
"Value of DEFAULTEXT, so we can propagate it through subdirectories")
|
||||
DEFAULTVERS (* ; "Value of DEFAULTVERS")
|
||||
))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'UFSGENFILESTATE
|
||||
'(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP
|
||||
POINTER POINTER POINTER)
|
||||
POINTER POINTER POINTER POINTER POINTER)
|
||||
'((UFSGENFILESTATE 0 FIXP)
|
||||
(UFSGENFILESTATE 2 FIXP)
|
||||
(UFSGENFILESTATE 4 FIXP)
|
||||
@@ -212,8 +215,10 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(UFSGENFILESTATE 26 FIXP)
|
||||
(UFSGENFILESTATE 28 POINTER)
|
||||
(UFSGENFILESTATE 30 POINTER)
|
||||
(UFSGENFILESTATE 32 POINTER))
|
||||
'34)
|
||||
(UFSGENFILESTATE 32 POINTER)
|
||||
(UFSGENFILESTATE 34 POINTER)
|
||||
(UFSGENFILESTATE 36 POINTER))
|
||||
'38)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
@@ -221,7 +226,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(/DECLAREDATATYPE 'UFSGENFILESTATE
|
||||
'(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP
|
||||
POINTER POINTER POINTER)
|
||||
POINTER POINTER POINTER POINTER POINTER)
|
||||
'((UFSGENFILESTATE 0 FIXP)
|
||||
(UFSGENFILESTATE 2 FIXP)
|
||||
(UFSGENFILESTATE 4 FIXP)
|
||||
@@ -239,24 +244,26 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(UFSGENFILESTATE 26 FIXP)
|
||||
(UFSGENFILESTATE 28 POINTER)
|
||||
(UFSGENFILESTATE 30 POINTER)
|
||||
(UFSGENFILESTATE 32 POINTER))
|
||||
'34)
|
||||
(UFSGENFILESTATE 32 POINTER)
|
||||
(UFSGENFILESTATE 34 POINTER)
|
||||
(UFSGENFILESTATE 36 POINTER))
|
||||
'38)
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE UFSGENFILESTATE ((FINFOID FIXP)
|
||||
(FILEID FIXP)
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS CURRENT-DEPTH MAX-DEPTH))
|
||||
(FILEID FIXP)
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS CURRENT-DEPTH MAX-DEPTH DEFAULTEXT DEFAULTVERS))
|
||||
)
|
||||
|
||||
|
||||
@@ -330,12 +337,244 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(\UFSGenerateFiles
|
||||
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 27-Sep-93 16:17 by jds") (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) (DIRECTORY (OR (LISTGET PARSED (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED (QUOTE RELATIVEDIRECTORY)) FDEV) (\UFS.DEFAULT.DIR FDEV))) (DEVICE (LISTGET PARSED (QUOTE DEVICE))) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN) (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) (SETQ FILTER (COND ((STREQUAL DIRECTORY "<") (CONCAT "{" (LISTGET PARSED (QUOTE HOST)) "}" (OR DEVICE "") "<" (PACKFILENAME.STRING (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*")))) (T (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY (QUOTE HOST) (LISTGET PARSED (QUOTE HOST)) (QUOTE DEVICE) DEVICE (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*"))))) (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) (COND ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR)))) (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND ((< TOTALNUM 0) (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR)))) (T (COND ((ZEROP TOTALNUM) (RETURN (\NULLFILEGENERATOR))) (T (AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS (QUOTE RESETLST))) (FMEMB (QUOTE RESETLST) OPTIONS)) (RESETSAVE NIL (QUOTE (AND RESETSTATE (\UFSFinishFileInfo-C ID))))) (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN)) CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH))))))))))))
|
||||
)
|
||||
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
|
||||
|
||||
(* ;;
|
||||
"Edited 22-Jan-2022 09:06 by rmk: Capture current free values of DEFAULTEXT and DEFAULTVERS")
|
||||
|
||||
(* ;; "Edited 27-Sep-93 16:17 by jds")
|
||||
|
||||
(DECLARE (SPECVARS DEFAULTEXT DEFAULTVERS))
|
||||
|
||||
(* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.")
|
||||
|
||||
(WITH.MONITOR (\UFSGetMonitor FDEV)
|
||||
[PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN))
|
||||
(DIRECTORY (OR (LISTGET PARSED 'DIRECTORY)
|
||||
(\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY)
|
||||
FDEV)
|
||||
(\UFS.DEFAULT.DIR FDEV)))
|
||||
(DEVICE (LISTGET PARSED 'DEVICE))
|
||||
(NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
|
||||
FILTER LEN)
|
||||
(COND
|
||||
((STREQUAL DIRECTORY "/")
|
||||
(SETQ DIRECTORY "<")))
|
||||
[SETQ FILTER (COND
|
||||
[(STREQUAL DIRECTORY "<")
|
||||
(CONCAT "{" (LISTGET PARSED 'HOST)
|
||||
"}"
|
||||
(OR DEVICE "")
|
||||
"<"
|
||||
(PACKFILENAME.STRING 'NAME (OR (LISTGET PARSED 'NAME)
|
||||
"*")
|
||||
'EXTENSION
|
||||
(OR (LISTGET PARSED 'EXTENSION)
|
||||
"*")
|
||||
'VERSION
|
||||
(OR (LISTGET PARSED 'VERSION)
|
||||
"*"]
|
||||
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET
|
||||
PARSED
|
||||
'HOST)
|
||||
'DEVICE DEVICE 'NAME (OR (LISTGET PARSED 'NAME)
|
||||
"*")
|
||||
'EXTENSION
|
||||
(OR (LISTGET PARSED 'EXTENSION)
|
||||
"*")
|
||||
'VERSION
|
||||
(OR (LISTGET PARSED 'VERSION)
|
||||
"*"]
|
||||
(SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "")
|
||||
DIRECTORY)
|
||||
NAMEAREA FDEV))
|
||||
[COND
|
||||
((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case")
|
||||
(PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory")
|
||||
(RETURN (\NULLFILEGENERATOR]
|
||||
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN))
|
||||
|
||||
(* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.")
|
||||
|
||||
(LET ((ID (CREATECELL \FIXP))
|
||||
(ERRNO (CREATECELL \FIXP))
|
||||
(PROPP (\UFS.VALID.PROPP DESIREDPROPS))
|
||||
TOTALNUM)
|
||||
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
|
||||
(COND
|
||||
[(< TOTALNUM 0)
|
||||
(OR (\UFSError DIRECTORY ERRNO FDEV)
|
||||
(RETURN (\NULLFILEGENERATOR]
|
||||
(T (COND
|
||||
((ZEROP TOTALNUM)
|
||||
(RETURN (\NULLFILEGENERATOR)))
|
||||
(T [AND (OR (AND (NOT (LISTP OPTIONS))
|
||||
(EQ OPTIONS 'RESETLST))
|
||||
(FMEMB 'RESETLST OPTIONS))
|
||||
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
|
||||
(RETURN (create FILEGENOBJ
|
||||
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
|
||||
FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN)
|
||||
GENFILESTATE _
|
||||
(\UFS.REGISTER.GFS (create UFSGENFILESTATE
|
||||
FINFOID _ ID
|
||||
FILEID _ 0
|
||||
TOTALNUM _ TOTALNUM
|
||||
DIRECTORY _ DIRECTORY
|
||||
DEV _ FDEV
|
||||
PROPP _ PROPP
|
||||
NAME _ (ALLOCSTRING
|
||||
MAX-PATHNAME-LEN
|
||||
)
|
||||
AUTHOR _ (AND PROPP
|
||||
(ALLOCSTRING
|
||||
MAX-UNAME-LEN
|
||||
))
|
||||
CURRENT-DEPTH _ 1
|
||||
MAX-DEPTH _
|
||||
FILING.ENUMERATION.DEPTH
|
||||
DEFAULTEXT _ DEFAULTEXT
|
||||
DEFAULTVERS _ DEFAULTVERS])])
|
||||
|
||||
(\UFS.NEXTFILEFN
|
||||
(LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 7-Oct-93 14:31 by jds") (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE))) (DECLARE (SPECVARS FILEGROUP)) (COND (SUBGEN (* ;; "We're in a sub-directory.") (LET (FILENAME NAMELEN NEWWNAME FILEGROUP) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))))) (T (* ;; "Not in a sub-directory, so act directly on the top-level generator.") (LET* ((FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (QUOTE *)) (DEFAULTVERS (QUOTE *)) (DESIREDPROPS (COND ((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (QUOTE (SIZE CREATIONDATE AUTHOR))) (T NIL)))) (DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS)) (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (COND ((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE) (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE) 0 NAMELEN)) (fetch (UFSGENFILESTATE DEV) of GENFILESTATE)))) (COND ((= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T)) (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID))) (COND ((AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) T) (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE) (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))) (IEQP (CHARCODE >) (NTHCHARCODE FILENAME (NCHARS FILENAME))) (DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP))) (* ;; "It's a directory, so let's recurse into it.") (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))) (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE))) (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)))) (T (COND (NAMEONLY NEWNAME) (T FILENAME)))))) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))))))))
|
||||
)
|
||||
[LAMBDA (GENFILESTATE NAMEONLY)
|
||||
|
||||
(* ;;
|
||||
"Edited 22-Jan-2022 09:05 by rmk: Bind DEFAULTEXT and DEFAULTVERS to values in GENFILESTATE")
|
||||
|
||||
(* ;; "Edited 7-Oct-93 14:31 by jds")
|
||||
|
||||
(* ;; "Given a UFS filesystem generator, return the %"next%" file in line.")
|
||||
|
||||
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE)))
|
||||
(DECLARE (SPECVARS FILEGROUP))
|
||||
(COND
|
||||
[SUBGEN
|
||||
|
||||
(* ;; "We're in a sub-directory.")
|
||||
|
||||
(LET (FILENAME NAMELEN NEWWNAME FILEGROUP)
|
||||
(SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY))
|
||||
(COND
|
||||
(FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE)
|
||||
(replace (UFSGENFILESTATE LENGTH) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE RDATE) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE RDATE) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE WDATE) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE WDATE) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AULEN) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AULEN) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN)))
|
||||
FILENAME)
|
||||
(T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL)
|
||||
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY]
|
||||
(T
|
||||
(* ;; "Not in a sub-directory, so act directly on the top-level generator.")
|
||||
|
||||
(LET* [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE))
|
||||
(FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE))
|
||||
(ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE)))
|
||||
FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (FETCH (UFSGENFILESTATE
|
||||
DEFAULTEXT)
|
||||
OF GENFILESTATE))
|
||||
(DEFAULTVERS (FETCH (UFSGENFILESTATE DEFAULTVERS) OF GENFILESTATE))
|
||||
(DESIREDPROPS (COND
|
||||
((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE)
|
||||
'(SIZE CREATIONDATE AUTHOR))
|
||||
(T NIL]
|
||||
(DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS))
|
||||
(AND (> FINFOID -1)
|
||||
(< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
|
||||
(CL:UNWIND-PROTECT
|
||||
[COND
|
||||
((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE))
|
||||
0)
|
||||
[replace (UFSGENFILESTATE THISFILE) of GENFILESTATE
|
||||
with (SETQ FILENAME (\UFS.FULLNAME.M
|
||||
(fetch (UFSGENFILESTATE DIRECTORY)
|
||||
of GENFILESTATE)
|
||||
(SETQ NEWNAME (CL:SUBSEQ
|
||||
(fetch (UFSGENFILESTATE
|
||||
NAME) of
|
||||
GENFILESTATE
|
||||
)
|
||||
0 NAMELEN))
|
||||
(fetch (UFSGENFILESTATE DEV) of
|
||||
GENFILESTATE
|
||||
]
|
||||
(COND
|
||||
((= (add FILEID 1)
|
||||
(fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
|
||||
(* ; "Generator exhausted. ")
|
||||
(\UFS.UNREGISTER.GFS GENFILESTATE T))
|
||||
(T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE
|
||||
with FILEID)))
|
||||
(COND
|
||||
[(AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH)
|
||||
of GENFILESTATE)
|
||||
T)
|
||||
(ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH
|
||||
) of GENFILESTATE)
|
||||
(fetch (UFSGENFILESTATE MAX-DEPTH)
|
||||
of GENFILESTATE)))
|
||||
(IEQP (CHARCODE >)
|
||||
(NTHCHARCODE FILENAME (NCHARS FILENAME)))
|
||||
(DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE)
|
||||
of GENFILESTATE))
|
||||
(fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))
|
||||
|
||||
(* ;; "It's a directory, so let's recurse into it.")
|
||||
|
||||
[replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE
|
||||
with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE)
|
||||
of (CAR FILEGROUP]
|
||||
(replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN
|
||||
with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH)
|
||||
of GENFILESTATE)))
|
||||
(replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN
|
||||
with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))
|
||||
(SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY))
|
||||
(COND
|
||||
(FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP)
|
||||
of GENFILESTATE)
|
||||
(replace (UFSGENFILESTATE LENGTH) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE LENGTH)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE RDATE) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE RDATE)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE WDATE) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE WDATE)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE PROTECTION)
|
||||
of GENFILESTATE with (fetch (
|
||||
UFSGENFILESTATE
|
||||
PROTECTION)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AULEN) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AULEN)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AUTHOR) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AUTHOR)
|
||||
of SUBGEN)))
|
||||
FILENAME)
|
||||
(NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of
|
||||
GENFILESTATE
|
||||
with NIL)
|
||||
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY]
|
||||
(T (COND
|
||||
(NAMEONLY NEWNAME)
|
||||
(T FILENAME]
|
||||
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
|
||||
|
||||
(\UFS.FILEINFOFN
|
||||
(LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T)))))
|
||||
@@ -574,7 +813,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
\UFS.DIRECTORY.RECOGNIZER DSKP)
|
||||
(RECORDS UFSSTREAM NAME&ALLPROPS)
|
||||
|
||||
(* ;; "File attribute code. For interface between Cfunc and LISPfunc.")
|
||||
(* ;; "File attribute code. For interface between Cfunc and LISPfunc.")
|
||||
|
||||
(CONSTANTS (ATTR-LENGTH 1)
|
||||
(ATTR-WDATE 2)
|
||||
@@ -585,7 +824,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(ATTR-EOL 7)
|
||||
(ATTR-ALL 8))
|
||||
|
||||
(* ;; "File RECOG code. For interface between Cfunc and LISPfunc.")
|
||||
(* ;; "File RECOG code. For interface between Cfunc and LISPfunc.")
|
||||
|
||||
(CONSTANTS (RECOG-OLD 0)
|
||||
(RECOG-OLDEST 1)
|
||||
@@ -594,7 +833,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(RECOG-OTHER 4)
|
||||
(RECOG-NON 5))
|
||||
|
||||
(* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.")
|
||||
(* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.")
|
||||
|
||||
(CONSTANTS (ACCESS-INPUT 0)
|
||||
(ACCESS-OUTPUT 1)
|
||||
@@ -602,95 +841,93 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(ACCESS-APPEND 3)
|
||||
(ACCESS-OTHER 4))
|
||||
|
||||
(* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.")
|
||||
(* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.")
|
||||
|
||||
(CONSTANTS (MAX-UNAME-LEN 512))
|
||||
|
||||
(* ;; "\UFSGetFileName allocate this size buffer to keep the path name.")
|
||||
(* ;; "\UFSGetFileName allocate this size buffer to keep the path name.")
|
||||
|
||||
(CONSTANTS (MAX-PATHNAME-LEN 256))
|
||||
(FILES (LOADCOMP)
|
||||
PMAP)
|
||||
(* ; "For \devicefile.eoserror")))
|
||||
(* ; "For \devicefile.eoserror")))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \UFS.FULLNAME.M MACRO [LAMBDA (DIR NAME DEV ATOMP)
|
||||
(DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*))
|
||||
(DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*))
|
||||
|
||||
(* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.")
|
||||
(* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.")
|
||||
|
||||
(COND
|
||||
(NAME (* ; "Pass NIL thru transparently")
|
||||
(COND
|
||||
[(DSKP DEV)
|
||||
(SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME))
|
||||
(COND
|
||||
[*DSK-UPPER-CASE-FILE-NAMES*
|
||||
|
||||
(* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.")
|
||||
|
||||
(COND
|
||||
(NAME (* ; "Pass NIL thru transparently")
|
||||
(COND
|
||||
[(DSKP DEV)
|
||||
(SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME))
|
||||
(COND
|
||||
[*DSK-UPPER-CASE-FILE-NAMES*
|
||||
|
||||
(* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.")
|
||||
|
||||
(COND
|
||||
(ATOMP (MKATOM (U-CASE NAME)))
|
||||
(T (U-CASE NAME]
|
||||
(T (COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME]
|
||||
(T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME)
|
||||
)
|
||||
(COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME])
|
||||
(ATOMP (MKATOM (U-CASE NAME)))
|
||||
(T (U-CASE NAME]
|
||||
(T (COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME]
|
||||
(T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME))
|
||||
(COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME])
|
||||
|
||||
(PUTPROPS \UFSGetMonitor MACRO ((DEV)
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSKtopMonitor)
|
||||
(UNIX \UFStopMonitor)
|
||||
NIL)))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSKtopMonitor)
|
||||
(UNIX \UFStopMonitor)
|
||||
NIL)))
|
||||
|
||||
(PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV)
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSK.DEFAULT.DIRECTORY)
|
||||
(UNIX \UFS.DEFAULT.DIRECTORY)
|
||||
NIL)))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSK.DEFAULT.DIRECTORY)
|
||||
(UNIX \UFS.DEFAULT.DIRECTORY)
|
||||
NIL)))
|
||||
|
||||
(PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV)
|
||||
|
||||
(* ;;
|
||||
"Return a function that will do name recognition for this device")
|
||||
(* ;;
|
||||
"Return a function that will do name recognition for this device")
|
||||
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK (FUNCTION \DSKGetFileName-C))
|
||||
(UNIX (FUNCTION \UFSGetFileName-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK (FUNCTION \DSKGetFileName-C))
|
||||
(UNIX (FUNCTION \UFSGetFileName-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
|
||||
(PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV)
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of
|
||||
DEV)
|
||||
(DSK (FUNCTION \DSKDirectoryNameP-C))
|
||||
(UNIX (FUNCTION \UFSDirectoryNameP-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK (FUNCTION \DSKDirectoryNameP-C))
|
||||
(UNIX (FUNCTION \UFSDirectoryNameP-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
|
||||
(PUTPROPS DSKP MACRO ((DEV)
|
||||
(EQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
'DSK)))
|
||||
(EQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
'DSK)))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS UFSSTREAM (
|
||||
(* ;;
|
||||
"Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.")
|
||||
(* ;;
|
||||
"Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.")
|
||||
|
||||
(FILEID (fetch F1 of DATUM)
|
||||
(REPLACE F1 OF DATUM WITH NEWVALUE))
|
||||
(* ; "Unix file handle")
|
||||
(CDATE (fetch F2 of DATUM)
|
||||
(REPLACE F2 OF DATUM WITH NEWVALUE))
|
||||
(* ; "IDate given to openstream")
|
||||
(UNIXNAME (fetch F5 of DATUM)
|
||||
(REPLACE F5 OF DATUM WITH NEWVALUE))
|
||||
(* ;
|
||||
"The name by which Unix knows this file")
|
||||
))
|
||||
(FILEID (fetch F1 of DATUM)
|
||||
(REPLACE F1 OF DATUM WITH NEWVALUE))
|
||||
(* ; "Unix file handle")
|
||||
(CDATE (fetch F2 of DATUM)
|
||||
(REPLACE F2 OF DATUM WITH NEWVALUE))
|
||||
(* ; "IDate given to openstream")
|
||||
(UNIXNAME (fetch F5 of DATUM)
|
||||
(REPLACE F5 OF DATUM WITH NEWVALUE))
|
||||
(* ;
|
||||
"The name by which Unix knows this file")
|
||||
))
|
||||
|
||||
(RECORD NAME&ALLPROPS (NAME . ALLPROPS))
|
||||
)
|
||||
@@ -876,23 +1113,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(PUTPROPS UFS COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 1992 1993 1994 1995 2000 2021
|
||||
))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (8248 9801 (\UFSCreateDevice 8258 . 8623) (\UFS.CREATE.DEVICE 8625 . 9481) (
|
||||
\UFSOpenDevice 9483 . 9660) (\UFSCloseDevice 9662 . 9799)) (13962 41872 (\UFSOpenFile 13972 . 17266) (
|
||||
\UFS.OPENP 17268 . 17765) (\UFS.RECOGNIZE.FILE 17767 . 18520) (\UFS.DIRECTORY.NAME 18522 . 19265) (
|
||||
\UFSCloseFile 19267 . 20243) (\UFSGetFileName 20245 . 20444) (\UFSDeleteFile 20446 . 20986) (
|
||||
\UFSRenameFile 20988 . 22153) (\UFSReadPages 22155 . 23290) (\UFSWritePages 23292 . 24512) (
|
||||
\UFSTruncateFile 24514 . 26011) (\UFSDirectoryNameP 26013 . 27067) (\UFSEventFn 27069 . 27731) (
|
||||
\UFSGetFileInfo 27733 . 30015) (\UFS.CREATE.PROPS 30017 . 30370) (\UFSSetFileInfo 30372 . 31601) (
|
||||
\UFSGenerateFiles 31603 . 34315) (\UFS.NEXTFILEFN 34317 . 38460) (\UFS.FILEINFOFN 38462 . 39911) (
|
||||
\UFS.VALID.PROPP 39913 . 40205) (\UFS.REGISTER.GFS 40207 . 40462) (\UFS.UNREGISTER.GFS 40464 . 41047)
|
||||
(\UFS.ABORT.DIRECTORY 41049 . 41397) (\UFS.ABORT.CL-DIRECTORY 41399 . 41686) (\UFS.CLEANUP.GFS.TABLE
|
||||
41688 . 41870)) (41907 48591 (\UFSMakeUnixFormatName 41917 . 42938) (\UFSParseNameString 42940 . 43314
|
||||
) (\UFSParse-Directory 43316 . 43857) (\UFS.PARSE.BODY 43859 . 44404) (\UFS.ADJUST.HOST 44406 . 44565)
|
||||
(\UFS.FULLNAME 44567 . 45775) (\UFS.ADD.HOST.FIELD 45777 . 46137) (\UFS.REMOVE.HOST.FIELD 46139 .
|
||||
47809) (\UFS.HANDLE.RELATIVEDIRECTORY 47811 . 48589)) (49407 50020 (CHDIR 49417 . 50018)) (50092 51078
|
||||
(\DEVICEFILE.EOSERROR 50102 . 51076)) (51151 52388 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51161 . 52006)
|
||||
(\UNVISIBLE.FLUSH.OPEN.STREAMS 52008 . 52386)) (52421 54047 (\UFSError 52431 . 54045)) (54091 56338 (
|
||||
\UFSGetFileType 54101 . 54702) (\UFSSetFileType 54704 . 55133) (\UFSeol 55135 . 56336)) (65950 67074 (
|
||||
\UFSGetPrintFileType 65960 . 66372) (\UFSGetFileTypeConfirm 66374 . 66822) (\UFSPrintTypeMenu 66824 .
|
||||
67072)) (67104 68852 (\UFStoOtherCopyMess 67114 . 68105) (\UFStoOtherRenameMess 68107 . 68850)))))
|
||||
(FILEMAP (NIL (8206 9759 (\UFSCreateDevice 8216 . 8581) (\UFS.CREATE.DEVICE 8583 . 9439) (
|
||||
\UFSOpenDevice 9441 . 9618) (\UFSCloseDevice 9620 . 9757)) (14300 52622 (\UFSOpenFile 14310 . 17604) (
|
||||
\UFS.OPENP 17606 . 18103) (\UFS.RECOGNIZE.FILE 18105 . 18858) (\UFS.DIRECTORY.NAME 18860 . 19603) (
|
||||
\UFSCloseFile 19605 . 20581) (\UFSGetFileName 20583 . 20782) (\UFSDeleteFile 20784 . 21324) (
|
||||
\UFSRenameFile 21326 . 22491) (\UFSReadPages 22493 . 23628) (\UFSWritePages 23630 . 24850) (
|
||||
\UFSTruncateFile 24852 . 26349) (\UFSDirectoryNameP 26351 . 27405) (\UFSEventFn 27407 . 28069) (
|
||||
\UFSGetFileInfo 28071 . 30353) (\UFS.CREATE.PROPS 30355 . 30708) (\UFSSetFileInfo 30710 . 31939) (
|
||||
\UFSGenerateFiles 31941 . 38373) (\UFS.NEXTFILEFN 38375 . 49210) (\UFS.FILEINFOFN 49212 . 50661) (
|
||||
\UFS.VALID.PROPP 50663 . 50955) (\UFS.REGISTER.GFS 50957 . 51212) (\UFS.UNREGISTER.GFS 51214 . 51797)
|
||||
(\UFS.ABORT.DIRECTORY 51799 . 52147) (\UFS.ABORT.CL-DIRECTORY 52149 . 52436) (\UFS.CLEANUP.GFS.TABLE
|
||||
52438 . 52620)) (52657 59341 (\UFSMakeUnixFormatName 52667 . 53688) (\UFSParseNameString 53690 . 54064
|
||||
) (\UFSParse-Directory 54066 . 54607) (\UFS.PARSE.BODY 54609 . 55154) (\UFS.ADJUST.HOST 55156 . 55315)
|
||||
(\UFS.FULLNAME 55317 . 56525) (\UFS.ADD.HOST.FIELD 56527 . 56887) (\UFS.REMOVE.HOST.FIELD 56889 .
|
||||
58559) (\UFS.HANDLE.RELATIVEDIRECTORY 58561 . 59339)) (60157 60770 (CHDIR 60167 . 60768)) (60842 61828
|
||||
(\DEVICEFILE.EOSERROR 60852 . 61826)) (61901 63138 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61911 . 62756)
|
||||
(\UNVISIBLE.FLUSH.OPEN.STREAMS 62758 . 63136)) (63171 64797 (\UFSError 63181 . 64795)) (64841 67088 (
|
||||
\UFSGetFileType 64851 . 65452) (\UFSSetFileType 65454 . 65883) (\UFSeol 65885 . 67086)) (76238 77362 (
|
||||
\UFSGetPrintFileType 76248 . 76660) (\UFSGetFileTypeConfirm 76662 . 77110) (\UFSPrintTypeMenu 77112 .
|
||||
77360)) (77392 79140 (\UFStoOtherCopyMess 77402 . 78393) (\UFStoOtherRenameMess 78395 . 79138)))))
|
||||
STOP
|
||||
|
||||
BIN
sources/UFS.LCOM
BIN
sources/UFS.LCOM
Binary file not shown.
Reference in New Issue
Block a user