;;; 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.
-(defun query-file-system (pathspec query-for enoent-errorp)
+(defun query-file-system (pathspec query-for)
(let ((pathname (translate-logical-pathname
(merge-pathnames
(pathname pathspec)
(declare (ignore ino nlink gid rdev size atime))
(if existsp
(case query-for
- (:truename (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
- (simple-file-perror "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)))
+ (: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
+ (simple-file-perror "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
;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*,
;; since PATHNAME may be a relative pathname.
(merge-pathnames
- (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
- (simple-file-perror "couldn't resolve ~A"
- filename errno)))
- (pathname-host pathname)
- (sane-default-pathname-defaults)
- :as-directory t)
+ (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
+ (simple-file-perror "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; return
- ;; NIL or error.
- (if (and (= errno sb!unix:enoent) (not enoent-errorp))
- nil
- (simple-file-perror
- (format nil "failed to find the ~A of ~~A" query-for)
- pathspec errno))))))))
+ ;; If we're still here, the file doesn't exist; error.
+ (simple-file-perror
+ (format nil "failed to find the ~A of ~~A" query-for)
+ pathspec errno)))))))
(defun probe-file (pathspec)
#!+sb-doc
- "Return the truename of PATHSPEC if such a file exists, the
-coercion of PATHSPEC to a pathname if PATHSPEC names a symlink
-that links to itself or to a file that doesn't exist, or NIL if
-errno is set to ENOENT after trying to stat(2) the file. An
-error of type FILE-ERROR is signaled if PATHSPEC is a wild
-pathname, or for any other circumstance where stat(2) fails."
- (query-file-system pathspec :truename nil))
-
+ "Return the truename of PATHSPEC if the truename can be found,
+or NIL otherwise. See TRUENAME for more information."
+ (handler-case (truename pathspec) (file-error () nil)))
(defun truename (pathspec)
#!+sb-doc
;; Note that eventually this routine might be different for streams
;; than for other pathname designators.
(if (streamp pathspec)
- (query-file-system pathspec :truename t)
- (query-file-system pathspec :truename t)))
+ (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 :write-date t))
+ (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 t))
+ (query-file-system pathspec :write-date))
\f
;;;; miscellaneous other operations
(simple-file-perror "couldn't delete ~A" namestring err))))
t)
\f
-(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 (and sbcl-home (not (string= sbcl-home "")))
- (parse-native-namestring
- (ensure-trailing-slash 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)
system."
(declare (ignore host))
(let ((env-home (posix-getenv "HOME")))
- (parse-native-namestring
- (ensure-trailing-slash
+ (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))))
+
\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))
(/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)))
: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))))
projects / sbcl.git / blobdiff