(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)))))
+ (declare (ignore ino nlink gid rdev size atime))
(if existsp
(case query-for
(:existence (nth-value
;; ... 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))
+ (: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
;; 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)
(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")))
(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)
;;; This is our core directory access interface that we use to implement
;;; DIRECTORY.
(defun map-directory (function directory &key (files t) (directories t)
- (classify-symlinks) (errorp t))
+ (classify-symlinks t) (errorp t))
#!+sb-doc
"Map over entries in DIRECTORY. Keyword arguments specify which entries to
map over, and how:
pathname. Defaults to T.
:CLASSIFY-SYMLINKS
- If T, the decision to call FUNCTION with the pathname of a symbolic link
+ If true, the decision to call FUNCTION with the pathname of a symbolic link
depends on the resolution of the link: if it points to a directory, it is
considered a directory entry, otherwise a file entry. If false, all
- symbolic links are considered file entries. Defaults to T. In both cases
- the pathname used for the symbolic link is not fully resolved, but names it
- as an immediate child of DIRECTORY.
+ symbolic links are considered file entries. In both cases the pathname used
+ for the symbolic link is not fully resolved, but names it as an immediate
+ child of DIRECTORY. Defaults to T.
:ERRORP
If true, signal an error if DIRECTORY does not exist, cannot be read, etc.
(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