X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=b51c6014e5ce9f48f0f0db989472da93cbf87830;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=3c5debb1fa73905f6e675223dd21157f19fa306f;hpb=83fd554b67913275d8dc06edcad8b2f065c89c49;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 3c5debb..b51c601 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -1,4 +1,5 @@ -;;;; file system interface functions -- fairly Unix-specific +;;;; file system interface functions -- fairly Unix-centric, but with +;;;; differences between Unix and Win32 papered over. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -13,17 +14,19 @@ ;;;; Unix pathname host support +;;; FIXME: the below shouldn't really be here, but in documentation +;;; (chapter 19 makes a lot of requirements for documenting +;;; implementation-dependent decisions), but anyway it's probably not +;;; what we currently do. +;;; ;;; Unix namestrings have the following format: ;;; ;;; namestring := [ directory ] [ file [ type [ version ]]] -;;; directory := [ "/" | search-list ] { file "/" }* -;;; search-list := [^:/]*: +;;; directory := [ "/" ] { file "/" }* ;;; file := [^/]* ;;; type := "." [^/.]* ;;; version := "." ([0-9]+ | "*") ;;; -;;; FIXME: Search lists are no longer supported. -;;; ;;; Note: this grammar 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 @@ -32,11 +35,7 @@ ;;; - If the first character is a dot, it's part of the file. It is not ;;; considered a dot in the following rules. ;;; -;;; - If there is only one dot, it separates 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. +;;; - Otherwise, the last dot separates the file and the type. ;;; ;;; Wildcard characters: ;;; @@ -44,10 +43,11 @@ ;;; following characters, it is considered part of a wildcard pattern ;;; and has the following meaning. ;;; -;;; ? - matches any character +;;; ? - matches any one 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. +;;; (FIXME: no it doesn't) ;;; ;;; Any of these special characters can be preceded by a backslash to ;;; cause it to be treated as a regular character. @@ -55,750 +55,398 @@ #!+sb-doc "Remove any occurrences of #\\ from the string because we've already checked for whatever they may have protected." - (declare (type simple-base-string namestr) - (type index start end)) - (let* ((result (make-string (- end start))) - (dst 0) - (quoted nil)) + (declare (type simple-string namestr) + (type index start end)) + (let* ((result (make-string (- end start) :element-type 'character)) + (dst 0) + (quoted nil)) (do ((src start (1+ src))) - ((= src end)) + ((= 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))))))) + (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 a bad place" - :namestring namestr - :offset (1- end))) - (shrink-vector result dst))) - -(defvar *ignore-wildcards* nil) - -(/show0 "filesys.lisp 86") + :complaint "backslash in a bad place" + :namestring namestr + :offset (1- end))) + (%shrink-vector result dst))) (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)) - "") - ((null (cdr (pattern))) - (let ((piece (first (pattern)))) - (typecase piece - ((member :multi-char-wild) :wild) - (simple-string piece) - (t - (make-pattern (pattern)))))) - (t - (make-pattern (pattern))))))) - -(/show0 "filesys.lisp 160") - -(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 whether 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))))) - -(/show0 "filesys.lisp 200") + (declare (type simple-string namestr) + (type index 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 (cons :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)) + "") + ((null (cdr (pattern))) + (let ((piece (first (pattern)))) + (typecase piece + ((member :multi-char-wild) :wild) + (simple-string piece) + (t + (make-pattern (pattern)))))) + (t + (make-pattern (pattern)))))) -;;; Take a string and return a list of cons cells that mark the char -;;; separated subseq. The first value is true if absolute directories -;;; location. -(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-separated 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))) - ;; PVE: make sure there are no illegal characters in - ;; the name, illegal being (code-char 0) and #\/ - #!+high-security - (when (and (stringp name) - (find-if #'(lambda (x) (or (char= x (code-char 0)) - (char= x #\/))) - name)) - (error 'parse-error)) - - ;; 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) - (cond ((string= namestr ".." :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestr "**" :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestr - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) - -(/show0 "filesys.lisp 300") - -(defun unparse-unix-host (pathname) - (declare (type pathname pathname) - (ignore pathname)) - "Unix") - -(defun unparse-unix-piece (thing) +(defun unparse-physical-piece (thing) (etypecase thing ((member :wild) "*") (simple-string (let* ((srclen (length thing)) - (dstlen srclen)) + (dstlen srclen)) (dotimes (i srclen) - (case (schar thing i) - ((#\* #\? #\[) - (incf dstlen)))) + (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))) + (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)) + (with-output-to-string (s) (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string - (strings piece)) - (symbol - (ecase piece - (:multi-char-wild - (strings "*")) - (:single-char-wild - (strings "?")))) - (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.")) - ((member :wild-inferiors) - (pieces "**/")) - ((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))))) - ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when - ;; translating logical pathnames to a filesystem without - ;; versions (like Unix). - (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)))) - (apply #'concatenate 'simple-string (strings)))) - -(/show0 "filesys.lisp 406") - -(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-directory - (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-directory))) - (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))))) + (etypecase piece + (simple-string + (write-string piece s)) + (symbol + (ecase piece + (:multi-char-wild + (write-string "*" s)) + (:single-char-wild + (write-string "?" s)))) + (cons + (case (car piece) + (:character-set + (write-string "[" s) + (write-string (cdr piece) s) + (write-string "]" s)) + (t + (error "invalid pattern piece: ~S" piece)))))))))) -(/show0 "filesys.lisp 471") +(defun make-matcher (piece) + (cond ((eq piece :wild) + (constantly t)) + ((typep piece 'pattern) + (lambda (other) + (when (stringp other) + (pattern-matches piece other)))) + (t + (lambda (other) + (equal piece other))))) -(def!struct (unix-host - (:make-load-form-fun make-unix-host-load-form) - (: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)))) - -(/show0 "filesys.lisp 486") +(/show0 "filesys.lisp 160") -(defvar *unix-host* (make-unix-host)) +(defun extract-name-type-and-version (namestr start end) + (declare (type simple-string namestr) + (type index start end)) + (let* ((last-dot (position #\. namestr :start (1+ start) :end end + :from-end t))) + (cond + (last-dot + (values (maybe-make-pattern namestr start last-dot) + (maybe-make-pattern namestr (1+ last-dot) end) + :newest)) + (t + (values (maybe-make-pattern namestr start end) + nil + :newest))))) -(/show0 "filesys.lisp 488") +(/show0 "filesys.lisp 200") -(defun make-unix-host-load-form (host) - (declare (ignore host)) - '*unix-host*) -;;;; wildcard matching stuff - -;;; Return a list of all the Lispy filenames (not including e.g. the -;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME. -(defun directory-lispy-filenames (directory-name) - (with-alien ((adlf (* c-string) - (alien-funcall (extern-alien - "alloc_directory_lispy_filenames" - (function (* c-string) c-string)) - directory-name))) - (if (null-alien adlf) - (error 'simple-file-error - :pathname directory-name - :format-control "~@" - :format-arguments (list directory-name (strerror))) - (unwind-protect - (c-strings->string-list adlf) - (alien-funcall (extern-alien "free_directory_lispy_filenames" - (function void (* c-string))) - adlf))))) - -(/show0 "filesys.lisp 498") - -;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL) - -(defmacro enumerate-matches ((var pathname &optional result - &key (verify-existence t) - (follow-links t)) - &body body) - (let ((body-name (gensym "ENUMERATE-MATCHES-BODY-FUN-"))) - `(block nil - (flet ((,body-name (,var) - ,@body)) - (declare (dynamic-extent ,body-name)) - (%enumerate-matches (pathname ,pathname) - ,verify-existence - ,follow-links - #',body-name) - ,result)))) - -(/show0 "filesys.lisp 500") - -;;; Call FUNCTION on matches. -(defun %enumerate-matches (pathname verify-existence follow-links function) - (/show0 "entering %ENUMERATE-MATCHES") - (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))) - (/show0 "computed DIRECTORY") - (if directory - (ecase (car directory) - (:absolute - (/show0 "absolute directory") - (%enumerate-directories "/" (cdr directory) pathname - verify-existence follow-links - nil function)) - (:relative - (/show0 "relative directory") - (%enumerate-directories "" (cdr directory) pathname - verify-existence follow-links - nil function))) - (%enumerate-files "" pathname verify-existence function)))) +;;;; Grabbing the kind of file when we have a namestring. +(defun native-file-kind (namestring) + (multiple-value-bind (existsp errno ino mode) + #!-win32 + (sb!unix:unix-lstat namestring) + #!+win32 + (sb!unix:unix-stat namestring) + (declare (ignore errno ino)) + (when existsp + (let ((ifmt (logand mode sb!unix:s-ifmt))) + (case ifmt + (#.sb!unix:s-ifreg :file) + (#.sb!unix:s-ifdir :directory) + #!-win32 + (#.sb!unix:s-iflnk :symlink) + (t :special)))))) + +;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. -;;; Call FUNCTION on directories. -(defun %enumerate-directories (head tail pathname verify-existence - follow-links nodes function) - (declare (simple-string head)) - (macrolet ((unix-xstat (name) - `(if follow-links - (sb!unix:unix-stat ,name) - (sb!unix:unix-lstat ,name))) - (with-directory-node-noted ((head) &body body) - `(multiple-value-bind (res dev ino mode) - (unix-xstat ,head) - (when (and res (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)) - (let ((nodes (cons (cons dev ino) nodes))) - ,@body))))) - (if tail - (let ((piece (car tail))) - (etypecase piece - (simple-string - (let ((head (concatenate 'string head piece))) - (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'string head "/") - (cdr tail) pathname - verify-existence follow-links - nodes function)))) - ((member :wild-inferiors) - (%enumerate-directories head (rest tail) pathname - verify-existence follow-links - nodes function) - (dolist (name (ignore-errors (directory-lispy-filenames head))) - (let ((subdir (concatenate 'string head name))) - (multiple-value-bind (res dev ino mode) - (unix-xstat subdir) - (declare (type (or fixnum null) mode)) - (when (and res (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)) - (unless (dolist (dir nodes nil) - (when (and (eql (car dir) dev) - (eql (cdr dir) ino)) - (return t))) - (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'string subdir "/"))) - (%enumerate-directories subdir tail pathname - verify-existence follow-links - nodes function)))))))) - ((or pattern (member :wild)) - (dolist (name (directory-lispy-filenames head)) - (when (or (eq piece :wild) (pattern-matches piece name)) - (let ((subdir (concatenate 'string head name))) - (multiple-value-bind (res dev ino mode) - (unix-xstat subdir) - (declare (type (or fixnum null) mode)) - (when (and res - (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)) - (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'string subdir "/"))) - (%enumerate-directories subdir (rest tail) pathname - verify-existence follow-links - nodes function)))))))) - ((member :up) - (let ((head (concatenate 'string head ".."))) - (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'string head "/") - (rest tail) pathname - verify-existence follow-links - nodes function)))))) - (%enumerate-files head pathname verify-existence function)))) +;;; Rewritten in 12/2007 by RMK, replacing 13+ year old CMU code that +;;; made a mess of things in order to support search lists (which SBCL +;;; has never had). These are now all relatively straightforward +;;; wrappers around stat(2) and realpath(2), with the same basic logic +;;; in all cases. The wrinkles to be aware of: +;;; +;;; * SBCL defines the truename of an existing, dangling or +;;; self-referring symlink to be the symlink itself. +;;; * The old version of PROBE-FILE merged the pathspec against +;;; *DEFAULT-PATHNAME-DEFAULTS* twice, and so lost when *D-P-D* +;;; was a relative pathname. Even if the case where *D-P-D* is a +;;; relative pathname is problematic, there's no particular reason +;;; to get that wrong, so let's try not to. +;;; * Note that while stat(2) is probably atomic, getting the truename +;;; for a filename involves poking all over the place, and so is +;;; subject to race conditions if other programs mutate the file +;;; system while we're resolving symlinks. So it's not implausible for +;;; realpath(3) to fail even if stat(2) succeeded. There's nothing +;;; obvious we can do about this, however. +;;; * Windows' apparent analogue of realpath(3) is called +;;; GetFullPathName, and it's a bit less useful than realpath(3). +;;; In particular, while realpath(3) errors in case the file doesn't +;;; exist, GetFullPathName seems to return a filename in all cases. +;;; As realpath(3) is not atomic anyway, we only ever call it when +;;; we think a file exists, so just be careful when rewriting this +;;; routine. +;;; +;;; Given a pathname designator, some quality to query for, return one +;;; of a pathname, a universal time, or a string (a file-author), or +;;; NIL. QUERY-FOR may be one of :TRUENAME, :EXISTENCE, :WRITE-DATE, +;;; :AUTHOR. If ERRORP is false, return NIL in case the file system +;;; returns an error code; otherwise, signal an error. Accepts +;;; logical pathnames, too (but never returns LPNs). For internal +;;; use. +(defun query-file-system (pathspec query-for &optional (errorp t)) + (let ((pathname (translate-logical-pathname + (merge-pathnames + (pathname pathspec) + (sane-default-pathname-defaults))))) + (when (wild-pathname-p pathname) + (error 'simple-file-error + :pathname pathname + :format-control "~@" + :format-arguments (list query-for pathname pathspec))) + (flet ((fail (note-format pathname errno) + (if errorp + (simple-file-perror note-format pathname errno) + (return-from query-file-system nil)))) + (let ((filename (native-namestring pathname :as-file t))) + #!+win32 + (case query-for + ((:existence :truename) + (multiple-value-bind (file kind) + (sb!win32::native-probe-file-name filename) + (when (and (not file) kind) + (setf file filename)) + ;; The following OR was an AND, but that breaks files like NUL, + ;; for which GetLongPathName succeeds yet GetFileAttributesEx + ;; fails to return the file kind. --DFL + (if (or file kind) + (values + (parse-native-namestring + file + (pathname-host pathname) + (sane-default-pathname-defaults) + :as-directory (eq :directory kind))) + (fail "couldn't resolve ~A" filename + (- (sb!win32:get-last-error)))))) + (:write-date + (or (sb!win32::native-file-write-date filename) + (fail "couldn't query write date of ~A" filename + (- (sb!win32:get-last-error)))))) + #!-win32 + (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size + atime mtime) + (sb!unix:unix-stat filename) + (declare (ignore ino nlink gid rdev size atime)) + (labels ((parse (filename &key (as-directory + (eql (logand mode + sb!unix:s-ifmt) + sb!unix:s-ifdir))) + (values + (parse-native-namestring + filename + (pathname-host pathname) + (sane-default-pathname-defaults) + :as-directory as-directory))) + (resolve-problematic-symlink (&optional realpath-failed) + ;; SBCL has for many years had a policy that a pathname + ;; that names an existing, dangling or self-referential + ;; symlink denotes the symlink itself. stat(2) fails + ;; and sets errno to ENOENT or ELOOP respectively, but + ;; we must distinguish cases where the symlink exists + ;; from ones where there's a loop in the apparent + ;; containing directory. + ;; Also handles symlinks in /proc/pid/fd/ to + ;; pipes or sockets on Linux + (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev + size atime mtime) + (sb!unix:unix-lstat filename) + (declare (ignore ignore ino mode nlink gid rdev size atime)) + (when (and (or (= errno sb!unix:enoent) + (= errno sb!unix:eloop) + realpath-failed) + linkp) + (return-from query-file-system + (case query-for + (:existence + ;; We do this reparse so as to return a + ;; normalized pathname. + (parse filename :as-directory nil)) + (:truename + ;; So here's a trick: since lstat succeded, + ;; FILENAME exists, so its directory exists and + ;; only the non-directory part is loopy. So + ;; let's resolve FILENAME's directory part with + ;; realpath(3), in order to get a canonical + ;; absolute name for the directory, and then + ;; return a pathname having PATHNAME's name, + ;; type, and version, but the rest from the + ;; truename of the directory. Since we turned + ;; PATHNAME into FILENAME "as a file", FILENAME + ;; does not end in a slash, and so we get the + ;; directory part of FILENAME by reparsing + ;; FILENAME and masking off its name, type, and + ;; version bits. But note not to call ourselves + ;; recursively, because we don't want to + ;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*, + ;; since PATHNAME may be a relative pathname. + (merge-pathnames + (parse + (multiple-value-bind (realpath errno) + (sb!unix:unix-realpath + (native-namestring + (make-pathname + :name :unspecific + :type :unspecific + :version :unspecific + :defaults (parse filename + :as-directory nil)))) + (or realpath + (fail "couldn't resolve ~A" filename errno))) + :as-directory t) + pathname)) + (:author (sb!unix:uid-username uid)) + (:write-date (+ unix-to-universal-time mtime)))))) + ;; If we're still here, the file doesn't exist; error. + (fail + (format nil "failed to find the ~A of ~~A" query-for) + pathspec errno))) + (if existsp + (case query-for + (:existence (parse filename)) + (:truename + ;; Note: in case the file is stat'able, POSIX + ;; realpath(3) gets us a canonical absolute + ;; filename, even if the post-merge PATHNAME + ;; is not absolute + (parse (or (sb!unix:unix-realpath filename) + (resolve-problematic-symlink t)))) + (:author (sb!unix:uid-username uid)) + (:write-date (+ unix-to-universal-time mtime))) + (resolve-problematic-symlink)))))))) -;;; Call FUNCTION on files. -(defun %enumerate-files (directory pathname verify-existence function) - (declare (simple-string directory)) - (/show0 "entering %ENUMERATE-FILES") - (let ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (version (%pathname-version pathname))) - (/show0 "computed NAME, TYPE, and VERSION") - (cond ((member name '(nil :unspecific)) - (/show0 "UNSPECIFIC, more or less") - (when (or (not verify-existence) - (sb!unix:unix-file-kind directory)) - (funcall function directory))) - ((or (pattern-p name) - (pattern-p type) - (eq name :wild) - (eq type :wild)) - (/show0 "WILD, more or less") - ;; I IGNORE-ERRORS here just because the original CMU CL - ;; code did. I think the intent is that it's not an error - ;; to request matches to a wild pattern when no matches - ;; exist, but I haven't tried to figure out whether - ;; everything is kosher. (E.g. what if we try to match a - ;; wildcard but we don't have permission to read one of the - ;; relevant directories?) -- WHN 2001-04-17 - (dolist (complete-filename (ignore-errors - (directory-lispy-filenames directory))) - (multiple-value-bind - (file-name file-type file-version) - (let ((*ignore-wildcards* t)) - (extract-name-type-and-version - complete-filename 0 (length complete-filename))) - (when (and (components-match file-name name) - (components-match file-type type) - (components-match file-version version)) - (funcall function - (concatenate 'string - directory - complete-filename)))))) - (t - (/show0 "default case") - (let ((file (concatenate 'string directory name))) - (/show0 "computed basic FILE=..") - (/primitive-print file) - (unless (or (null type) (eq type :unspecific)) - (/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case") - (setf file (concatenate 'string file "." type))) - (unless (member version '(nil :newest :wild)) - (/show0 "tweaking FILE for more-or-less-:WILD case") - (setf file (concatenate 'string file "." - (quick-integer-to-string version)))) - (/show0 "finished possibly tweaking FILE=..") - (/primitive-print file) - (when (or (not verify-existence) - (sb!unix:unix-file-kind file t)) - (/show0 "calling FUNCTION on FILE") - (funcall function file))))))) -(/show0 "filesys.lisp 603") +(defun probe-file (pathspec) + #!+sb-doc + "Return the truename of PATHSPEC if the truename can be found, +or NIL otherwise. See TRUENAME for more information." + (query-file-system pathspec :truename nil)) -;;; FIXME: Why do we need this? -(defun quick-integer-to-string (n) - (declare (type integer n)) - (cond ((not (fixnump n)) - (write-to-string n :base 10 :radix nil)) - ((zerop n) "0") - ((eql n 1) "1") - ((minusp n) - (concatenate 'simple-string "-" - (the simple-string (quick-integer-to-string (- n))))) - (t - (do* ((len (1+ (truncate (integer-length n) 3))) - (res (make-string len)) - (i (1- len) (1- i)) - (q n) - (r 0)) - ((zerop q) - (incf i) - (replace res res :start2 i :end2 len) - (shrink-vector res (- len i))) - (declare (simple-string res) - (fixnum len i r q)) - (multiple-value-setq (q r) (truncate q 10)) - (setf (schar res i) (schar "0123456789" r)))))) - -;;;; UNIX-NAMESTRING +(defun truename (pathspec) + #!+sb-doc + "If PATHSPEC is a pathname that names an existing file, return +a pathname that denotes a canonicalized name for the file. If +pathspec is a stream associated with a file, return a pathname +that denotes a canonicalized name for the file associated with +the stream. -(defun empty-relative-pathname-spec-p (x) - (or (equal x "") - (and (pathnamep x) - (or (equal (pathname-directory x) '(:relative)) - ;; KLUDGE: I'm not sure this second check should really - ;; have to be here. But on sbcl-0.6.12.7, - ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and - ;; (PATHNAME "") seems to act like an empty relative - ;; pathname, so in order to work with that, I test - ;; for NIL here. -- WHN 2001-05-18 - (null (pathname-directory x))) - (null (pathname-name x)) - (null (pathname-type x))) - ;; (The ANSI definition of "pathname specifier" has - ;; other cases, but none of them seem to admit the possibility - ;; of being empty and relative.) - )) +An error of type FILE-ERROR is signalled if no such file exists +or if the file system is such that a canonicalized file name +cannot be determined or if the pathname is wild. -;;; Convert PATHNAME into a string that can be used with UNIX system -;;; calls, or return NIL if no match is found. Search-lists and -;;; wild-cards are expanded. -(defun unix-namestring (pathname-spec &optional (for-input t)) - ;; The ordinary rules of converting Lispy paths to Unix paths break - ;; down for the current working directory, which Lisp thinks of as - ;; "" (more or less, and modulo ANSI's *DEFAULT-PATHNAME-DEFAULTS*, - ;; which unfortunately SBCL, as of sbcl-0.6.12.8, basically ignores) - ;; and Unix thinks of as ".". Since we're at the interface between - ;; Unix system calls and things like ENSURE-DIRECTORIES-EXIST which - ;; think the Lisp way, we perform the conversion. - ;; - ;; (FIXME: The *right* way to deal with this special case is to - ;; merge PATHNAME-SPEC with *DEFAULT-PATHNAME-DEFAULTS* here, after - ;; which it's not a relative pathname any more so the special case - ;; is no longer an issue. But until *DEFAULT-PATHNAME-DEFAULTS* - ;; works, we use this hack.) - (if (empty-relative-pathname-spec-p pathname-spec) - "." - ;; Otherwise, the ordinary rules apply. - (let* ((namestring (physicalize-pathname (pathname pathname-spec))) - (matches nil)) ; an accumulator for actual matches - (enumerate-matches (match namestring nil :verify-existence for-input) - (push match matches)) - (case (length matches) - (0 nil) - (1 (first matches)) - (t (error 'simple-file-error - :format-control "~S is ambiguous:~{~% ~A~}" - :format-arguments (list pathname-spec matches))))))) - -;;;; TRUENAME and PROBE-FILE +Under Unix, the TRUENAME of a symlink that links to itself or to +a file that doesn't exist is considered to be the name of the +broken symlink itself." + ;; Note that eventually this routine might be different for streams + ;; than for other pathname designators. + (if (streamp pathspec) + (query-file-system pathspec :truename) + (query-file-system pathspec :truename))) -;;; This is only trivially different from PROBE-FILE, which is silly -;;; but ANSI. -(defun truename (pathname) +(defun file-author (pathspec) #!+sb-doc - "Return the pathname for the actual file described by PATHNAME. - An error of type FILE-ERROR is signalled if no such file exists, - or the pathname is wild. - - Under Unix, the TRUENAME of a broken symlink is considered to be - the name of the broken symlink itself." - (if (wild-pathname-p pathname) - (error 'simple-file-error - :format-control "can't use a wild pathname here" - :pathname pathname) - (let ((result (probe-file pathname))) - (unless result - (error 'simple-file-error - :pathname pathname - :format-control "The file ~S does not exist." - :format-arguments (list (namestring pathname)))) - result))) + "Return the author of the file specified by PATHSPEC. Signal an +error of type FILE-ERROR if no such file exists, or if PATHSPEC +is a wild pathname." + (query-file-system pathspec :author)) -;;; If PATHNAME exists, return its truename, otherwise NIL. -(defun probe-file (pathname) +(defun file-write-date (pathspec) #!+sb-doc - "Return a pathname which is the truename of the file if it exists, or NIL - otherwise. An error of type FILE-ERROR is signaled if pathname is wild." - (when (wild-pathname-p pathname) - (error 'simple-file-error - :pathname pathname - :format-control "can't use a wild pathname here")) - (let* ((defaulted-pathname (merge-pathnames - pathname - (sane-default-pathname-defaults))) - (namestring (unix-namestring defaulted-pathname t))) - (when (and namestring (sb!unix:unix-file-kind namestring t)) - (let ((trueishname (sb!unix:unix-resolve-links namestring))) - (when trueishname - (let ((*ignore-wildcards* t)) - (pathname (sb!unix:unix-simplify-pathname trueishname)))))))) + "Return the write date of the file specified by PATHSPEC. +An error of type FILE-ERROR is signaled if no such file exists, +or if PATHSPEC is a wild pathname." + (query-file-system pathspec :write-date)) ;;;; miscellaneous other operations @@ -807,248 +455,751 @@ (defun rename-file (file new-name) #!+sb-doc "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a - file, then the associated file is renamed." - (let* ((original (truename file)) - (original-namestring (unix-namestring original t)) - (new-name (merge-pathnames new-name original)) - (new-namestring (unix-namestring new-name nil))) +file, then the associated file is renamed." + (let* ((original (merge-pathnames file (sane-default-pathname-defaults))) + (old-truename (truename original)) + (original-namestring (native-namestring (physicalize-pathname original) + :as-file t)) + (new-name (merge-pathnames new-name original)) + (new-namestring (native-namestring (physicalize-pathname new-name) + :as-file t))) (unless new-namestring (error 'simple-file-error - :pathname new-name - :format-control "~S can't be created." - :format-arguments (list new-name))) + :pathname new-name + :format-control "~S can't be created." + :format-arguments (list new-name))) (multiple-value-bind (res error) - (sb!unix:unix-rename original-namestring new-namestring) + (sb!unix:unix-rename original-namestring new-namestring) (unless res - (error 'simple-file-error - :pathname new-name - :format-control "~@" - :format-arguments (list original new-name (strerror error)))) + :format-arguments (list original new-name (strerror error)))) (when (streamp file) - (file-name file new-namestring)) - (values new-name original (truename new-name))))) + (file-name file new-name)) + (values new-name old-truename (truename new-name))))) (defun delete-file (file) #!+sb-doc - "Delete the specified FILE." - (let ((namestring (unix-namestring file t))) + "Delete the specified FILE. + +If FILE is a stream, on Windows the stream is closed immediately. On Unix +plaforms the stream remains open, allowing IO to continue: the OS resources +associated with the deleted file remain available till the stream is closed as +per standard Unix unlink() behaviour." + (let* ((pathname (translate-logical-pathname + (merge-pathnames file (sane-default-pathname-defaults)))) + (namestring (native-namestring pathname :as-file t))) + #!+win32 (when (streamp file) - (close file :abort t)) - (unless namestring - (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) - (multiple-value-bind (res err) (sb!unix:unix-unlink namestring) - (unless res - (simple-file-perror "couldn't delete ~A" namestring err)))) + (close file)) + (multiple-value-bind (res err) + #!-win32 (sb!unix:unix-unlink namestring) + #!+win32 (or (sb!win32::native-delete-file namestring) + (values nil (- (sb!win32:get-last-error)))) + (unless res + (simple-file-perror "couldn't delete ~A" namestring err)))) t) + +(defun directorize-pathname (pathname) + (if (or (pathname-name pathname) + (pathname-type pathname)) + (make-pathname :directory (append (pathname-directory pathname) + (list (file-namestring pathname))) + :host (pathname-host pathname) + :device (pathname-device pathname)) + pathname)) + +(defun delete-directory (pathspec &key recursive) + "Deletes the directory designated by PATHSPEC (a pathname designator). +Returns the truename of the directory deleted. + +If RECURSIVE is false \(the default), signals an error unless the directory is +empty. If RECURSIVE is true, first deletes all files and subdirectories. If +RECURSIVE is true and the directory contains symbolic links, the links are +deleted, not the files and directories they point to. + +Signals an error if PATHSPEC designates a file or a symbolic link instead of a +directory, or if the directory could not be deleted for any reason. + +Both + + \(DELETE-DIRECTORY \"/tmp/foo\") + \(DELETE-DIRECTORY \"/tmp/foo/\") + +delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not +exist or if is a file or a symbolic link." + (declare (type pathname-designator pathspec)) + (let ((physical (directorize-pathname + (physicalize-pathname + (merge-pathnames + pathspec (sane-default-pathname-defaults)))))) + (labels ((recurse-merged (dir) + (lambda (sub) + (recurse (merge-pathnames sub dir)))) + (delete-merged (dir) + (lambda (file) + (delete-file (merge-pathnames file dir)))) + (recurse (dir) + (map-directory (recurse-merged dir) dir + :files nil + :directories t + :classify-symlinks nil) + (map-directory (delete-merged dir) dir + :files t + :directories nil + :classify-symlinks nil) + (delete-dir dir)) + (delete-dir (dir) + (let ((namestring (native-namestring dir :as-file t))) + (multiple-value-bind (res errno) + #!+win32 + (or (sb!win32::native-delete-directory namestring) + (values nil (- (sb!win32:get-last-error)))) + #!-win32 + (values + (not (minusp (alien-funcall + (extern-alien "rmdir" + (function int c-string)) + namestring))) + (get-errno)) + (if res + dir + (simple-file-perror + "Could not delete directory ~A" + namestring errno)))))) + (if recursive + (recurse physical) + (delete-dir physical))))) + -;;; (This is an ANSI Common Lisp function.) -;;; -;;; This is obtained from the logical name \"home:\", which is set -;;; up for us at initialization time. -(defun user-homedir-pathname (&optional host) - "Return the home directory of the user as a pathname." - (declare (ignore host)) - ;; Note: CMU CL did #P"home:" here instead of using a call to - ;; PATHNAME. Delaying construction of the pathname until we're - ;; running in a target Lisp lets us avoid figuring out how to dump - ;; cross-compilation host Lisp PATHNAME objects into a target Lisp - ;; object file. It also might have a small positive effect on - ;; efficiency, in that we don't allocate a PATHNAME we don't need, - ;; but it it could also have a larger negative effect. Hopefully - ;; it'll be OK. -- WHN 19990714 - (pathname "home:")) +(defun sbcl-homedir-pathname () + (let ((sbcl-home (posix-getenv "SBCL_HOME"))) + ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores + (when (and sbcl-home (not (string= sbcl-home ""))) + (parse-native-namestring sbcl-home + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t)))) -(defun file-write-date (file) - #!+sb-doc - "Return file's creation date, or NIL if it doesn't exist. - An error of type file-error is signaled if file is a wild pathname" - (if (wild-pathname-p file) - ;; FIXME: This idiom appears many times in this file. Perhaps it - ;; should turn into (CANNOT-BE-WILD-PATHNAME FILE). (C-B-W-P - ;; should be a macro, not a function, so that the error message - ;; is reported as coming from e.g. FILE-WRITE-DATE instead of - ;; from CANNOT-BE-WILD-PATHNAME itself.) - (error 'simple-file-error - :pathname file - :format-control "bad place for a wild pathname") - (let ((name (unix-namestring file t))) - (when name - (multiple-value-bind - (res dev ino mode nlink uid gid rdev size atime mtime) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (when res - (+ unix-to-universal-time mtime))))))) +(defun user-homedir-namestring (&optional username) + (if username + (sb!unix:user-homedir username) + (let ((env-home (posix-getenv "HOME"))) + (if (and env-home (not (string= env-home ""))) + env-home + #!-win32 + (sb!unix:uid-homedir (sb!unix:unix-getuid)))))) -(defun file-author (file) +;;; (This is an ANSI Common Lisp function.) +(defun user-homedir-pathname (&optional host) #!+sb-doc - "Return the file author as a string, or nil if the author cannot be - determined. Signal an error of type FILE-ERROR if FILE doesn't exist, - or FILE is a wild pathname." - (if (wild-pathname-p file) - (error 'simple-file-error - :pathname file - "bad place for a wild pathname") - (let ((name (unix-namestring (pathname file) t))) - (unless name - (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) - (multiple-value-bind (winp dev ino mode nlink uid) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink)) - (if winp (lookup-login-name uid)))))) + "Return the home directory of the user as a pathname. If the HOME +environment variable has been specified, the directory it designates +is returned; otherwise obtains the home directory from the operating +system. HOST argument is ignored by SBCL." + (declare (ignore host)) + (values + (parse-native-namestring + (or (user-homedir-namestring) + #!+win32 + (sb!win32::get-folder-namestring sb!win32::csidl_profile)) + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t))) + ;;;; DIRECTORY -(/show0 "filesys.lisp 800") - -(defun directory (pathname &key) +(defun directory (pathspec &key (resolve-symlinks t)) #!+sb-doc "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the - given pathname. Note that the interaction between this ANSI-specified - TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) - means this function can sometimes return files which don't have the same - directory as PATHNAME." - (let ((truenames nil)) - (enumerate-search-list - (pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild))) - (enumerate-matches (match pathname) - (let ((*ignore-wildcards* t)) - (push (truename (if (eq (sb!unix:unix-file-kind match) :directory) - (concatenate 'string match "/") - match)) - truenames)))) - ;; FIXME: The DELETE-DUPLICATES here requires quadratic time, - ;; which is unnecessarily slow. That might not be an issue, - ;; though, since the time constant for doing TRUENAME on every - ;; directory entry is likely to be (much) larger, and the cost of - ;; all those TRUENAMEs on a huge directory might even be quadratic - ;; in the directory size. Someone who cares about enormous - ;; directories might want to check this. -- WHN 2001-06-19 - (sort (delete-duplicates truenames :test #'string= :key #'pathname-name) - #'string< :key #'pathname-name))) - -;;;; translating Unix uid's -;;;; -;;;; FIXME: should probably move into unix.lisp +given pathname. Note that the interaction between this ANSI-specified +TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) means +this function can sometimes return files which don't have the same directory +as PATHNAME. If :RESOLVE-SYMLINKS is NIL, don't resolve symbolic links in +matching filenames." + (let (;; We create one entry in this hash table for each truename, + ;; as an asymptotically efficient way of removing duplicates + ;; (which can arise when e.g. multiple symlinks map to the + ;; same truename). + (truenames (make-hash-table :test #'equal))) + (labels ((record (pathname) + (let ((truename (if resolve-symlinks + ;; FIXME: Why not not TRUENAME? As reported by + ;; Milan Zamazal sbcl-devel 2003-10-05, using + ;; TRUENAME causes a race condition whereby + ;; removal of a file during the directory + ;; operation causes an error. It's not clear + ;; what the right thing to do is, though. -- + ;; CSR, 2003-10-13 + (query-file-system pathname :truename nil) + (query-file-system pathname :existence nil)))) + (when truename + (setf (gethash (namestring truename) truenames) + truename)))) + (do-physical-pathnames (pathname) + (aver (not (logical-pathname-p pathname))) + (let* (;; KLUDGE: Since we don't canonize pathnames on construction, + ;; we really have to do it here to get #p"foo/." mean the same + ;; as #p"foo/./". + (pathname (canonicalize-pathname pathname)) + (name (pathname-name pathname)) + (type (pathname-type pathname)) + (match-name (make-matcher name)) + (match-type (make-matcher type))) + (map-matching-directories + (if (or name type) + (lambda (directory) + (map-matching-entries #'record + directory + match-name + match-type)) + #'record) + pathname))) + (do-pathnames (pathname) + (if (logical-pathname-p pathname) + (let ((host (intern-logical-host (pathname-host pathname)))) + (dolist (x (logical-host-canon-transls host)) + (destructuring-bind (from to) x + (let ((intersections + (pathname-intersections pathname from))) + (dolist (p intersections) + (do-pathnames (translate-pathname p from to))))))) + (do-physical-pathnames pathname)))) + (declare (truly-dynamic-extent #'record)) + (do-pathnames (merge-pathnames pathspec))) + (mapcar #'cdr + ;; Sorting isn't required by the ANSI spec, but sorting into some + ;; canonical order seems good just on the grounds that the + ;; implementation should have repeatable behavior when possible. + (sort (loop for namestring being each hash-key in truenames + using (hash-value truename) + collect (cons namestring truename)) + #'string< + :key #'car)))) + +(defun canonicalize-pathname (pathname) + ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP, + ;; and dealing with #p"foo/.." and #p"foo/." + (labels ((simplify (piece) + (unless (eq :unspecific piece) + piece)) + (canonicalize-directory (directory) + (let (pieces) + (dolist (piece directory) + (cond + ((and pieces (member piece '(:back :up))) + ;; FIXME: We should really canonicalize when we construct + ;; pathnames. This is just wrong. + (case (car pieces) + ((:absolute :wild-inferiors) + (error 'simple-file-error + :format-control "Invalid use of ~S after ~S." + :format-arguments (list piece (car pieces)) + :pathname pathname)) + ((:relative :up :back) + (push piece pieces)) + (t + (pop pieces)))) + ((equal piece ".") + ;; This case only really matters on Windows, + ;; because on POSIX, our call site (TRUENAME via + ;; QUERY-FILE-SYSTEM) only passes in pathnames from + ;; realpath(3), in which /./ has been removed + ;; already. Windows, however, depends on us to + ;; perform this fixup. -- DFL + ) + (t + (push piece pieces)))) + (nreverse pieces)))) + (let ((name (simplify (pathname-name pathname))) + (type (simplify (pathname-type pathname))) + (dir (canonicalize-directory (pathname-directory pathname)))) + (cond ((equal "." name) + (cond ((not type) + (make-pathname :name nil :defaults pathname)) + ((equal "" type) + (make-pathname :name nil + :type nil + :directory (butlast dir) + :defaults pathname)))) + (t + (make-pathname :name name :type type + :directory dir + :defaults pathname)))))) + +;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style +;;; interface to mapping over namestrings of entries in the corresponding +;;; directory. +(defmacro with-native-directory-iterator ((iterator namestring &key errorp) &body body) + (with-unique-names (one-iter) + `(dx-flet + ((iterate (,one-iter) + (declare (type function ,one-iter)) + (macrolet ((,iterator () + `(funcall ,',one-iter))) + ,@body))) + #!+win32 + (sb!win32::native-call-with-directory-iterator + #'iterate ,namestring ,errorp) + #!-win32 + (call-with-native-directory-iterator #'iterate ,namestring ,errorp)))) -(defvar *uid-hash-table* (make-hash-table) +(defun call-with-native-directory-iterator (function namestring errorp) + (declare (type (or null string) namestring) + (function function)) + (let (dp) + (when namestring + (dx-flet + ((one-iter () + (tagbody + :next + (let ((ent (sb!unix:unix-readdir dp nil))) + (when ent + (let ((name (sb!unix:unix-dirent-name ent))) + (when name + (cond ((equal "." name) + (go :next)) + ((equal ".." name) + (go :next)) + (t + (return-from one-iter name)))))))))) + (unwind-protect + (progn + (setf dp (sb!unix:unix-opendir namestring errorp)) + (when dp + (funcall function #'one-iter))) + (when dp + (sb!unix:unix-closedir dp nil))))))) + +;;; This is our core directory access interface that we use to implement +;;; DIRECTORY. +(defun map-directory (function directory &key (files t) (directories t) + (classify-symlinks t) (errorp t)) #!+sb-doc - "hash table for keeping track of uid's and login names") + "Map over entries in DIRECTORY. Keyword arguments specify which entries to +map over, and how: + + :FILES + If true, call FUNCTION with the pathname of each file in DIRECTORY. + Defaults to T. + + :DIRECTORIES + If true, call FUNCTION with a pathname for each subdirectory of DIRECTORY. + If :AS-FILES, the pathname used is a pathname designating the subdirectory + as a file in DIRECTORY. Otherwise the pathname used is a directory + pathname. Defaults to T. + + :CLASSIFY-SYMLINKS + If true, the decision to call FUNCTION with the pathname of a symbolic link + depends on the resolution of the link: if it points to a directory, it is + considered a directory entry, otherwise a file entry. If false, all + symbolic links are considered file entries. In both cases the pathname used + for the symbolic link is not fully resolved, but names it as an immediate + child of DIRECTORY. Defaults to T. + + :ERRORP + If true, signal an error if DIRECTORY does not exist, cannot be read, etc. + Defaults to T. + +Experimental: interface subject to change." + (declare (pathname-designator directory)) + (let* ((fun (%coerce-callable-to-fun function)) + (as-files (eq :as-files directories)) + (physical (physicalize-pathname directory)) + (realname (query-file-system physical :existence nil)) + (canonical (if realname + (parse-native-namestring realname + (pathname-host physical) + (sane-default-pathname-defaults) + :as-directory t) + (return-from map-directory nil))) + (dirname (native-namestring canonical))) + (flet ((map-it (name dirp) + (funcall fun + (merge-pathnames (parse-native-namestring + name nil physical + :as-directory (and dirp (not as-files))) + physical)))) + (with-native-directory-iterator (next dirname :errorp errorp) + (loop + ;; provision for FindFirstFileExW-based iterator that should be used + ;; on Windows: file kind is known instantly there, so we'll have it + ;; returned by (next) soon. + (multiple-value-bind (name kind) (next) + (unless (or name kind) (return)) + (unless kind + (setf kind (native-file-kind + (concatenate 'string dirname name)))) + (when kind + (case kind + (:directory + (when directories + (map-it name t))) + (:symlink + (if classify-symlinks + (let* ((tmpname (merge-pathnames + (parse-native-namestring + name nil physical :as-directory nil) + physical)) + (truename (query-file-system tmpname :truename nil))) + (if (or (not truename) + (or (pathname-name truename) (pathname-type truename))) + (when files + (funcall fun tmpname)) + (when directories + (map-it name t)))) + (when files + (map-it name nil)))) + (t + ;; Anything else parses as a file. + (when files + (map-it name nil))))))))))) + +;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION +;;; with all DIRECTORIES that match the directory portion of PATHSPEC. +(defun map-matching-directories (function pathspec) + (let* ((dir (pathname-directory pathspec)) + (length (length dir)) + (wild (position-if (lambda (elt) + (or (eq :wild elt) (typep elt 'pattern))) + dir)) + (wild-inferiors (position :wild-inferiors dir)) + (end (cond ((and wild wild-inferiors) + (min wild wild-inferiors)) + (t + (or wild wild-inferiors length)))) + (rest (subseq dir end)) + (starting-point (make-pathname :directory (subseq dir 0 end) + :device (pathname-device pathspec) + :host (pathname-host pathspec) + :name nil + :type nil + :version nil))) + (cond (wild-inferiors + (map-wild-inferiors function rest starting-point)) + (wild + (map-wild function rest starting-point)) + (t + ;; Nothing wild -- the directory matches itself. + (funcall function starting-point)))) + nil) + +(defun last-directory-piece (pathname) + (car (last (pathname-directory pathname)))) -(/show0 "filesys.lisp 844") +;;; Part of DIRECTORY: implements iterating over a :WILD or pattern component +;;; in the directory spec. +(defun map-wild (function more directory) + (let ((this (pop more)) + (next (car more))) + (flet ((cont (subdirectory) + (cond ((not more) + ;; end of the line + (funcall function subdirectory)) + ((or (eq :wild next) (typep next 'pattern)) + (map-wild function more subdirectory)) + ((eq :wild-inferiors next) + (map-wild-inferiors function more subdirectory)) + (t + (let ((this (pathname-directory subdirectory))) + (map-matching-directories + function + (make-pathname :directory (append this more) + :defaults subdirectory))))))) + (map-directory + (if (eq :wild this) + #'cont + (lambda (sub) + (when (pattern-matches this (last-directory-piece sub)) + (funcall #'cont sub)))) + directory + :files nil + :directories t + :errorp nil)))) -;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous -;;; lookups are cached in a hash table since groveling the passwd(s) -;;; files is somewhat expensive. The table may hold NIL for id's that -;;; cannot be looked up since this keeps the files from having to be -;;; searched in their entirety each time this id is translated. -(defun lookup-login-name (uid) - (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*) - (if foundp - login-name - (setf (gethash uid *uid-hash-table*) - (get-group-or-user-name :user uid))))) +;;; Part of DIRECTORY: implements iterating over a :WILD-INFERIORS component +;;; in the directory spec. +(defun map-wild-inferiors (function more directory) + (loop while (member (car more) '(:wild :wild-inferiors)) + do (pop more)) + (let ((next (car more)) + (rest (cdr more))) + (unless more + (funcall function directory)) + (map-directory + (cond ((not more) + (lambda (pathname) + (funcall function pathname) + (map-wild-inferiors function more pathname))) + (t + (lambda (pathname) + (let ((this (pathname-directory pathname))) + (when (equal next (car (last this))) + (map-matching-directories + function + (make-pathname :directory (append this rest) + :defaults pathname))) + (map-wild-inferiors function more pathname))))) + directory + :files nil + :directories t + :errorp nil))) -;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") -;;; since it is a much smaller file, contains all the local id's, and -;;; most uses probably involve id's on machines one would login into. -;;; Then if necessary, we look in "/etc/passwds" ("/etc/groups") which -;;; is really long and has to be fetched over the net. +;;; Part of DIRECTORY: implements iterating over entries in a directory, and +;;; matching them. +(defun map-matching-entries (function directory match-name match-type) + (map-directory + (lambda (file) + (when (and (funcall match-name (pathname-name file)) + (funcall match-type (pathname-type file))) + (funcall function file))) + directory + :files t + :directories :as-files + :errorp nil)) + +;;; NOTE: There is a fair amount of hair below that is probably not +;;; strictly necessary. ;;; -;;; FIXME: Now that we no longer have lookup-group-name, we no longer need -;;; the GROUP-OR-USER argument. -(defun get-group-or-user-name (group-or-user id) - #!+sb-doc - "Returns the simple-string user or group name of the user whose uid or gid - is id, or NIL if no such user or group exists. Group-or-user is either - :group or :user." - (let ((id-string (let ((*print-base* 10)) (prin1-to-string id)))) - (declare (simple-string id-string)) - (multiple-value-bind (file1 file2) - (ecase group-or-user - (:group (values "/etc/group" "/etc/groups")) - (:user (values "/etc/passwd" "/etc/passwd"))) - (or (get-group-or-user-name-aux id-string file1) - (get-group-or-user-name-aux id-string file2))))) +;;; The issue is the following: what does (DIRECTORY "SYS:*;") mean? +;;; Until 2004-01, SBCL's behaviour was unquestionably wrong, as it +;;; did not translate the logical pathname at all, but instead treated +;;; it as a physical one. Other Lisps seem to to treat this call as +;;; equivalent to (DIRECTORY (TRANSLATE-LOGICAL-PATHNAME "SYS:*;")), +;;; which is fine as far as it goes, but not very interesting, and +;;; arguably counterintuitive. (PATHNAME-MATCH-P "SYS:SRC;" "SYS:*;") +;;; is true, so why should "SYS:SRC;" not show up in the call to +;;; DIRECTORY? (assuming the physical pathname corresponding to it +;;; exists, of course). +;;; +;;; So, the interpretation that I am pushing is for all pathnames +;;; matching the input pathname to be queried. This means that we +;;; need to compute the intersection of the input pathname and the +;;; logical host FROM translations, and then translate the resulting +;;; pathname using the host to the TO translation; this treatment is +;;; recursively invoked until we get a physical pathname, whereupon +;;; our physical DIRECTORY implementation takes over. -;;; FIXME: Isn't there now a POSIX routine to parse the passwd file? -;;; getpwent? getpwuid? -(defun get-group-or-user-name-aux (id-string passwd-file) - (with-open-file (stream passwd-file) - (loop - (let ((entry (read-line stream nil))) - (unless entry (return nil)) - (let ((name-end (position #\: (the simple-string entry) - :test #'char=))) - (when name-end - (let ((id-start (position #\: (the simple-string entry) - :start (1+ name-end) :test #'char=))) - (when id-start - (incf id-start) - (let ((id-end (position #\: (the simple-string entry) - :start id-start :test #'char=))) - (when (and id-end - (string= id-string entry - :start2 id-start :end2 id-end)) - (return (subseq entry 0 name-end)))))))))))) - -(/show0 "filesys.lisp 899") +;;; FIXME: this is an incomplete implementation. It only works when +;;; both are logical pathnames (which is OK, because that's the only +;;; case when we call it), but there are other pitfalls as well: see +;;; the DIRECTORY-HELPER below for some, but others include a lack of +;;; pattern handling. + +;;; The above was written by CSR, I (RMK) believe. The argument that +;;; motivates the interpretation is faulty, however: PATHNAME-MATCH-P +;;; returns true for (PATHNAME-MATCH-P #P"/tmp/*/" #P"/tmp/../"), but +;;; the latter pathname is not in the result of DIRECTORY on the +;;; former. Indeed, if DIRECTORY were constrained to return the +;;; truename for every pathname for which PATHNAME-MATCH-P returned +;;; true and which denoted a filename that named an existing file, +;;; (DIRECTORY #P"/tmp/**/") would be required to list every file on a +;;; Unix system, since any file can be named as though it were "below" +;;; /tmp, given the dotdot entries. So I think the strongest +;;; "consistency" we can define between PATHNAME-MATCH-P and DIRECTORY +;;; is that PATHNAME-MATCH-P returns true of everything DIRECTORY +;;; returns, but not vice versa. + +;;; In any case, even if the motivation were sound, DIRECTORY on a +;;; wild logical pathname has no portable semantics. I see nothing in +;;; ANSI that requires implementations to support wild physical +;;; pathnames, and so there need not be any translation of a wild +;;; logical pathname to a phyiscal pathname. So a program that calls +;;; DIRECTORY on a wild logical pathname is doing something +;;; non-portable at best. And if the only sensible semantics for +;;; DIRECTORY on a wild logical pathname is something like the +;;; following, it would be just as well if it signaled an error, since +;;; a program can't possibly rely on the result of an intersection of +;;; user-defined translations with a file system probe. (Potentially +;;; useful kinds of "pathname" that might not support wildcards could +;;; include pathname hosts that model unqueryable namespaces like HTTP +;;; URIs, or that model namespaces that it's not convenient to +;;; investigate, such as the namespace of TCP ports that some network +;;; host listens on. I happen to think it a bad idea to try to +;;; shoehorn such namespaces into a pathnames system, but people +;;; sometimes claim to want pathnames for these things.) -- RMK +;;; 2007-12-31. -;;; predicate to order pathnames by; goes by name -(defun pathname-order (x y) - (let ((xn (%pathname-name x)) - (yn (%pathname-name y))) - (if (and xn yn) - (let ((res (string-lessp xn yn))) - (cond ((not res) nil) - ((= res (length (the simple-string xn))) t) - ((= res (length (the simple-string yn))) nil) - (t t))) - xn))) +(defun pathname-intersections (one two) + (aver (logical-pathname-p one)) + (aver (logical-pathname-p two)) + (labels + ((intersect-version (one two) + (aver (typep one '(or null (member :newest :wild :unspecific) + integer))) + (aver (typep two '(or null (member :newest :wild :unspecific) + integer))) + (cond + ((eq one :wild) two) + ((eq two :wild) one) + ((or (null one) (eq one :unspecific)) two) + ((or (null two) (eq two :unspecific)) one) + ((eql one two) one) + (t nil))) + (intersect-name/type (one two) + (aver (typep one '(or null (member :wild :unspecific) string))) + (aver (typep two '(or null (member :wild :unspecific) string))) + (cond + ((eq one :wild) two) + ((eq two :wild) one) + ((or (null one) (eq one :unspecific)) two) + ((or (null two) (eq two :unspecific)) one) + ((string= one two) one) + (t (return-from pathname-intersections nil)))) + (intersect-directory (one two) + (aver (typep one '(or null (member :wild :unspecific) list))) + (aver (typep two '(or null (member :wild :unspecific) list))) + (cond + ((eq one :wild) two) + ((eq two :wild) one) + ((or (null one) (eq one :unspecific)) two) + ((or (null two) (eq two :unspecific)) one) + (t (aver (eq (car one) (car two))) + (mapcar + (lambda (x) (cons (car one) x)) + (intersect-directory-helper (cdr one) (cdr two))))))) + (let ((version (intersect-version + (pathname-version one) (pathname-version two))) + (name (intersect-name/type + (pathname-name one) (pathname-name two))) + (type (intersect-name/type + (pathname-type one) (pathname-type two))) + (host (pathname-host one))) + (mapcar (lambda (d) + (make-pathname :host host :name name :type type + :version version :directory d)) + (intersect-directory + (pathname-directory one) (pathname-directory two)))))) + +;;; FIXME: written as its own function because I (CSR) don't +;;; understand it, so helping both debuggability and modularity. In +;;; case anyone is motivated to rewrite it, it returns a list of +;;; sublists representing the intersection of the two input directory +;;; paths (excluding the initial :ABSOLUTE or :RELATIVE). +;;; +;;; FIXME: Does not work with :UP or :BACK +;;; FIXME: Does not work with patterns +;;; +;;; FIXME: PFD suggests replacing this implementation with a DFA +;;; conversion of a NDFA. Find out (a) what this means and (b) if it +;;; turns out to be worth it. +(defun intersect-directory-helper (one two) + (flet ((simple-intersection (cone ctwo) + (cond + ((eq cone :wild) ctwo) + ((eq ctwo :wild) cone) + (t (aver (typep cone 'string)) + (aver (typep ctwo 'string)) + (if (string= cone ctwo) cone nil))))) + (macrolet + ((loop-possible-wild-inferiors-matches + (lower-bound bounding-sequence order) + (let ((index (gensym)) (g2 (gensym)) (g3 (gensym)) (l (gensym))) + `(let ((,l (length ,bounding-sequence))) + (loop for ,index from ,lower-bound to ,l + append (mapcar (lambda (,g2) + (append + (butlast ,bounding-sequence (- ,l ,index)) + ,g2)) + (mapcar + (lambda (,g3) + (append + (if (eq (car (nthcdr ,index ,bounding-sequence)) + :wild-inferiors) + '(:wild-inferiors) + nil) ,g3)) + (intersect-directory-helper + ,@(if order + `((nthcdr ,index one) (cdr two)) + `((cdr one) (nthcdr ,index two))))))))))) + (cond + ((and (eq (car one) :wild-inferiors) + (eq (car two) :wild-inferiors)) + (delete-duplicates + (append (mapcar (lambda (x) (cons :wild-inferiors x)) + (intersect-directory-helper (cdr one) (cdr two))) + (loop-possible-wild-inferiors-matches 2 one t) + (loop-possible-wild-inferiors-matches 2 two nil)) + :test 'equal)) + ((eq (car one) :wild-inferiors) + (delete-duplicates (loop-possible-wild-inferiors-matches 0 two nil) + :test 'equal)) + ((eq (car two) :wild-inferiors) + (delete-duplicates (loop-possible-wild-inferiors-matches 0 one t) + :test 'equal)) + ((and (null one) (null two)) (list nil)) + ((null one) nil) + ((null two) nil) + (t (and (simple-intersection (car one) (car two)) + (mapcar (lambda (x) (cons (simple-intersection + (car one) (car two)) x)) + (intersect-directory-helper (cdr one) (cdr two))))))))) + +(defun directory-pathname-p (pathname) + (and (pathnamep pathname) + (null (pathname-name pathname)) + (null (pathname-type pathname)))) + (defun ensure-directories-exist (pathspec &key verbose (mode #o777)) #!+sb-doc "Test whether the directories containing the specified file actually exist, and attempt to create them if they do not. The MODE argument is a CMUCL/SBCL-specific extension to control the Unix permission bits." - (let ((pathname (physicalize-pathname (pathname pathspec))) - (created-p nil)) + (let ((pathname (physicalize-pathname (merge-pathnames (pathname pathspec)))) + (created-p nil)) (when (wild-pathname-p pathname) (error 'simple-file-error - :format-control "bad place for a wild pathname" - :pathname pathspec)) - (enumerate-search-list (pathname pathname) - (let ((dir (pathname-directory pathname))) - (loop for i from 1 upto (length dir) - do (let ((newpath (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (subseq dir 0 i)))) - (unless (probe-file newpath) - (let ((namestring (namestring newpath))) - (when verbose - (format *standard-output* - "~&creating directory: ~A~%" - namestring)) - (sb!unix:unix-mkdir namestring mode) - (unless (probe-file namestring) - (error 'simple-file-error - :pathname pathspec - :format-control "can't create directory ~A" - :format-arguments (list namestring))) - (setf created-p t))))) - ;; Only the first path in a search-list is considered. - (return (values pathname created-p)))))) + :format-control "bad place for a wild pathname" + :pathname pathspec)) + (let* ((dir (pathname-directory pathname)) + (*default-pathname-defaults* + (make-pathname :directory dir :device (pathname-device pathname))) + (dev (pathname-device pathname))) + (loop for i from (case dev (:unc 3) (otherwise 2)) + upto (length dir) + do + (let* ((newpath (make-pathname + :host (pathname-host pathname) + :device dev + :directory (subseq dir 0 i))) + (probed (probe-file newpath))) + (unless (directory-pathname-p probed) + (let ((namestring (coerce (native-namestring newpath) + 'string))) + (when verbose + (format *standard-output* + "~&creating directory: ~A~%" + namestring)) + (sb!unix:unix-mkdir namestring mode) + (unless (directory-pathname-p (probe-file newpath)) + (restart-case + (error + 'simple-file-error + :pathname pathspec + :format-control + (if (and probed + (not (directory-pathname-p probed))) + "Can't create directory ~A,~ + ~%a file with the same name already exists." + "Can't create directory ~A") + :format-arguments (list namestring)) + (retry () + :report "Retry directory creation." + (ensure-directories-exist + pathspec + :verbose verbose :mode mode)) + (continue () + :report + "Continue as if directory creation was successful." + nil))) + (setf created-p t))))) + (values pathspec created-p)))) (/show0 "filesys.lisp 1000")