(simple-file-perror note-format pathname errno)
(return-from query-file-system nil))))
(let ((filename (native-namestring pathname :as-file t)))
+ #!+win32
+ (case query-for
+ ((:existence :truename)
+ (multiple-value-bind (file kind)
+ (sb!win32::native-probe-file-name filename)
+ (when (and (not file) kind)
+ (setf file filename))
+ ;; The following OR was an AND, but that breaks files like NUL,
+ ;; for which GetLongPathName succeeds yet GetFileAttributesEx
+ ;; fails to return the file kind. --DFL
+ (if (or file kind)
+ (values
+ (parse-native-namestring
+ file
+ (pathname-host pathname)
+ (sane-default-pathname-defaults)
+ :as-directory (eq :directory kind)))
+ (fail "couldn't resolve ~A" filename
+ (- (sb!win32:get-last-error))))))
+ (:write-date
+ (or (sb!win32::native-file-write-date filename)
+ (fail "couldn't query write date of ~A" filename
+ (- (sb!win32:get-last-error))))))
+ #!-win32
(multiple-value-bind (existsp errno ino mode nlink uid gid rdev size
atime mtime)
(sb!unix:unix-stat filename)
- (declare (ignore ino nlink gid rdev size atime
- #!+win32 uid))
- #!+win32
- ;; On win32, stat regards UNC pathnames and device names as
- ;; nonexisting, so we check once more with the native API.
- (unless existsp
- (setf existsp
- (let ((handle (sb!win32:create-file
- filename 0 0 nil
- sb!win32:file-open-existing
- 0 0)))
- (when (/= -1 handle)
- (setf mode
- (or mode
- (if (logbitp 4
- (sb!win32:get-file-attributes filename))
- sb!unix:s-ifdir 0)))
- (progn (sb!win32:close-handle handle) t)))))
- (if existsp
- (case query-for
- (:existence (nth-value
- 0
- (parse-native-namestring
- filename
- (pathname-host pathname)
- (sane-default-pathname-defaults)
- :as-directory (eql (logand mode sb!unix:s-ifmt)
- sb!unix:s-ifdir))))
- (:truename (nth-value
- 0
- (parse-native-namestring
- ;; Note: in case the file is stat'able, POSIX
- ;; realpath(3) gets us a canonical absolute
- ;; filename, even if the post-merge PATHNAME
- ;; is not absolute...
- (multiple-value-bind (realpath errno)
- (sb!unix:unix-realpath filename)
- (if realpath
- realpath
- (fail "couldn't resolve ~A" filename errno)))
- (pathname-host pathname)
- (sane-default-pathname-defaults)
- ;; ... but without any trailing slash.
- :as-directory (eql (logand mode sb!unix:s-ifmt)
- sb!unix:s-ifdir))))
- (:author
- #!-win32
- (sb!unix:uid-username uid))
- (:write-date (+ unix-to-universal-time mtime)))
- (progn
- ;; SBCL has for many years had a policy that a pathname
- ;; that names an existing, dangling or self-referential
- ;; symlink denotes the symlink itself. stat(2) fails
- ;; and sets errno to ENOENT or ELOOP respectively, but
- ;; we must distinguish cases where the symlink exists
- ;; from ones where there's a loop in the apparent
- ;; containing directory.
- #!-win32
- (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev
- size atime mtime)
- (sb!unix:unix-lstat filename)
- (declare (ignore ignore ino mode nlink gid rdev size atime))
- (when (and (or (= errno sb!unix:enoent)
- (= errno sb!unix:eloop))
- linkp)
- (return-from query-file-system
- (case query-for
- (:existence
- ;; We do this reparse so as to return a
- ;; normalized pathname.
- (parse-native-namestring
- filename (pathname-host pathname)))
- (:truename
- ;; So here's a trick: since lstat succeded,
- ;; FILENAME exists, so its directory exists and
- ;; only the non-directory part is loopy. So
- ;; let's resolve FILENAME's directory part with
- ;; realpath(3), in order to get a canonical
- ;; absolute name for the directory, and then
- ;; return a pathname having PATHNAME's name,
- ;; type, and version, but the rest from the
- ;; truename of the directory. Since we turned
- ;; PATHNAME into FILENAME "as a file", FILENAME
- ;; does not end in a slash, and so we get the
- ;; directory part of FILENAME by reparsing
- ;; FILENAME and masking off its name, type, and
- ;; version bits. But note not to call ourselves
- ;; recursively, because we don't want to
- ;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*,
- ;; since PATHNAME may be a relative pathname.
- (merge-pathnames
- (nth-value
- 0
- (parse-native-namestring
- (multiple-value-bind (realpath errno)
- (sb!unix:unix-realpath
- (native-namestring
- (make-pathname
- :name :unspecific
- :type :unspecific
- :version :unspecific
- :defaults (parse-native-namestring
- filename
- (pathname-host pathname)
- (sane-default-pathname-defaults)))))
- (if realpath
- realpath
- (fail "couldn't resolve ~A" filename errno)))
- (pathname-host pathname)
- (sane-default-pathname-defaults)
- :as-directory t))
- pathname))
- (:author (sb!unix:uid-username uid))
- (:write-date (+ unix-to-universal-time mtime))))))
- ;; If we're still here, the file doesn't exist; error.
- (fail
- (format nil "failed to find the ~A of ~~A" query-for)
- pathspec errno))))))))
+ (declare (ignore ino nlink gid rdev size atime))
+ (labels ((parse (filename &key (as-directory
+ (eql (logand mode
+ sb!unix:s-ifmt)
+ sb!unix:s-ifdir)))
+ (values
+ (parse-native-namestring
+ filename
+ (pathname-host pathname)
+ (sane-default-pathname-defaults)
+ :as-directory as-directory)))
+ (resolve-problematic-symlink (&optional realpath-failed)
+ ;; 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.
+ ;; Also handles symlinks in /proc/pid/fd/ to
+ ;; pipes or sockets on Linux
+ (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)
+ realpath-failed)
+ linkp)
+ (return-from query-file-system
+ (case query-for
+ (:existence
+ ;; We do this reparse so as to return a
+ ;; normalized pathname.
+ (parse filename :as-directory nil))
+ (: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
+ (parse
+ (multiple-value-bind (realpath errno)
+ (sb!unix:unix-realpath
+ (native-namestring
+ (make-pathname
+ :name :unspecific
+ :type :unspecific
+ :version :unspecific
+ :defaults (parse filename
+ :as-directory nil))))
+ (or realpath
+ (fail "couldn't resolve ~A" filename errno)))
+ :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)))
+ (if existsp
+ (case query-for
+ (:existence (parse filename))
+ (:truename
+ ;; 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
+ (parse (or (sb!unix:unix-realpath filename)
+ (resolve-problematic-symlink t))))
+ (:author (sb!unix:uid-username uid))
+ (:write-date (+ unix-to-universal-time mtime)))
+ (resolve-problematic-symlink))))))))
(defun probe-file (pathspec)
(defun rename-file (file new-name)
#!+sb-doc
"Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a
- file, then the associated file is renamed."
- (let* ((original (truename file))
- (original-namestring (native-namestring original :as-file t))
+file, then the associated file is renamed."
+ (let* ((original (merge-pathnames file (sane-default-pathname-defaults)))
+ (old-truename (truename original))
+ (original-namestring (native-namestring (physicalize-pathname original)
+ :as-file t))
(new-name (merge-pathnames new-name original))
(new-namestring (native-namestring (physicalize-pathname new-name)
:as-file t)))
:format-arguments (list original new-name (strerror error))))
(when (streamp file)
(file-name file new-name))
- (values new-name original (truename new-name)))))
+ (values new-name old-truename (truename new-name)))))
(defun delete-file (file)
#!+sb-doc
#!+win32
(when (streamp file)
(close file))
- (multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
- (unless res
- (simple-file-perror "couldn't delete ~A" namestring err))))
+ (multiple-value-bind (res err)
+ #!-win32 (sb!unix:unix-unlink namestring)
+ #!+win32 (or (sb!win32::native-delete-file namestring)
+ (values nil (- (sb!win32:get-last-error))))
+ (unless res
+ (simple-file-perror "couldn't delete ~A" namestring err))))
t)
+(defun directorize-pathname (pathname)
+ (if (or (pathname-name pathname)
+ (pathname-type pathname))
+ (make-pathname :directory (append (pathname-directory pathname)
+ (list (file-namestring pathname)))
+ :host (pathname-host pathname)
+ :device (pathname-device pathname))
+ pathname))
+
(defun delete-directory (pathspec &key recursive)
"Deletes the directory designated by PATHSPEC (a pathname designator).
Returns the truename of the directory deleted.
RECURSIVE is true and the directory contains symbolic links, the links are
deleted, not the files and directories they point to.
-Signals an error if PATHSPEC designates a file instead of a directory, or if
-the directory could not be deleted for any reason.
+Signals an error if PATHSPEC designates a file or a symbolic link instead of a
+directory, or if the directory could not be deleted for any reason.
+
+Both
+
+ \(DELETE-DIRECTORY \"/tmp/foo\")
+ \(DELETE-DIRECTORY \"/tmp/foo/\")
-\(DELETE-DIRECTORY \"/tmp/foo\") and \(DELETE-DIRECTORY \"/tmp/foo/\") both
delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not
-exist or is a file."
+exist or if is a file or a symbolic link."
(declare (type pathname-designator pathspec))
- (with-pathname (pathname pathspec)
- (let ((truename (truename (translate-logical-pathname pathname))))
- (labels ((recurse (dir)
- (map-directory #'recurse dir
- :files nil
- :directories t
- :classify-symlinks nil)
- (map-directory #'delete-file dir
- :files t
- :directories nil
- :classify-symlinks nil)
- (delete-dir dir))
- (delete-dir (dir)
- (let* ((namestring (native-namestring dir :as-file t))
- (res (alien-funcall (extern-alien #!-win32 "rmdir"
- #!+win32 "_rmdir"
- (function int c-string))
- namestring)))
- (if (minusp res)
- (simple-file-perror "Could not delete directory ~A:~% ~A"
- namestring (get-errno))
- dir))))
- (if recursive
- (recurse truename)
- (delete-dir truename))))))
+ (let ((physical (directorize-pathname
+ (physicalize-pathname
+ (merge-pathnames
+ pathspec (sane-default-pathname-defaults))))))
+ (labels ((recurse-merged (dir)
+ (lambda (sub)
+ (recurse (merge-pathnames sub dir))))
+ (delete-merged (dir)
+ (lambda (file)
+ (delete-file (merge-pathnames file dir))))
+ (recurse (dir)
+ (map-directory (recurse-merged dir) dir
+ :files nil
+ :directories t
+ :classify-symlinks nil)
+ (map-directory (delete-merged dir) dir
+ :files t
+ :directories nil
+ :classify-symlinks nil)
+ (delete-dir dir))
+ (delete-dir (dir)
+ (let ((namestring (native-namestring dir :as-file t)))
+ (multiple-value-bind (res errno)
+ #!+win32
+ (or (sb!win32::native-delete-directory namestring)
+ (values nil (- (sb!win32:get-last-error))))
+ #!-win32
+ (values
+ (not (minusp (alien-funcall
+ (extern-alien "rmdir"
+ (function int c-string))
+ namestring)))
+ (get-errno))
+ (if res
+ dir
+ (simple-file-perror
+ "Could not delete directory ~A"
+ namestring errno))))))
+ (if recursive
+ (recurse physical)
+ (delete-dir physical)))))
+
\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*
+ *physical-host*
*default-pathname-defaults*
:as-directory t))))
(or (user-homedir-namestring)
#!+win32
(sb!win32::get-folder-namestring sb!win32::csidl_profile))
- #!-win32 sb!impl::*unix-host*
- #!+win32 sb!impl::*win32-host*
+ *physical-host*
*default-pathname-defaults*
:as-directory t)))
(canonicalize-directory (directory)
(let (pieces)
(dolist (piece directory)
- (if (and pieces (member piece '(:back :up)))
+ (cond
+ ((and pieces (member piece '(:back :up)))
;; FIXME: We should really canonicalize when we construct
;; pathnames. This is just wrong.
(case (car pieces)
((:relative :up :back)
(push piece pieces))
(t
- (pop pieces)))
- (push piece pieces)))
+ (pop pieces))))
+ ((equal piece ".")
+ ;; This case only really matters on Windows,
+ ;; because on POSIX, our call site (TRUENAME via
+ ;; QUERY-FILE-SYSTEM) only passes in pathnames from
+ ;; realpath(3), in which /./ has been removed
+ ;; already. Windows, however, depends on us to
+ ;; perform this fixup. -- DFL
+ )
+ (t
+ (push piece pieces))))
(nreverse pieces))))
(let ((name (simplify (pathname-name pathname)))
(type (simplify (pathname-type pathname)))
(macrolet ((,iterator ()
`(funcall ,',one-iter)))
,@body)))
+ #!+win32
+ (sb!win32::native-call-with-directory-iterator
+ #'iterate ,namestring ,errorp)
+ #!-win32
(call-with-native-directory-iterator #'iterate ,namestring ,errorp))))
(defun call-with-native-directory-iterator (function namestring errorp)
(let* ((fun (%coerce-callable-to-fun function))
(as-files (eq :as-files directories))
(physical (physicalize-pathname directory))
- ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows
- ;; network shares.
- (realname (sb!unix:unix-realpath (native-namestring physical :as-file t)))
+ (realname (query-file-system physical :existence nil))
(canonical (if realname
(parse-native-namestring realname
(pathname-host physical)
:as-directory (and dirp (not as-files)))
physical))))
(with-native-directory-iterator (next dirname :errorp errorp)
- (loop for name = (next)
- while name
- do (let* ((full (concatenate 'string dirname name))
- (kind (native-file-kind full)))
- (when kind
- (case kind
- (:directory
- (when directories
- (map-it name t)))
- (:symlink
- (if classify-symlinks
- (let* ((tmpname (merge-pathnames
- (parse-native-namestring
- name nil physical :as-directory nil)
- physical))
- (truename (query-file-system tmpname :truename nil)))
- (if (or (not truename)
- (or (pathname-name truename) (pathname-type truename)))
- (when files
- (funcall fun tmpname))
- (when directories
- (map-it name t))))
+ (loop
+ ;; provision for FindFirstFileExW-based iterator that should be used
+ ;; on Windows: file kind is known instantly there, so we'll have it
+ ;; returned by (next) soon.
+ (multiple-value-bind (name kind) (next)
+ (unless (or name kind) (return))
+ (unless kind
+ (setf kind (native-file-kind
+ (concatenate 'string dirname name))))
+ (when kind
+ (case kind
+ (:directory
+ (when directories
+ (map-it name t)))
+ (:symlink
+ (if classify-symlinks
+ (let* ((tmpname (merge-pathnames
+ (parse-native-namestring
+ name nil physical :as-directory nil)
+ physical))
+ (truename (query-file-system tmpname :truename nil)))
+ (if (or (not truename)
+ (or (pathname-name truename) (pathname-type truename)))
(when files
- (map-it name nil))))
- (t
- ;; Anything else parses as a file.
- (when files
- (map-it name nil)))))))))))
+ (funcall fun tmpname))
+ (when directories
+ (map-it name t))))
+ (when files
+ (map-it name nil))))
+ (t
+ ;; Anything else parses as a file.
+ (when files
+ (map-it name nil)))))))))))
;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION
;;; with all DIRECTORIES that match the directory portion of PATHSPEC.
(car one) (car two)) x))
(intersect-directory-helper (cdr one) (cdr two)))))))))
\f
+
+(defun directory-pathname-p (pathname)
+ (and (pathnamep pathname)
+ (null (pathname-name pathname))
+ (null (pathname-type pathname))))
+
(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
#!+sb-doc
"Test whether the directories containing the specified file
(error 'simple-file-error
:format-control "bad place for a wild pathname"
:pathname pathspec))
- (let ((dir (pathname-directory pathname)))
- (loop for i from 1 upto (length dir)
- do (let ((newpath (make-pathname
- :host (pathname-host pathname)
- :device (pathname-device pathname)
- :directory (subseq dir 0 i))))
- (unless (probe-file newpath)
- (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 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))
- (continue ()
- :report
- "Continue as if directory creation was successful."
- nil)))
- (setf created-p t)))))
+ (let* ((dir (pathname-directory pathname))
+ (*default-pathname-defaults*
+ (make-pathname :directory dir :device (pathname-device pathname)))
+ (dev (pathname-device pathname)))
+ (loop for i from (case dev (:unc 3) (otherwise 2))
+ upto (length dir)
+ do
+ (let* ((newpath (make-pathname
+ :host (pathname-host pathname)
+ :device dev
+ :directory (subseq dir 0 i)))
+ (probed (probe-file newpath)))
+ (unless (directory-pathname-p probed)
+ (let ((namestring (coerce (native-namestring newpath)
+ 'string)))
+ (when verbose
+ (format *standard-output*
+ "~&creating directory: ~A~%"
+ namestring))
+ (sb!unix:unix-mkdir namestring mode)
+ (unless (directory-pathname-p (probe-file newpath))
+ (restart-case
+ (error
+ 'simple-file-error
+ :pathname pathspec
+ :format-control
+ (if (and probed
+ (not (directory-pathname-p probed)))
+ "Can't create directory ~A,~
+ ~%a file with the same name already exists."
+ "Can't create directory ~A")
+ :format-arguments (list namestring))
+ (retry ()
+ :report "Retry directory creation."
+ (ensure-directories-exist
+ pathspec
+ :verbose verbose :mode mode))
+ (continue ()
+ :report
+ "Continue as if directory creation was successful."
+ nil)))
+ (setf created-p t)))))
(values pathspec created-p))))
(/show0 "filesys.lisp 1000")
projects / sbcl.git / blobdiff