X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=1d2e11b81a5ad76e233b7734417eacf39a8e63a7;hb=9fd95117be995b9e15a19aa182fafe4a489a4ac7;hp=04e6503e4bb75717157c9777d376de654a79f4bf;hpb=8a632c14b592472873cfb214239c9387bc1a1ced;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 04e6503..1d2e11b 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -504,7 +504,7 @@ ;;; 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) @@ -522,22 +522,24 @@ (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 @@ -577,47 +579,41 @@ ;; 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 @@ -637,22 +633,22 @@ 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 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)) ;;;; miscellaneous other operations @@ -699,20 +695,15 @@ or if PATHSPEC is a wild pathname." (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 (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) @@ -723,16 +714,22 @@ 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 + (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)))) + ;;;; DIRECTORY @@ -765,6 +762,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)) @@ -935,6 +967,8 @@ system." (/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))) @@ -965,22 +999,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))))