X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=4c2c05355337c2afeec49b383242ce31d7ae2c33;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=2887bacb4a21910db7119f3b373d6c2ad072f642;hpb=ffb8ca7616d75c88aae8f0939a241260ffdec051;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 2887bac..4c2c053 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,6 +14,11 @@ ;;;; 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 ]]] @@ -29,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: ;;; @@ -41,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. @@ -52,9 +55,9 @@ #!+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) + (declare (type simple-string namestr) (type index start end)) - (let* ((result (make-string (- end start) :element-type 'base-char)) + (let* ((result (make-string (- end start) :element-type 'character)) (dst 0) (quoted nil)) (do ((src start (1+ src))) @@ -82,7 +85,7 @@ (/show0 "filesys.lisp 86") (defun maybe-make-pattern (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (if *ignore-wildcards* (subseq namestr start end) @@ -155,7 +158,7 @@ (/show0 "filesys.lisp 160") (defun extract-name-type-and-version (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (let* ((last-dot (position #\. namestr :start (1+ start) :end end :from-end t))) @@ -171,252 +174,6 @@ (/show0 "filesys.lisp 200") -;;; 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 parse-unix-namestring (namestr start end) - (declare (type simple-string namestr) - (type index start end)) - (setf namestr (coerce namestr 'simple-base-string)) - (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) - (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))) - - (when (stringp name) - (let ((position (position-if (lambda (char) - (or (char= char (code-char 0)) - (char= char #\/))) - name))) - (when position - (error 'namestring-parse-error - :complaint "can't embed #\\Nul or #\\/ in Unix namestring" - :namestring namestr - :offset position)))) - ;; Now we have everything we want. So return it. - (values nil ; no host for Unix namestrings - nil ; no device for Unix namestrings - (collect ((dirs)) - (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)) - ;; this host designator needs to be recognized as a physical host in - ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but - ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR, - ;; 2002-05-09 - "") - -(defun unparse-unix-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 - (collect ((strings)) - (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-base-string - (strings)))))) - -(defun unparse-unix-directory-list (directory) - (declare (type list directory)) - (collect ((pieces)) - (when directory - (ecase (pop directory) - (:absolute - (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 (member :wild)) - (pieces (unparse-unix-piece dir)) - (pieces "/")) - (t - (error "invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-base-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 - (when (and (null type) - (typep name 'string) - (> (length name) 0) - (position #\. name :start 1)) - (error "too many dots in the name: ~S" pathname)) - (when (and (typep name 'string) - (string= name "")) - (error "name is of length 0: ~S" pathname)) - (strings (unparse-unix-piece name))) - (when type-supplied - (unless name - (error "cannot specify the type without a file: ~S" pathname)) - (when (typep type 'simple-string) - (when (position #\. type) - (error "type component can't have a #\. inside: ~S" pathname))) - (strings ".") - (strings (unparse-unix-piece type)))) - (apply #'concatenate 'simple-base-string (strings)))) - -(/show0 "filesys.lisp 406") - -(defun unparse-unix-namestring (pathname) - (declare (type pathname pathname)) - (concatenate 'simple-base-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 ((null pathname-directory) '(:relative)) - ((eq (car pathname-directory) :relative) - pathname-directory) - ((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 - (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) - (strings (unparse-unix-directory-list result-directory))) - (let* ((pathname-type (%pathname-type pathname)) - (type-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)) - (when (and (null pathname-type) - (position #\. pathname-name :start 1)) - (error "too many dots in the name: ~S" pathname)) - (strings (unparse-unix-piece pathname-name))) - (when type-needed - (when (or (null pathname-type) (eq pathname-type :unspecific)) - (lose)) - (when (typep pathname-type 'simple-base-string) - (when (position #\. pathname-type) - (error "type component can't have a #\. inside: ~S" pathname))) - (strings ".") - (strings (unparse-unix-piece pathname-type)))) - (apply #'concatenate 'simple-string (strings))))) ;;;; wildcard matching stuff @@ -441,6 +198,10 @@ (/show0 "filesys.lisp 498") +;; TODO: the implementation !enumerate-matches is some hairy stuff +;; that we mostly don't need. Couldn't we use POSIX fts(3) to walk +;; the file system and PATHNAME-MATCH-P to select matches, at least on +;; Unices? (defmacro !enumerate-matches ((var pathname &optional result &key (verify-existence t) (follow-links t)) @@ -455,6 +216,15 @@ (/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) @@ -463,26 +233,31 @@ (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))) - (/noshow0 "computed DIRECTORY") - (if directory - (ecase (first directory) - (:absolute - (/noshow0 "absolute directory") - (%enumerate-directories "/" (rest directory) pathname - verify-existence follow-links - nil function)) - (:relative - (/noshow0 "relative directory") - (%enumerate-directories "" (rest directory) pathname - verify-existence follow-links - nil function))) - (%enumerate-files "" pathname verify-existence function)))) + (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) + 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) @@ -505,12 +280,14 @@ (let ((piece (car tail))) (etypecase piece (simple-string - (let ((head (concatenate 'base-string head piece))) + (let ((head (concatenate 'string head piece))) (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'base-string head "/") - (cdr tail) pathname - verify-existence follow-links - nodes function)))) + (%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 @@ -522,8 +299,8 @@ (%enumerate-directories head (rest tail) pathname verify-existence follow-links nodes function) - (dolist (name (ignore-errors (directory-lispy-filenames head))) - (let ((subdir (concatenate 'base-string head name))) + (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)) @@ -531,17 +308,19 @@ 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 'base-string subdir "/"))) + (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 'base-string head name))) + (let ((subdir (concatenate 'string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) @@ -549,26 +328,26 @@ (eql (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)) (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'base-string subdir "/"))) + (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 "/") + (when (string= head (host-unparse-directory-separator host)) (error 'simple-file-error :pathname pathname :format-control "~@")) (with-directory-node-removed (head) - (let ((head (concatenate 'base-string head ".."))) + (let ((head (concatenate 'string head ".."))) (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'base-string 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 "/")) + (aver (string= head (host-unparse-directory-separator host))) (error 'simple-file-error :pathname pathname :format-control "~@")))) @@ -584,7 +363,7 @@ (/noshow0 "computed NAME, TYPE, and VERSION") (cond ((member name '(nil :unspecific)) (/noshow0 "UNSPECIFIC, more or less") - (let ((directory (coerce directory 'base-string))) + (let ((directory (coerce directory 'string))) (when (or (not verify-existence) (sb!unix:unix-file-kind directory)) (funcall function directory)))) @@ -611,19 +390,19 @@ (components-match file-type type) (components-match file-version version)) (funcall function - (concatenate 'base-string + (concatenate 'string directory complete-filename)))))) (t (/noshow0 "default case") - (let ((file (concatenate 'base-string directory name))) + (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 'base-string file "." type))) + (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 'base-string file "." + (setf file (concatenate 'string file "." (quick-integer-to-string version)))) (/noshow0 "finished possibly tweaking FILE") (when (or (not verify-existence) @@ -680,6 +459,13 @@ ;;; 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. +;;; +;;; 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. +;;; +;;; 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 @@ -694,42 +480,202 @@ (1 (first matches)) (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) -;;;; TRUENAME and PROBE-FILE - -;;; This is only trivially different from PROBE-FILE, which is silly -;;; but ANSI. -(defun truename (pathname) - #!+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. +;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. - 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 +;;; 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 "The file ~S does not exist." - :format-arguments (list (namestring pathname)))) - result)) + :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)) + (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 (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)))))))) + -(defun probe-file (pathname) +(defun probe-file (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 (sb!unix:unix-simplify-pathname trueishname))) - (if (eq (sb!unix:unix-file-kind name) :directory) - (pathname (concatenate 'string name "/")) - (pathname name)))))))) + "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 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. + +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 @@ -776,40 +722,41 @@ (simple-file-perror "couldn't delete ~A" namestring err)))) t) +(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)))) + ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) - "Return the home directory of the user as a pathname." - (declare (ignore host)) - (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid)))) - -(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)))))) + "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." + (declare (ignore host)) + (let ((env-home (posix-getenv "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))) + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t)))) -(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 @@ -842,6 +789,41 @@ ;;; 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)) @@ -957,18 +939,19 @@ (car one) (car two)) x)) (intersect-directory-helper (cdr one) (cdr two))))))))) -(defun directory (pathname &key) +(defun directory (pathname &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." + 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)) + (filenames (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))) @@ -983,10 +966,12 @@ ;; 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))))) + (filename (if resolve-symlinks + (query-file-system match :truename nil) + (query-file-system match :existence nil)))) + (when filename + (setf (gethash (namestring filename) filenames) + filename))))) (do-directory (pathname) (if (logical-pathname-p pathname) (let ((host (intern-logical-host (pathname-host pathname)))) @@ -1003,15 +988,17 @@ ;; 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)) + (sort (loop for name being each hash-key in filenames + using (hash-value filename) + collect (cons name filename)) #'string< :key #'car)))) (/show0 "filesys.lisp 899") ;;; predicate to order pathnames by; goes by name +;; FIXME: Does anything use this? It's not exported, and I don't find +;; the name anywhere else. (defun pathname-order (x y) (let ((xn (%pathname-name x)) (yn (%pathname-name y))) @@ -1029,7 +1016,7 @@ 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))) + (let ((pathname (physicalize-pathname (merge-pathnames (pathname pathspec)))) (created-p nil)) (when (wild-pathname-p pathname) (error 'simple-file-error @@ -1042,24 +1029,30 @@ :device (pathname-device pathname) :directory (subseq dir 0 i)))) (unless (probe-file newpath) - (let ((namestring (coerce (namestring newpath) 'base-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 pathname created-p)))) + (values pathspec created-p)))) (/show0 "filesys.lisp 1000")