-;;;; 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.
\f
;;;; 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 ]]]
;;; - 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:
;;;
;;; 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.
#!+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)))
(/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)
:complaint "#\\[ with no corresponding #\\]"
:namestring namestr
:offset index))
- (pattern (list :character-set
+ (pattern (cons :character-set
(subseq namestr
(1+ index)
close-bracket)))
(/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)))
(/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)))))
\f
;;;; wildcard matching stuff
(/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))
(/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)
(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)
(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
(%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))
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))
(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 "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
(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 "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))
(/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))))
(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)
;;; 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
(1 (first matches))
(t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname")))))
\f
-;;;; 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 "~@<can't find the ~A of wild pathname ~A~
+ (physicalized from ~A).~:>"
+ :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))
\f
;;;; miscellaneous other operations
(simple-file-perror "couldn't delete ~A" namestring err))))
t)
\f
+(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)))))
\f
;;;; DIRECTORY
;;; 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))
(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)))
;; 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))))
;; 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))))
\f
(/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)))
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
: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")
projects / sbcl.git / blobdiff