diff --git a/code/filesys.lisp b/code/filesys.lisp index 36018f74c08bd7396ae0a5b447e36067b219b8c0..d7e4f0f29583ef6e35a381d199db27421860af12 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -1,5 +1,4 @@ ;;; -*- Log: code.log; Package: Lisp -*- -;;; ### Some day fix to accept :wild in any pathname component. ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. @@ -7,27 +6,20 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.15 1991/12/01 18:10:44 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.16 1991/12/16 10:31:59 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; Ugly pathname functions for Spice Lisp. -;;; these functions are part of the standard Spice Lisp environment. +;;; File system interface functions. This file is pretty UNIX specific. ;;; -;;; Written by Jim Large and Rob MacLachlan +;;; Written by William Lott ;;; ;;; ********************************************************************** (in-package "LISP") -(export '(pathname pathnamep *default-pathname-defaults* truename - parse-namestring merge-pathnames make-pathname - pathname-host pathname-device pathname-directory - pathname-name pathname-type pathname-version - namestring file-namestring directory-namestring - host-namestring enough-namestring user-homedir-pathname - probe-file rename-file delete-file file-write-date - file-author directory)) +(export '(truename probe-file user-homedir-pathname directory + rename-file delete-file file-write-date file-author)) (use-package "EXTENSIONS") @@ -36,276 +28,563 @@ file-writable unix-namestring)) (in-package "LISP") - -;;; Pathname structure - - -;;; *Default-Pathname-defaults* has all values unspecified except for the -;;; host. All pathnames must have a host. -(defvar *default-pathname-defaults* () - "Set to the default pathname-defaults pathname (Got that?)") - -(defun filesys-init () - (setq *default-pathname-defaults* - (%make-pathname "Mach" nil nil nil nil nil)) - (multiple-value-bind (won dir) - (mach:unix-current-directory) - (when won - (setf (search-list "default:") (list dir))))) - - -;;; The pathname type is defined with a defstruct. -;;; This declaration implicitly defines the common lisp function Pathnamep -(defstruct (pathname - (:conc-name %pathname-) - (:print-function %print-pathname) - (:constructor - %make-pathname (host device directory name type version)) - (:predicate pathnamep)) - "Pathname is the structure of the file pathname. It consists of a - host, a device, a directory, a name, and a type." - (host nil :type (or simple-string null)) - (device nil :type (or simple-string (member nil :absolute))) - (directory nil :type (or simple-vector null)) - (name nil :type (or simple-string null)) - (type nil :type (or simple-string null)) - (version nil :type (or integer (member nil :newest)))) - -(defun %print-pathname (s stream d) - (declare (ignore d)) - (format stream "#p~S" (namestring s))) - -(defun make-pathname (&key defaults (host nil hostp) (device nil devicep) - (directory nil directoryp) (name nil namep) - (type nil typep) (version nil versionp)) - "Create a pathname from :host, :device, :directory, :name, :type and :version. - If any field is ommitted, it is obtained from :defaults as though by - merge-pathnames." - (flet ((make-it (host device directory name type version) - (%make-pathname - (if host - (if (stringp host) (coerce host 'simple-string) host) - (%pathname-host *default-pathname-defaults*)) - (if (stringp device) (coerce device 'simple-string) device) - (if (stringp directory) - (%pathname-directory (parse-namestring directory)) - directory) - (if (stringp name) (coerce name 'simple-string) name) - (if (stringp type) (coerce type 'simple-string) type) - version))) - (if defaults - (let ((defaults (pathname defaults))) - (make-it (if hostp host (%pathname-host defaults)) - (if devicep device (%pathname-device defaults)) - (if directoryp directory (%pathname-directory defaults)) - (if namep name (%pathname-name defaults)) - (if typep type (%pathname-type defaults)) - (if versionp version (%pathname-version defaults)))) - (make-it host device directory name type version)))) - - -;;; These can not be done by the accessors because the pathname arg may be -;;; a string or a symbol or etc. - -(defun pathname-host (pathname) - "Returns the host slot of pathname. Pathname may be a string, symbol, - or stream." - (%pathname-host (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-device (pathname) - "Returns the device slot of pathname. Pathname may be a string, symbol, - or stream." - (%pathname-device (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-directory (pathname) - "Returns the directory slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-directory (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-name (pathname) - "Returns the name slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-name (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-type (pathname) - "Returns the type slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-type (if (pathnamep pathname) pathname (pathname pathname)))) - -(defun pathname-version (pathname) - "Returns the version slot of pathname. Pathname may be a string, - symbol, or stream." - (%pathname-version (if (pathnamep pathname) pathname (pathname pathname)))) +;;;; Unix pathname host support. - - -;;;; PARSE-NAMESTRING and PATHNAME. - -;;; SPLIT-FILENAME -- internal +;;; Unix namestrings have the following format: ;;; -;;; Splits the filename into the name and type. If someone wants to change -;;; this yet again, just change this. -;;; -(defun split-filename (filename) - (declare (simple-string filename)) - (let ((posn (position #\. filename :from-end t))) - (cond ((null posn) - (values filename nil)) - ((or (zerop posn) (= posn (1- (length filename)))) - (values filename "")) - (t - (values (subseq filename 0 posn) - (subseq filename (1+ posn))))))) - -;;; DO-FILENAME-PARSE -- internal +;;; namestring := [ directory ] [ file [ type [ version ]]] +;;; directory := [ "/" | search-list ] { file "/" }* +;;; search-list := [^:/]*: +;;; file := [^/]* +;;; type := "." [^/.]* +;;; version := "." ([0-9]+ | "*") ;;; -;;; Split string into a logical name, a vector of directories, a file name and -;;; a file type. +;;; Note: this grammer is ambiguous. The string foo.bar.5 can be parsed +;;; as either just the file specified or as specifying the file, type, and +;;; version. Therefore, we use the following rules when confronted with +;;; an ambiguous file.type.version string: ;;; -(defun do-filename-parse (string &optional (start 0) end) - (declare (simple-string string)) - (let ((end (or end (length string)))) - (let* ((directories nil) - (filename nil) - (absolutep (and (> end start) (eql (schar string start) #\/))) - (logical-name - (cond (absolutep - (setf start (position #\/ string :start start :end end - :test-not #'char=)) - :absolute) - ((find #\: string - :start start - :end (or (position #\/ string :start start :end end) - end)) - (let ((posn (position #\: string :start start))) - (prog1 - (subseq string start posn) - (setf start (1+ posn)))))))) - (loop - (unless (and start (> end start)) - (return)) - (let ((next-slash (position #\/ string :start start :end end))) - (cond (next-slash - (push (subseq string start next-slash) directories) - (setf start - (position #\/ string :start next-slash :end end - :test-not #'char=))) - (t - (setf filename (subseq string start end)) - (return))))) - (multiple-value-bind (name type) - (if filename (split-filename filename)) - (values (cond (logical-name logical-name) - (directories "Default")) - (if (or logical-name directories) - (coerce (nreverse directories) 'vector)) - name - type))))) - -(defun parse-namestring (thing &optional host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) - "Convert THING (string, symbol, pathname, or stream) into a pathname." - (declare (ignore junk-allowed)) - (let* ((host (or host (pathname-host defaults))) - (pathname - (etypecase thing - ((or string symbol) - (with-array-data ((string (string thing)) - (start start) - (end end)) - (multiple-value-bind (device directories name type) - (do-filename-parse string start end) - (make-pathname :host host - :device device - :directory directories - :name name - :type type)))) - (pathname - thing) - (stream - (pathname (file-name thing)))))) - (unless (or (null host) - (null (pathname-host pathname)) - (string-equal host (pathname-host pathname))) - (cerror "Ignore it." - "Host mismatch in ~S: ~S isn't ~S" - 'parse-namestring - (pathname-host pathname) - host)) - ;; - ;; ### ??? what should the second value be??? - (values pathname (or end start)))) - - -(defun pathname (thing) - "Turns thing into a pathname. Thing may be a string, symbol, stream, or - pathname." - (values (parse-namestring thing))) - - - -;;; Merge-Pathnames -- Public +;;; - If the first character is a dot, it's part of the file. It is not +;;; considered a dot in the following rules. ;;; -;;; Returns a new pathname whose fields are the same as the fields in PATHNAME -;;; except that () fields are filled in from defaults. Type and Version field -;;; are only done if name field has to be done (see manual for explanation). +;;; - If there is only one dot, it seperates the file and the type. +;;; +;;; - If there are multiple dots and the stuff following the last dot +;;; is a valid version, then that is the version and the stuff between +;;; the second to last dot and the last dot is the type. +;;; +;;; Wildcard characters: +;;; +;;; If the directory, file, type components contain any of the following +;;; characters, it is considered part of a wildcard pattern and has the +;;; following meaning. +;;; +;;; ? - matches any character +;;; * - matches any zero or more characters. +;;; [abc] - matches any of a, b, or c. +;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn. +;;; +;;; Any of these special characters can be preceeded by a backslash to +;;; cause it to be treated as a regular character. ;;; -(defun merge-pathnames (pathname &optional - (defaults *default-pathname-defaults*) - default-version) - "Fills in unspecified slots of Pathname from Defaults (defaults to - *default-pathname-defaults*). If the version remains unspecified, - gets it from Default-Version." - ;; - ;; finish hairy argument defaulting - (let ((pathname (pathname pathname)) - (defaults (pathname defaults))) - ;; - ;; make a new pathname - (let ((name (%pathname-name pathname))) - (%make-pathname - (or (%pathname-host pathname) (%pathname-host defaults)) - (or (%pathname-device pathname) (%pathname-device defaults)) - (or (%pathname-directory pathname) (%pathname-directory defaults)) - (or name (%pathname-name defaults)) - (or (%pathname-type pathname) (%pathname-type defaults)) - (or (%pathname-version pathname) - (if name - default-version - (or (%pathname-version defaults) default-version))))))) - -;;;; NAMESTRING and other stringification stuff. +(defun remove-backslashes (namestr start end) + "Remove and occurences of \\ from the string because we've already + checked for whatever they may have been backslashed." + (declare (type simple-base-string namestr) + (type index start end)) + (let* ((result (make-string (- end start))) + (dst 0) + (quoted nil)) + (do ((src start (1+ src))) + ((= src end)) + (cond (quoted + (setf (schar result dst) (schar namestr src)) + (setf quoted nil) + (incf dst)) + (t + (let ((char (schar namestr src))) + (cond ((char= char #\\) + (setq quoted t)) + (t + (setf (schar result dst) char) + (incf dst))))))) + (when quoted + (error 'namestring-parse-error + :complaint "Backslash in bad place." + :namestring namestr + :offset (1- end))) + (shrink-vector result dst))) + +(defvar *ignore-wildcards* nil) + +(defun maybe-make-pattern (namestr start end) + (declare (type simple-base-string namestr) + (type index start end)) + (if *ignore-wildcards* + (subseq namestr start end) + (collect ((pattern)) + (let ((quoted nil) + (any-quotes nil) + (last-regular-char nil) + (index start)) + (flet ((flush-pending-regulars () + (when last-regular-char + (pattern (if any-quotes + (remove-backslashes namestr + last-regular-char + index) + (subseq namestr last-regular-char index))) + (setf any-quotes nil) + (setf last-regular-char nil)))) + (loop + (when (>= index end) + (return)) + (let ((char (schar namestr index))) + (cond (quoted + (incf index) + (setf quoted nil)) + ((char= char #\\) + (setf quoted t) + (setf any-quotes t) + (unless last-regular-char + (setf last-regular-char index)) + (incf index)) + ((char= char #\?) + (flush-pending-regulars) + (pattern :single-char-wild) + (incf index)) + ((char= char #\*) + (flush-pending-regulars) + (pattern :multi-char-wild) + (incf index)) + ((char= char #\[) + (flush-pending-regulars) + (let ((close-bracket + (position #\] namestr :start index :end end))) + (unless close-bracket + (error 'namestring-parse-error + :complaint "``['' with no corresponding ``]''" + :namestring namestr + :offset index)) + (pattern (list :character-set + (subseq namestr + (1+ index) + close-bracket))) + (setf index (1+ close-bracket)))) + (t + (unless last-regular-char + (setf last-regular-char index)) + (incf index))))) + (flush-pending-regulars))) + (cond ((null (pattern)) + "") + ((and (null (cdr (pattern))) + (simple-string-p (car (pattern)))) + (car (pattern))) + (t + (make-pattern (pattern))))))) + +(defun extract-name-type-and-version (namestr start end) + (declare (type simple-base-string namestr) + (type index start end)) + (let* ((last-dot (position #\. namestr :start (1+ start) :end end + :from-end t)) + (second-to-last-dot (and last-dot + (position #\. namestr :start (1+ start) + :end last-dot :from-end t))) + (version :newest)) + ;; If there is a second-to-last dot, check to see if there is a valid + ;; version after the last dot. + (when second-to-last-dot + (cond ((and (= (+ last-dot 2) end) + (char= (schar namestr (1+ last-dot)) #\*)) + (setf version :wild)) + ((and (< (1+ last-dot) end) + (do ((index (1+ last-dot) (1+ index))) + ((= index end) t) + (unless (char<= #\0 (schar namestr index) #\9) + (return nil)))) + (setf version + (parse-integer namestr :start (1+ last-dot) :end end))) + (t + (setf second-to-last-dot nil)))) + (cond (second-to-last-dot + (values (maybe-make-pattern namestr start second-to-last-dot) + (maybe-make-pattern namestr + (1+ second-to-last-dot) + last-dot) + version)) + (last-dot + (values (maybe-make-pattern namestr start last-dot) + (maybe-make-pattern namestr (1+ last-dot) end) + version)) + (t + (values (maybe-make-pattern namestr start end) + nil + version))))) + +(defun split-at-slashes (namestr start end) + (declare (type simple-base-string namestr) + (type index start end)) + (let ((absolute (and (/= start end) + (char= (schar namestr start) #\/)))) + (when absolute + (incf start)) + ;; Next, split the remainder into slash seperated chunks. + (collect ((pieces)) + (loop + (let ((slash (position #\/ namestr :start start :end end))) + (pieces (cons start (or slash end))) + (unless slash + (return)) + (setf start (1+ slash)))) + (values absolute (pieces))))) + +(defun maybe-extract-search-list (namestr start end) + (declare (type simple-base-string namestr) + (type index start end)) + (let ((quoted nil)) + (do ((index start (1+ index))) + ((= index end) + (values nil start)) + (if quoted + (setf quoted nil) + (case (schar namestr index) + (#\\ + (setf quoted t)) + (#\: + (return (values (remove-backslashes namestr start index) + (1+ index))))))))) + +(defun parse-unix-namestring (namestr start end) + (declare (type simple-base-string namestr) + (type index start end)) + (multiple-value-bind + (absolute pieces) + (split-at-slashes namestr start end) + (let ((search-list + (if absolute + nil + (let ((first (car pieces))) + (multiple-value-bind + (search-list new-start) + (maybe-extract-search-list namestr + (car first) (cdr first)) + (when search-list + (setf absolute t) + (setf (car first) new-start)) + search-list))))) + (multiple-value-bind + (name type version) + (let* ((tail (car (last pieces))) + (tail-start (car tail)) + (tail-end (cdr tail))) + (unless (= tail-start tail-end) + (setf pieces (butlast pieces)) + (extract-name-type-and-version namestr tail-start tail-end))) + ;; Now we have everything we want. So return it. + (values nil ; no host for unix namestrings. + nil ; no devices for unix namestrings. + (collect ((dirs)) + (when search-list + (dirs (intern-search-list search-list))) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (let ((dir (maybe-make-pattern namestr + piece-start + piece-end))) + (if (and (simple-string-p dir) + (string= dir "..")) + (dirs :up) + (dirs dir)))))) + (if (dirs) + (cons (if absolute :absolute :relative) (dirs)) + nil)) + name + type + version))))) + +(defun unparse-unix-host (pathname) + (declare (type pathname pathname) + (ignore pathname)) + "Unix") + +(defun unparse-unix-piece (thing) + (etypecase thing + (simple-string + (let* ((srclen (length thing)) + (dstlen srclen)) + (dotimes (i srclen) + (case (schar thing i) + ((#\* #\? #\[) + (incf dstlen)))) + (let ((result (make-string dstlen)) + (dst 0)) + (dotimes (src srclen) + (let ((char (schar thing src))) + (case char + ((#\* #\? #\[) + (setf (schar result dst) #\\) + (incf dst))) + (setf (schar result dst) char) + (incf dst))) + result))) + (pattern + (collect ((strings)) + (dolist (piece (pattern-pieces thing)) + (etypecase piece + (simple-string + (strings piece)) + (symbol + (case piece + (:multi-char-wild + (strings "*")) + (:single-char-wild + (strings "?")) + (t + (error "Invalid pattern piece: ~S" piece)))) + (cons + (case (car piece) + (:character-set + (strings "[") + (strings (cdr piece)) + (strings "]")) + (t + (error "Invalid pattern piece: ~S" piece)))))) + (apply #'concatenate + 'simple-string + (strings)))))) + +(defun unparse-unix-directory-list (directory) + (declare (type list directory)) + (collect ((pieces)) + (when directory + (ecase (pop directory) + (:absolute + (cond ((search-list-p (car directory)) + (pieces (search-list-name (pop directory))) + (pieces ":")) + (t + (pieces "/")))) + (:relative + ;; Nothing special. + )) + (dolist (dir directory) + (typecase dir + ((member :up) + (pieces "../")) + ((member :back) + (error ":BACK cannot be represented in namestrings.")) + ((or simple-string pattern) + (pieces (unparse-unix-piece dir)) + (pieces "/")) + (t + (error "Invalid directory component: ~S" dir))))) + (apply #'concatenate 'simple-string (pieces)))) + +(defun unparse-unix-directory (pathname) + (declare (type pathname pathname)) + (unparse-unix-directory-list (%pathname-directory pathname))) + +(defun unparse-unix-file (pathname) + (declare (type pathname pathname)) + (collect ((strings)) + (let* ((name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (type-supplied (not (or (null type) (eq type :unspecific)))) + (version (%pathname-version pathname)) + (version-supplied (not (or (null version) (eq version :newest))))) + (when name + (strings (unparse-unix-piece name))) + (when type-supplied + (unless name + (error "Cannot specify the type without a file: ~S" pathname)) + (strings ".") + (strings (unparse-unix-piece type))) + (when version-supplied + (unless type-supplied + (error "Cannot specify the version without a type: ~S" pathname)) + (strings (if (eq version :wild) + ".*" + (format nil ".~D" version))))) + (apply #'concatenate 'simple-string (strings)))) + +(defun unparse-unix-namestring (pathname) + (declare (type pathname pathname)) + (concatenate 'simple-string + (unparse-unix-directory pathname) + (unparse-unix-file pathname))) + +(defun unparse-unix-enough (pathname defaults) + (declare (type pathname pathname defaults)) + (flet ((lose () + (error "~S cannot be represented relative to ~S" + pathname defaults))) + (collect ((strings)) + (let* ((pathname-directory (%pathname-directory pathname)) + (defaults-directory (%pathname-directory defaults)) + (prefix-len (length defaults-directory)) + (result-dir + (cond ((and (> prefix-len 1) + (>= (length pathname-directory) prefix-len) + (compare-component (subseq pathname-directory + 0 prefix-len) + defaults-directory)) + ;; Pathname starts with a prefix of default. So just + ;; use a relative directory from then on out. + (cons :relative (nthcdr prefix-len pathname-directory))) + ((eq (car pathname-directory) :absolute) + ;; We are an absolute pathname, so we can just use it. + pathname-directory) + (t + ;; We are a relative directory. So we lose. + (lose))))) + (strings (unparse-unix-directory-list result-dir))) + (let* ((pathname-version (%pathname-version pathname)) + (version-needed (and pathname-version + (not (eq pathname-version :newest)))) + (pathname-type (%pathname-type pathname)) + (type-needed (or version-needed + (and pathname-type + (not (eq pathname-type :unspecific))))) + (pathname-name (%pathname-name pathname)) + (name-needed (or type-needed + (and pathname-name + (not (compare-component pathname-name + (%pathname-name + defaults))))))) + (when name-needed + (unless pathname-name (lose)) + (strings (unparse-unix-piece pathname-name))) + (when type-needed + (when (or (null pathname-type) (eq pathname-type :unspecific)) + (lose)) + (strings ".") + (strings (unparse-unix-piece pathname-type))) + (when version-needed + (typecase pathname-version + ((member :wild) + (strings ".*")) + (integer + (strings (format nil ".~D" pathname-version))) + (t + (lose))))) + (apply #'concatenate 'simple-string (strings))))) + + +(defstruct (unix-host + (:include host + (:parse #'parse-unix-namestring) + (:unparse #'unparse-unix-namestring) + (:unparse-host #'unparse-unix-host) + (:unparse-directory #'unparse-unix-directory) + (:unparse-file #'unparse-unix-file) + (:unparse-enough #'unparse-unix-enough) + (:customary-case :lower)) + (:make-load-form-fun make-unix-host-load-form)) + ) + +(defvar *unix-host* (make-unix-host)) + +(defun make-unix-host-load-form (host) + (declare (ignore host)) + '*unix-host*) -;;; %Dirstring -- Internal -;;; -;;; %Dirstring converts a vector of the form #("foo" "bar" ... "baz") into a -;;; string of the form "foo/bar/ ... /baz/" - -(defun %dirstring (dirlist) - (declare (simple-vector dirlist)) - (let* ((numdirs (length dirlist)) - (length numdirs)) - (declare (fixnum numdirs length)) - (dotimes (i numdirs) - (incf length (the fixnum (length (svref dirlist i))))) - (do ((result (make-string length)) - (index 0 (1+ index)) - (position 0)) - ((= index numdirs) result) - (declare (simple-string result)) - (let* ((string (svref dirlist index)) - (len (length string)) - (end (+ position len))) - (declare (simple-string string) - (fixnum len end)) - (replace result string :start1 position :end1 end :end2 len) - (setf (schar result end) #\/) - (setq position (+ end 1)))))) + +;;;; Wildcard matching stuff. + +(defmacro enumerate-matches ((var pathname &optional result + &key (verify-existance t)) + &body body) + (let ((body-name (gensym))) + `(block nil + (flet ((,body-name (,var) + ,@body)) + (%enumerate-matches (pathname ,pathname) + ,verify-existance + #',body-name) + ,result)))) + +(defun %enumerate-matches (pathname verify-existance function) + (when (pathname-type pathname) + (unless (pathname-name pathname) + (error "Cannot supply a type without a name:~% ~S" pathname))) + (when (and (integerp (pathname-version pathname)) + (member (pathname-type pathname) '(nil :unspecific))) + (error "Cannot supply a version without a type:~% ~S" pathname)) + (let ((directory (pathname-directory pathname))) + (if directory + (ecase (car directory) + (:absolute + (%enumerate-directories "/" (cdr directory) pathname + verify-existance function)) + (:relative + (%enumerate-directories "" (cdr directory) pathname + verify-existance function))) + (%enumerate-files "" pathname verify-existance function)))) + +(defun %enumerate-directories (head tail pathname verify-existance function) + (if tail + (let ((piece (car tail))) + (etypecase piece + (simple-string + (%enumerate-directories (concatenate 'string head piece "/") + (cdr tail) pathname verify-existance + function)) + (pattern + (let ((dir (mach:open-dir head))) + (when dir + (unwind-protect + (loop + (let ((name (mach:read-dir dir))) + (cond ((null name) + (return)) + ((string= name ".")) + ((string= name "..")) + ((pattern-matches piece name) + (let ((subdir (concatenate 'string + head name "/"))) + (when (eq (mach:unix-file-kind subdir) + :directory) + (%enumerate-directories + subdir (cdr tail) pathname verify-existance + function))))))) + (mach:close-dir dir))))) + ((member :up) + (%enumerate-directories (concatenate 'string head "../") + (cdr tail) pathname verify-existance + function)))) + (%enumerate-files head pathname verify-existance function))) + +(defun %enumerate-files (directory pathname verify-existance function) + (let ((name (pathname-name pathname)) + (type (pathname-type pathname)) + (version (pathname-version pathname))) + (cond ((null name) + (when (or (not verify-existance) + (mach:unix-file-kind directory)) + (funcall function directory))) + ((or (pattern-p name) + (pattern-p type) + (eq version :wild)) + (let ((dir (mach:open-dir directory))) + (when dir + (unwind-protect + (loop + (let ((file (mach:read-dir dir))) + (if file + (multiple-value-bind + (file-name file-type file-version) + (let ((*ignore-wildcards* t)) + (extract-name-type-and-version + file 0 (length file))) + (when (and (components-match file-name name) + (components-match file-type type) + (components-match file-version + version)) + (funcall function + (concatenate 'string + directory + file)))) + (return)))) + (mach:close-dir dir))))) + (t + (let ((file (concatenate 'string directory name))) + (unless (eq type :unspecific) + (setf file (concatenate 'string file "." type))) + (unless (eq version :newest) + (setf file (concatenate 'string file "." + (quick-integer-to-string version)))) + (when (or (not verify-existance) + (mach:unix-file-kind file)) + (funcall function file))))))) (defun quick-integer-to-string (n) + (declare (type integer n)) (cond ((zerop n) "0") ((eql n 1) "1") ((minusp n) @@ -325,153 +604,26 @@ (fixnum len i r)) (multiple-value-setq (q r) (truncate q 10)) (setf (schar res i) (schar "0123456789" r)))))) - -(defun %device-string (device) - (cond ((eq device :absolute) "/") - (device - (if (string-equal device "Default") - "" - (concatenate 'simple-string (the simple-string device) ":"))) - (T ""))) - -(defun namestring (pathname) - "Returns the full form of PATHNAME as a string." - (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname))) - (directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result (%device-string (%pathname-device pathname)))) - (declare (simple-string result)) - (when directory - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - (when name - (setq result (concatenate 'simple-string result - (the simple-string name)))) - (when (and type (not (zerop (length type)))) - (setq result (concatenate 'simple-string result "." - (the simple-string type)))) - result)) - -(defun namestring-without-device (pathname) - "NAMESTRING of pathname ignoring the device slot." - (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname))) - (directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result "")) - (declare (simple-string result)) - (when directory - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - (when name - (setq result (concatenate 'simple-string result - (the simple-string name)))) - (when (and type (not (zerop (length type)))) - (setq result (concatenate 'simple-string result "." - (the simple-string type)))) - result)) -;;; This function is somewhat bummed to make the Hemlock directory command -;;; is fast. -;;; -(defun file-namestring (pathname) - "Returns the name, type, and version of PATHNAME as a string." - (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname))) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result (or name ""))) - (declare (simple-string result)) - (if (and type (not (zerop (length type)))) - (concatenate 'simple-string result "." type) - result))) - -(defun directory-namestring (pathname) - "Returns the device & directory parts of PATHNAME as a string." - (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname))) - (directory (%pathname-directory pathname)) - (result (%device-string (%pathname-device pathname)))) - (declare (simple-string result)) - (when directory - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - result)) - -(defun host-namestring (pathname) - "Returns the host part of PATHNAME as a string." - (%pathname-host (if (pathnamep pathname) pathname (pathname pathname)))) - - -;;; Do-Search-List -- Internal -;;; -;;; Bind var in turn to each element of search list with the specifed -;;; name. -;;; -(defmacro do-search-list ((var name &optional exit-form) . body) - "Do-Search-List (Var Name [Exit-Form]) {Form}*" - `(dolist (,var (resolve-search-list ,name nil) ,exit-form) - (declare (simple-string ,var)) - ,@body)) - -;;; UNIX-NAMESTRING -- public + +;;;; UNIX-NAMESTRING -- public ;;; (defun unix-namestring (pathname &optional (for-input t)) - "Convert PATHNAME into a string that can be used with UNIX system calls." - (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname))) - (device (%pathname-device pathname))) - (cond ((or (eq device :absolute) - (null device) - (string= device "Default")) - (namestring pathname)) - (for-input - (let ((remainder (namestring-without-device pathname)) - (first nil)) - (do-search-list (entry device first) - (let ((name (concatenate 'simple-string entry remainder))) - (unless first - (setf first name)) - (when (mach:unix-file-kind name) - (return name)))))) - (t - (concatenate 'simple-string - (car (resolve-search-list device t)) - (namestring-without-device pathname)))))) - - - -;;;; ENOUGH-NAMESTRING - -(defun enough-namestring (pathname &optional - (defaults *default-pathname-defaults*)) - "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS." - (let* ((pathname (pathname pathname)) - (defaults (pathname defaults)) - (device (%pathname-device pathname)) - (directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (result "") - (need-name nil)) - (declare (simple-string result)) - (when (and device (string-not-equal device (%pathname-device defaults))) - (setq result (%device-string device))) - (when (and directory - (not (equalp directory (%pathname-directory defaults)))) - (setq result (concatenate 'simple-string result - (the simple-string (%dirstring directory))))) - (when (and name (string-not-equal name (%pathname-name defaults))) - (setq result (concatenate 'simple-string result - (the simple-string name)) - need-name t)) - (when (and type (or need-name - (string-not-equal type (%pathname-type defaults)))) - (setq result (concatenate 'simple-string result "." - (the simple-string type)))) - result)) - + "Convert PATHNAME into a string that can be used with UNIX system calls. + Search-lists and wild-cards are expanded." + (enumerate-search-list + (pathname pathname) + (collect ((names)) + (enumerate-matches (name pathname nil :verify-existance for-input) + (names name)) + (let ((names (names))) + (when names + (when (cdr names) + (error "~S is ambiguous:~{~% ~A~}" pathname names)) + (return (car names))))))) -;;;; TRUENAME and other stuff probing stuff. +;;;; TRUENAME and PROBE-FILE. ;;; Truename -- Public ;;; @@ -491,30 +643,27 @@ ;;; (defun probe-file (pathname) "Return a pathname which is the truename of the file if it exists, NIL - otherwise. Returns NIL for directories and other non-file entries." + otherwise." (let ((namestring (unix-namestring pathname t))) - (when (mach:unix-file-kind namestring) + (when (and namestring (mach:unix-file-kind namestring)) (let ((truename (mach:unix-resolve-links (mach:unix-maybe-prepend-current-directory namestring)))) (when truename - (pathname (mach:unix-simplify-pathname truename))))))) + (let ((*ignore-wildcards* t)) + (pathname (mach:unix-simplify-pathname truename)))))))) ;;;; Other random operations. ;;; Rename-File -- Public ;;; -;;; If File is a File-Stream, then rename the associated file if it exists, -;;; otherwise just change the name in the stream. If not a file stream, then -;;; just rename the file. -;;; (defun rename-file (file new-name) "Rename File to have the specified New-Name. If file is a stream open to a file, then the associated file is renamed. If the file does not yet exist then the file is created with the New-Name when the stream is closed." (let* ((original (truename file)) - (original-namestring (namestring original)) + (original-namestring (unix-namestring original t)) (new-name (merge-pathnames new-name original)) (new-namestring (unix-namestring new-name nil))) (multiple-value-bind (res error) @@ -525,7 +674,7 @@ original new-name (mach:get-unix-error-msg error))) (when (streamp file) (file-name file new-namestring)) - (values new-name original (truename new-namestring))))) + (values new-name original (truename new-name))))) ;;; Delete-File -- Public ;;; @@ -580,139 +729,29 @@ ;;;; DIRECTORY. -;;; PARSE-PATTERN -- internal. -;;; -;;; Parse-pattern extracts the name portion of pathname and converts it into -;;; a pattern usable in match-pattern-p. -;;; -(defun parse-pattern (pathname) - (let ((string (file-namestring pathname)) - (pattern nil) - (last-regular-char nil) - (index 0)) - (flet ((flush-pending-regulars () - (when last-regular-char - (push (subseq string last-regular-char index) pattern)) - (setf last-regular-char nil))) - (loop - (when (>= index (length string)) - (return)) - (let ((char (schar string index))) - (cond ((char= char #\?) - (flush-pending-regulars) - (push :single-char-wild pattern) - (incf index)) - ((char= char #\*) - (flush-pending-regulars) - (push :multi-char-wild pattern) - (incf index)) - ((char= char #\[) - (flush-pending-regulars) - (let ((close-bracket (position #\] string :start index))) - (unless close-bracket - (error "``['' with no corresponding ``]'': ~S" string)) - (push :character-set pattern) - (push (subseq string (1+ index) close-bracket) - pattern) - (setf index (1+ close-bracket)))) - (t - (unless last-regular-char - (setf last-regular-char index)) - (incf index))))) - (flush-pending-regulars)) - (nreverse pattern))) - -;;; MATCH-PATTERN-P -- internal. -;;; -;;; Determine if string (starting at start) matches pattern. -;;; -(defun match-pattern-p (string pattern &optional (start 0)) - (cond ((null pattern) - (= start (length string))) - ((eq (car pattern) :single-char-wild) - (and (> (length string) start) - (match-pattern-p string (cdr pattern) (1+ start)))) - ((eq (car pattern) :character-set) - (and (> (length string) start) - (find (schar string start) (cadr pattern)) - (match-pattern-p string (cddr pattern) (1+ start)))) - ((eq (car pattern) :multi-char-wild) - (do ((new-start (length string) (1- new-start))) - ((< new-start start) nil) - (when (match-pattern-p string (cdr pattern) new-start) - (return t)))) - ((stringp (car pattern)) - (let* ((expected (car pattern)) - (len (length expected)) - (new-start (+ start len))) - (and (>= (length string) new-start) - (string= string expected :start1 start :end1 new-start) - (match-pattern-p string (cdr pattern) new-start)))) - (t - (error "Bogus thing in pattern: ~S" (car pattern))))) - -;;; MATCHING-FILES-IN-DIR -- internal -;;; -;;; Return a list of all the files in the directory dirname that match -;;; pattern. If all is nil, ignore files starting with a ``.''. -;;; -(defun matching-files-in-dir (dirname pattern all) - (let ((dir (mach:open-dir dirname))) - (if dir - (unwind-protect - (let ((results nil)) - (loop - (let ((name (mach:read-dir dir))) - (cond ((null name) - (return)) - ((or (string= name ".") - (string= name "..") - (and (not all) - (char= (schar name 0) #\.)))) - ((or (null pattern) - (match-pattern-p name pattern)) - (if (zerop (length dirname)) - (push name results) - (push (concatenate 'string dirname name) - results)))))) - (values results t)) - (mach:close-dir dir)) - (values nil nil)))) - ;;; DIRECTORY -- public. ;;; (defun directory (pathname &key (all t) (check-for-subdirs t)) "Returns a list of pathnames, one for each file that matches the given pathname. Supplying :all as nil causes this to ignore Unix dot files. This never includes Unix dot and dot-dot in the result." - (let* ((pathname (if (pathnamep pathname) pathname (pathname pathname))) - (device (%pathname-device pathname)) - (pattern (parse-pattern pathname)) - (results nil)) - (if (or (eq device :absolute) - (null device) - (string= device "Default")) - (setf results - (matching-files-in-dir (directory-namestring pathname) - pattern all)) - (let ((remainder (namestring-without-device - (directory-namestring pathname)))) - (do-search-list (dir device) - (multiple-value-bind - (files won) - (matching-files-in-dir (concatenate 'simple-string - dir - remainder) - pattern - all) - (setf results (append results files)))))) - (setf results (sort (delete-duplicates results :test #'string=) #'string<)) - (mapcar #'(lambda (name) - (if (and check-for-subdirs - (eq (mach:unix-file-kind name) :directory)) - (pathname (concatenate 'string name "/")) - (pathname name))) - results))) + (let ((results nil)) + (enumerate-search-list + (pathname pathname) + (enumerate-matches (name pathname) + (when (or all + (let ((slash (position #\/ name :from-end t))) + (or (null slash) + (= (1+ slash) (length name)) + (char/= (schar name (1+ slash)) #\.)))) + (push name results)))) + (let ((*ignore-wildcards* t)) + (mapcar #'(lambda (name) + (if (and check-for-subdirs + (eq (mach:unix-file-kind name) :directory)) + (pathname (concatenate 'string name "/")) + (pathname name))) + (sort (delete-duplicates results :test #'string=) #'string<))))) ;;;; Printing directories. @@ -725,8 +764,8 @@ non-nil, then Unix dot files are included too (as ls -a). When :vervose is supplied and non-nil, then a long listing of miscellaneous information is output one file per line." - (setf pathname (pathname pathname)) - (let ((*standard-output* (out-synonym-of stream))) + (let ((*standard-output* (out-synonym-of stream)) + (pathname pathname)) (if verbose (print-directory-verbose pathname all return-list) (print-directory-formatted pathname all return-list)))) @@ -946,7 +985,8 @@ (t (let ((good-files (delete-if #'(lambda (pathname) - (and (pathname-type pathname) + (and (simple-string-p + (pathname-type pathname)) (member (pathname-type pathname) ignore-types :test #'string=))) @@ -974,69 +1014,56 @@ ;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal. ;;; -;;; This is necessary to make COMPLETE-FILE reasonable. The problem is that -;;; MERGE-PATHNAMES of pathname and defaults fails us when pathname has a -;;; non-nil directory slot, and pathname is relative to the "default" device. -;;; There is no good argument for making MERGE-PATHNAMES do what COMPLETE-FILE -;;; wants, but since COMPLETE-FILE is used in the context of the defaults -;;; argument, it should always complete relative to the defaults, not relative -;;; to the "default" logical name. That is, what users want when pathname is -;;; not absolute and specifies directories is something relative to the -;;; absolute defaults supplied. -;;; (defun complete-file-directory-arg (pathname defaults) - (let ((pathname (pathname pathname)) - (defaults (pathname defaults))) - (concatenate 'simple-string - (namestring - (cond - ((not (and (string= (pathname-device pathname) "Default") - (pathname-directory pathname))) - (merge-pathnames pathname defaults)) - ((eq (pathname-device defaults) :absolute) - ;; - (make-pathname - :host (or (pathname-host pathname) (pathname-host defaults)) - :device :absolute - :directory (concatenate 'simple-vector - (pathname-directory defaults) - (pathname-directory pathname)) - :name (or (pathname-name pathname) (pathname-name defaults)) - :type (or (pathname-type pathname) - (pathname-type defaults)))) - (t - ;; This branch should never fire, but just in case ... - (merge-pathnames pathname defaults)))) - "*"))) + (let* ((pathname (merge-pathnames pathname defaults)) + (type (pathname-type pathname))) + (flet ((append-multi-char-wild (thing) + (etypecase thing + (null :wild) + (pattern + (make-pattern (append (pattern-pieces thing) + (list :multi-char-wild)))) + (simple-string + (make-pattern (list thing :multi-char-wild)))))) + (if (or (null type) (eq type :unspecific)) + ;; There is no type. + (make-pathname :defaults pathname + :name (append-multi-char-wild (pathname-name pathname)) + :type :wild) + ;; There already is a type, so just extend it. + (make-pathname :defaults pathname + :name (pathname-name pathname) + :type (append-multi-char-wild (pathname-type pathname))))))) ;;; Ambiguous-Files -- Public ;;; -(defun ambiguous-files (pathname &optional defaults) +(defun ambiguous-files (pathname + &optional (defaults *default-pathname-defaults*)) "Return a list of all files which are possible completions of Pathname. We look in the directory specified by Defaults as well as looking down the search list." - (directory (concatenate 'string - (namestring - (merge-pathnames pathname - (make-pathname :defaults defaults - :name nil - :type nil))) - "*"))) + (directory (complete-file-directory-arg pathname defaults) + :check-for-subdirs nil)) + ;;; File-writable -- exported from extensions. ;;; ;;; Determines whether the single argument (which should be a pathname) ;;; can be written by the the current task. - +;;; (defun file-writable (name) "File-writable accepts a pathname and returns T if the current process can write it, and NIL otherwise." - (let ((truename (probe-file name))) + (let ((name (unix-namestring name nil))) (values - (mach:unix-access - (unix-namestring (or truename (directory-namestring name)) t) - (if truename mach:w_ok (logior mach:w_ok mach:x_ok)))))) + (if (mach:unix-file-kind name) + (mach:unix-access name mach:w_ok) + (mach:unix-access (subseq name + 0 + (or (position #\/ name :from-end t) + 0)) + (logior mach:w_ok mach:x_ok)))))) ;;; Pathname-Order -- Internal @@ -1057,9 +1084,6 @@ ;;; Default-Directory -- Public ;;; -;;; This fills in a hole in Common Lisp. We return the first thing we -;;; find by doing a ResolveSearchList on Default. -;;; (defun default-directory () "Returns the pathname for the default directory. This is the place where a file will be written if no directory is specified. This may be changed @@ -1067,22 +1091,24 @@ (multiple-value-bind (gr dir-or-error) (mach:unix-current-directory) (if gr - (pathname (concatenate 'simple-string dir-or-error "/")) + (let ((*ignore-wildcards* t)) + (pathname (concatenate 'simple-string dir-or-error "/"))) (error dir-or-error)))) -;;; -;;; Maybe this shouldn't go here... -(defsetf default-directory %set-default-directory) - ;;; %Set-Default-Directory -- Internal -;;; -;;; The setf method for Default-Directory. We actually set the environment -;;; variable Current which is by convention the head of the search list. ;;; (defun %set-default-directory (new-val) (multiple-value-bind (gr error) (mach:unix-chdir (unix-namestring new-val t)) (if gr - (car (setf (search-list "default:") - (list (default-directory)))) - (error (mach:get-unix-error-msg error))))) + (setf (search-list "default:") (default-directory)) + (error (mach:get-unix-error-msg error)))) + new-val) +;;; +(defsetf default-directory %set-default-directory) + +(defun filesys-init () + (setf *default-pathname-defaults* + (%make-pathname *unix-host* nil nil nil nil :newest)) + (setf (search-list "default:") (default-directory)) + nil)