X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=aba52a6bdbf65533e594f978d68e232e1de0cde8;hb=16f861fd9d7c9246a22a212c26d97fb2e3712607;hp=53ff874e234af3edfcf5cdd02669f3b11ce02394;hpb=a757a48ad4a4531894203461ba5fb626a3ffc511;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 53ff874..aba52a6 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -80,80 +80,127 @@ :offset (1- end))) (%shrink-vector result dst))) -(defvar *ignore-wildcards* nil) - -(/show0 "filesys.lisp 86") - (defun maybe-make-pattern (namestr start end) (declare (type simple-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 (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)))))) + (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)))))) + +(defun unparse-physical-piece (thing) + (etypecase thing + ((member :wild) "*") + (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 + (with-output-to-string (s) + (dolist (piece (pattern-pieces thing)) + (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 - (make-pattern (pattern))))))) + (error "invalid pattern piece: ~S" piece)))))))))) + +(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))))) (/show0 "filesys.lisp 160") @@ -175,346 +222,222 @@ (/show0 "filesys.lisp 200") -;;;; 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") - -(defmacro !enumerate-matches ((var pathname &optional result - &key (verify-existence t) - (follow-links t)) - &body body) - `(block nil - (%enumerate-matches (pathname ,pathname) - ,verify-existence - ,follow-links - (lambda (,var) ,@body)) - ,result)) - -(/show0 "filesys.lisp 500") - -;;; Call FUNCTION on matches. -;;; -;;; KLUDGE: this assumes that an absolute pathname is indicated to the -;;; operating system by having a directory separator as the first -;;; character in the directory part. This is true for Win32 pathnames -;;; and for Unix pathnames, but it isn't true for LispM pathnames (and -;;; their bastard offspring, logical pathnames. Also it assumes that -;;; Unix pathnames have an empty or :unspecific device, and that -;;; windows drive letters are the only kinds of non-empty/:UNSPECIFIC -;;; devices. -(defun %enumerate-matches (pathname verify-existence follow-links function) - (/noshow0 "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 ((host (pathname-host pathname)) - (device (pathname-device pathname)) - (directory (pathname-directory pathname))) - (/noshow0 "computed HOST and DIRECTORY") - (let* ((dirstring (if directory - (ecase (first directory) - (:absolute (host-unparse-directory-separator host)) - (:relative "")) - "")) - (devstring (if (and device (not (eq device :unspecific))) - (concatenate 'simple-string (string device) (string #\:)) - "")) - (headstring (concatenate 'simple-string devstring dirstring))) - (if directory - (%enumerate-directories headstring (rest directory) pathname - verify-existence follow-links nil function) - (%enumerate-files headstring pathname verify-existence function))))) - -;;; Call FUNCTION on directories. -(defun %enumerate-directories (head tail pathname verify-existence - follow-links nodes function - &aux (host (pathname-host pathname))) - (declare (simple-string head)) - #!+win32 - (setf follow-links nil) - (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)))) - (with-directory-node-removed ((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 (remove (cons dev ino) nodes :test #'equal))) - ,@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 - (host-unparse-directory-separator host)) - (cdr tail) pathname - verify-existence follow-links - nodes function)))) - ((member :wild-inferiors) - ;; now with extra error case handling from CLHS - ;; 19.2.2.4.3 -- CSR, 2004-01-24 - (when (member (cadr tail) '(:up :back)) - (error 'simple-file-error - :pathname pathname - :format-control "~@." - :format-arguments (list (cadr tail)))) - (%enumerate-directories head (rest tail) pathname - verify-existence follow-links - nodes function) - (dolist (name (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) - #!+win32 ;; KLUDGE - (not (zerop ino)) - (eql (cdr dir) ino)) - (return t))) - (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'string subdir (host-unparse-directory-separator host)))) - (%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 (host-unparse-directory-separator host)))) - (%enumerate-directories subdir (rest tail) pathname - verify-existence follow-links - nodes function)))))))) - ((member :up) - (when (string= head (host-unparse-directory-separator host)) - (error 'simple-file-error - :pathname pathname - :format-control "~@")) - (with-directory-node-removed (head) - (let ((head (concatenate 'string head ".."))) - (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'string head (host-unparse-directory-separator host)) - (rest tail) pathname - verify-existence follow-links - nodes function))))) - ((member :back) - ;; :WILD-INFERIORS is handled above, so the only case here - ;; should be (:ABSOLUTE :BACK) - (aver (string= head (host-unparse-directory-separator host))) - (error 'simple-file-error - :pathname pathname - :format-control "~@")))) - (%enumerate-files head pathname verify-existence function)))) - -;;; Call FUNCTION on files. -(defun %enumerate-files (directory pathname verify-existence function) - (declare (simple-string directory)) - (/noshow0 "entering %ENUMERATE-FILES") - (let ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (version (%pathname-version pathname))) - (/noshow0 "computed NAME, TYPE, and VERSION") - (cond ((member name '(nil :unspecific)) - (/noshow0 "UNSPECIFIC, more or less") - (let ((directory (coerce directory 'string))) - (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)) - (/noshow0 "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 - (/noshow0 "default case") - (let ((file (concatenate 'string directory name))) - (/noshow "computed basic FILE") - (unless (or (null type) (eq type :unspecific)) - (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case") - (setf file (concatenate 'string file "." type))) - (unless (member version '(nil :newest :wild :unspecific)) - (/noshow0 "tweaking FILE for more-or-less-:WILD case") - (setf file (concatenate 'string file "." - (quick-integer-to-string version)))) - (/noshow0 "finished possibly tweaking FILE") - (when (or (not verify-existence) - (sb!unix:unix-file-kind file t)) - (/noshow0 "calling FUNCTION on FILE") - (funcall function file))))))) - -(/noshow0 "filesys.lisp 603") - -;;; 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-base-string "-" - (the simple-base-string (quick-integer-to-string (- n))))) - (t - (do* ((len (1+ (truncate (integer-length n) 3))) - (res (make-string len :element-type 'base-char)) - (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)))))) +;;;; 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)))))) -;;;; UNIX-NAMESTRING - -(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.) - )) - -;;; Convert PATHNAME into a string that can be used with UNIX system -;;; calls, or return NIL if no match is found. Wild-cards are expanded. +;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. + +;;; 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: ;;; -;;; FIXME: apart from the error checking (for wildness and for -;;; existence) and conversion to physical pathanme, this is redundant -;;; with UNPARSE-NATIVE-UNIX-NAMESTRING; one should probably be -;;; written in terms of the other. +;;; * 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. ;;; -;;; FIXME: actually this (I think) works not just for Unix. -(defun unix-namestring (pathname-spec &optional (for-input t)) - (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec))) - (matches nil)) ; an accumulator for actual matches - (when (wild-pathname-p namestring) +;;; 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 namestring - :format-control "bad place for a wild pathname")) - (!enumerate-matches (match namestring nil :verify-existence for-input) - (push match matches)) - (case (length matches) - (0 nil) - (1 (first matches)) - (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) - -;;;; TRUENAME and PROBE-FILE + :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))) + (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 + #!+win32 uid)) + (if existsp + (case query-for + (:existence (nth-value + 0 + (parse-native-namestring + filename + (pathname-host pathname) + (sane-default-pathname-defaults) + :as-directory (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)))) + (:truename (nth-value + 0 + (parse-native-namestring + ;; 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... + (multiple-value-bind (realpath errno) + (sb!unix:unix-realpath filename) + (if realpath + realpath + (fail "couldn't resolve ~A" filename errno))) + (pathname-host pathname) + (sane-default-pathname-defaults) + ;; ... but without any trailing slash. + :as-directory (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)))) + (:author + #!-win32 + (sb!unix:uid-username uid)) + (:write-date (+ unix-to-universal-time mtime))) + (progn + ;; 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. + #!-win32 + (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)) + linkp) + (return-from query-file-system + (case query-for + (:existence + ;; We do this reparse so as to return a + ;; normalized pathname. + (parse-native-namestring + filename (pathname-host pathname))) + (: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 + (nth-value + 0 + (parse-native-namestring + (multiple-value-bind (realpath errno) + (sb!unix:unix-realpath + (native-namestring + (make-pathname + :name :unspecific + :type :unspecific + :version :unspecific + :defaults (parse-native-namestring + filename + (pathname-host pathname) + (sane-default-pathname-defaults))))) + (if realpath + realpath + (fail "couldn't resolve ~A" filename errno))) + (pathname-host pathname) + (sane-default-pathname-defaults) + :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)))))))) + -;;; This is only trivially different from PROBE-FILE, which is silly -;;; but ANSI. -(defun truename (pathname) +(defun probe-file (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." - (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 truename of PATHSPEC if the truename can be found, +or NIL otherwise. See TRUENAME for more information." + (query-file-system pathspec :truename nil)) -(defun probe-file (pathname) +(defun truename (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." - (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) - (name (simplify-namestring - trueishname - (pathname-host defaulted-pathname)))) - (if (eq (sb!unix:unix-file-kind name) :directory) - ;; FIXME: this might work, but it's ugly. - (pathname (concatenate 'string name "/")) - (pathname name)))))))) + "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. + +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. + +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))) + +(defun file-author (pathspec) + #!+sb-doc + "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)) + +(defun file-write-date (pathspec) + #!+sb-doc + "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 @@ -525,9 +448,9 @@ otherwise. An error of type FILE-ERROR is signaled if pathname is wild." "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)) + (original-namestring (native-namestring original :as-file t)) (new-name (merge-pathnames new-name original)) - (new-namestring (unix-namestring new-name nil))) + (new-namestring (native-namestring new-name :as-file t))) (unless new-namestring (error 'simple-file-error :pathname new-name @@ -548,7 +471,9 @@ otherwise. An error of type FILE-ERROR is signaled if pathname is wild." (defun delete-file (file) #!+sb-doc "Delete the specified FILE." - (let ((namestring (unix-namestring file t))) + (let* ((truename (probe-file file)) + (namestring (when truename + (native-namestring truename :as-file t)))) (when (streamp file) (close file :abort t)) (unless namestring @@ -561,20 +486,15 @@ otherwise. An error of type FILE-ERROR is signaled if pathname is wild." (simple-file-perror "couldn't delete ~A" namestring err)))) t) -(defun ensure-trailing-slash (string) - (let ((last-char (char string (1- (length string))))) - (if (or (eql last-char #\/) - #!+win32 - (eql last-char #\\)) - string - (concatenate 'string string "/")))) - (defun sbcl-homedir-pathname () (let ((sbcl-home (posix-getenv "SBCL_HOME"))) ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores - (when sbcl-home - (parse-native-namestring - (ensure-trailing-slash sbcl-home))))) + (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)))) ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) @@ -585,50 +505,357 @@ is returned; otherwise obtains the home directory from the operating system." (declare (ignore host)) (let ((env-home (posix-getenv "HOME"))) - (parse-native-namestring - (ensure-trailing-slash - (if (and env-home - (not (equal env-home ""))) + (values + (parse-native-namestring + (if (and env-home (not (string= env-home ""))) env-home #!-win32 (sb!unix:uid-homedir (sb!unix:unix-getuid)) #!+win32 ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH + ;; What?! -- RMK, 2007-12-31 (return-from user-homedir-pathname - (sb!win32::get-folder-pathname sb!win32::csidl_profile))))))) + (sb!win32::get-folder-pathname sb!win32::csidl_profile))) + #!-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" - (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 file-author (file) - #!+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." - (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)) - (and winp (sb!unix:uid-username uid))))) ;;;; DIRECTORY -(/show0 "filesys.lisp 800") +(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. 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)) + ;; KLUDGE: We want #p"/foo" to match #p"/foo/, + ;; so cobble up a directory name component from + ;; name and type -- just take care with "*.*"! + (dirname (if (and (eq :wild name) (eq :wild type)) + "*" + (with-output-to-string (s) + (when name + (write-string (unparse-physical-piece name) s)) + (when type + (write-string "." s) + (write-string (unparse-physical-piece type) s))))) + (dir (maybe-make-pattern dirname 0 (length dirname))) + (match-name (make-matcher name)) + (match-type (make-matcher type)) + (match-dir (make-matcher dir))) + (map-matching-directories + (if (or name type) + (lambda (directory) + (map-matching-files #'record + directory + match-name + match-type + match-dir)) + #'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) + (if (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))) + (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))) + (call-with-native-directory-iterator #'iterate ,namestring ,errorp)))) + +(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) (errorp t)) + #!+sb-doc + "Call FUNCTION with the pathname for each entry in DIRECTORY as follows: if +FILES is true (the default), FUNCTION is called for each file in the +directory; if DIRECTORIES is true (the default), FUNCTION is called for each +subdirectory. If ERRORP is true (the default) signal an error if DIRECTORY +does not exist, cannot be read, etc. + +On platforms supporting symbolic links the decision to call FUNCTION with its +pathname depends on the resolution of the link: if it points to a directory, +it is considered a directory entry. Whether it is considered a file or a +directory, the provided pathname is not fully resolved, but rather names the +symbolic link as an immediate child of DIRECTORY. + +Experimental: interface subject to change." + (let* ((fun (%coerce-callable-to-fun function)) + (physical (physicalize-pathname directory)) + ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows + ;; network shares. + (realname (sb!unix:unix-realpath (native-namestring physical :as-file t))) + (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 dirp) + physical)))) + (with-native-directory-iterator (next dirname :errorp errorp) + (loop for name = (next) + while name + do (let* ((full (concatenate 'string dirname name)) + (kind (native-file-kind full))) + (when kind + (case kind + (:directory + (when directories + (map-it name t))) + (:symlink + (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))))) + (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)))) + +;;; 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)) + (lambda (pathname) + (map-wild function more pathname))) + ((eq :wild-inferiors next) + (lambda (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 more) + :defaults pathname))))))))) + (map-directory + (if (eq :wild this) + #'cont + (lambda (sub) + (awhen (pattern-matches this (last-directory-piece sub)) + (funcall #'cont it)))) + directory + :files nil + :directories t + :errorp nil)))) + +;;; 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))) + +;;; Part of DIRECTORY: implements iterating over files in a directory, and matching +;;; them. +(defun map-matching-files (function directory match-name match-type match-dir) + (map-directory + (lambda (file) + (let ((pname (pathname-name file)) + (ptype (pathname-type file))) + (when (if (or pname ptype) + (and (funcall match-name pname) (funcall match-type ptype)) + (funcall match-dir (last-directory-piece file))) + (funcall function file)))) + directory + :files t + :directories t + :errorp nil)) ;;; NOTE: There is a fair amount of hair below that is probably not ;;; strictly necessary. @@ -657,6 +884,41 @@ system." ;;; 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. + (defun pathname-intersections (one two) (aver (logical-pathname-p one)) (aver (logical-pathname-p two)) @@ -771,72 +1033,6 @@ system." (mapcar (lambda (x) (cons (simple-intersection (car one) (car two)) x)) (intersect-directory-helper (cdr one) (cdr two))))))))) - -(defun directory (pathname &key) - #!+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 (;; 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)) - ;; FIXME: Possibly this MERGE-PATHNAMES call should only - ;; happen once we get a physical pathname. - (merged-pathname (merge-pathnames pathname))) - (labels ((do-physical-directory (pathname) - (aver (not (logical-pathname-p pathname))) - (!enumerate-matches (match pathname) - (let* ((*ignore-wildcards* t) - ;; FIXME: Why 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 - (truename (probe-file match))) - (when truename - (setf (gethash (namestring truename) truenames) - truename))))) - (do-directory (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-directory (translate-pathname p from to))))))) - (do-physical-directory pathname)))) - (do-directory merged-pathname)) - (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 name being each hash-key in truenames - using (hash-value truename) - collect (cons name truename)) - #'string< - :key #'car)))) - -(/show0 "filesys.lisp 899") - -;;; 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 ensure-directories-exist (pathspec &key verbose (mode #o777)) #!+sb-doc @@ -857,22 +1053,28 @@ system." :device (pathname-device pathname) :directory (subseq dir 0 i)))) (unless (probe-file newpath) - (let ((namestring (coerce (namestring newpath) 'string))) + (let ((namestring (coerce (native-namestring newpath) + 'string))) (when verbose (format *standard-output* "~&creating directory: ~A~%" namestring)) (sb!unix:unix-mkdir namestring mode) - (unless (probe-file namestring) - (restart-case (error 'simple-file-error - :pathname pathspec - :format-control "can't create directory ~A" - :format-arguments (list namestring)) + (unless (probe-file newpath) + (restart-case (error + 'simple-file-error + :pathname pathspec + :format-control + "can't create directory ~A" + :format-arguments (list namestring)) (retry () :report "Retry directory creation." - (ensure-directories-exist pathspec :verbose verbose :mode mode)) + (ensure-directories-exist + pathspec + :verbose verbose :mode mode)) (continue () - :report "Continue as if directory creation was successful." + :report + "Continue as if directory creation was successful." nil))) (setf created-p t))))) (values pathspec created-p))))