(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))
+ (declare (ignore ino nlink gid rdev size atime
+ #!+win32 uid))
(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 (sb!unix:uid-username uid))
+ (: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
(let* ((original (truename file))
(original-namestring (native-namestring original :as-file t))
(new-name (merge-pathnames new-name original))
- (new-namestring (native-namestring new-name :as-file t)))
+ (new-namestring (native-namestring (physicalize-pathname new-name)
+ :as-file t)))
(unless new-namestring
(error 'simple-file-error
:pathname new-name
(defun delete-file (file)
#!+sb-doc
- "Delete the specified FILE."
- (let* ((truename (probe-file file))
- (namestring (when truename
- (native-namestring truename :as-file t))))
+ "Delete the specified FILE.
+
+If FILE is a stream, on Windows the stream is closed immediately. On Unix
+plaforms the stream remains open, allowing IO to continue: the OS resources
+associated with the deleted file remain available till the stream is closed as
+per standard Unix unlink() behaviour."
+ (let* ((pathname (translate-logical-pathname file))
+ (namestring (native-namestring pathname :as-file t)))
+ (truename file) ; for error-checking side-effect
+ #!+win32
(when (streamp file)
- (close file :abort t))
- (unless namestring
- (error 'simple-file-error
- :pathname file
- :format-control "~S doesn't exist."
- :format-arguments (list file)))
+ (close file))
(multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
(unless res
(simple-file-perror "couldn't delete ~A" namestring err))))
t)
+
+(defun delete-directory (pathspec &key recursive)
+ "Deletes the directory designated by PATHSPEC (a pathname designator).
+Returns the truename of the directory deleted.
+
+If RECURSIVE is false \(the default), signals an error unless the directory is
+empty. If RECURSIVE is true, first deletes all files and subdirectories. If
+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.
+
+\(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.
+
+Experimental: interface subject to change."
+ (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))))))
\f
(defun sbcl-homedir-pathname ()
(let ((sbcl-home (posix-getenv "SBCL_HOME")))
*default-pathname-defaults*
:as-directory t))))
+(defun user-homedir-namestring (&optional username)
+ (if username
+ (sb!unix:user-homedir username)
+ (let ((env-home (posix-getenv "HOME")))
+ (if (and env-home (not (string= env-home "")))
+ env-home
+ #!-win32
+ (sb!unix:uid-homedir (sb!unix:unix-getuid))))))
+
;;; (This is an ANSI Common Lisp function.)
(defun user-homedir-pathname (&optional host)
#!+sb-doc
"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."
+system. HOST argument is ignored by SBCL."
(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))))
+ (values
+ (parse-native-namestring
+ (or (user-homedir-namestring)
+ #!+win32
+ (sb!win32::get-folder-namestring sb!win32::csidl_profile))
+ #!-win32 sb!impl::*unix-host*
+ #!+win32 sb!impl::*win32-host*
+ *default-pathname-defaults*
+ :as-directory t)))
\f
;;;; DIRECTORY
truename))))
(do-physical-pathnames (pathname)
(aver (not (logical-pathname-p pathname)))
- (let* ((name (pathname-name pathname))
+ (let* (;; KLUDGE: Since we don't canonize pathnames on construction,
+ ;; we really have to do it here to get #p"foo/." mean the same
+ ;; as #p"foo/./".
+ (pathname (canonicalize-pathname pathname))
+ (name (pathname-name pathname))
(type (pathname-type pathname))
- ;; KLUDGE: We want #p"/foo" to match #p"/foo/,
- ;; so cobble up a directory name component from
- ;; name and type -- just take care with "*.*"!
- (dirname (if (and (eq :wild name) (eq :wild type))
- "*"
- (with-output-to-string (s)
- (when name
- (write-string (unparse-physical-piece name) s))
- (when type
- (write-string "." s)
- (write-string (unparse-physical-piece type) s)))))
- (dir (maybe-make-pattern dirname 0 (length dirname)))
(match-name (make-matcher name))
- (match-type (make-matcher type))
- (match-dir (make-matcher dir)))
+ (match-type (make-matcher type)))
(map-matching-directories
(if (or name type)
(lambda (directory)
- (map-matching-files #'record
- directory
- match-name
- match-type
- match-dir))
+ (map-matching-entries #'record
+ directory
+ match-name
+ match-type))
#'record)
pathname)))
(do-pathnames (pathname)
#'string<
:key #'car))))
+(defun canonicalize-pathname (pathname)
+ ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP,
+ ;; and dealing with #p"foo/.." and #p"foo/."
+ (labels ((simplify (piece)
+ (unless (eq :unspecific piece)
+ piece))
+ (canonicalize-directory (directory)
+ (let (pieces)
+ (dolist (piece directory)
+ (if (and pieces (member piece '(:back :up)))
+ ;; FIXME: We should really canonicalize when we construct
+ ;; pathnames. This is just wrong.
+ (case (car pieces)
+ ((:absolute :wild-inferiors)
+ (error 'simple-file-error
+ :format-control "Invalid use of ~S after ~S."
+ :format-arguments (list piece (car pieces))
+ :pathname pathname))
+ ((:relative :up :back)
+ (push piece pieces))
+ (t
+ (pop pieces)))
+ (push piece pieces)))
+ (nreverse pieces))))
+ (let ((name (simplify (pathname-name pathname)))
+ (type (simplify (pathname-type pathname)))
+ (dir (canonicalize-directory (pathname-directory pathname))))
+ (cond ((equal "." name)
+ (cond ((not type)
+ (make-pathname :name nil :defaults pathname))
+ ((equal "" type)
+ (make-pathname :name nil
+ :type nil
+ :directory (butlast dir)
+ :defaults pathname))))
+ (t
+ (make-pathname :name name :type type
+ :directory dir
+ :defaults pathname))))))
+
;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style
;;; interface to mapping over namestrings of entries in the corresponding
;;; directory.
;;; This is our core directory access interface that we use to implement
;;; DIRECTORY.
-(defun map-directory (function directory &key (files t) (directories t) (errorp t))
+(defun map-directory (function directory &key (files t) (directories t)
+ (classify-symlinks) (errorp t))
#!+sb-doc
- "Call FUNCTION with the pathname for each entry in DIRECTORY as follows: if
-FILES is true (the default), FUNCTION is called for each file in the
-directory; if DIRECTORIES is true (the default), FUNCTION is called for each
-subdirectory. If ERRORP is true (the default) signal an error if DIRECTORY
-does not exist, cannot be read, etc.
+ "Map over entries in DIRECTORY. Keyword arguments specify which entries to
+map over, and how:
+
+ :FILES
+ If true, call FUNCTION with the pathname of each file in DIRECTORY.
+ Defaults to T.
-On platforms supporting symbolic links the decision to call FUNCTION with its
-pathname depends on the resolution of the link: if it points to a directory,
-it is considered a directory entry. Whether it is considered a file or a
-directory, the provided pathname is not fully resolved, but rather names the
-symbolic link as an immediate child of DIRECTORY.
+ :DIRECTORIES
+ If true, call FUNCTION with a pathname for each subdirectory of DIRECTORY.
+ If :AS-FILES, the pathname used is a pathname designating the subdirectory
+ as a file in DIRECTORY. Otherwise the pathname used is a directory
+ pathname. Defaults to T.
+
+ :CLASSIFY-SYMLINKS
+ If T, 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.
+
+ :ERRORP
+ If true, signal an error if DIRECTORY does not exist, cannot be read, etc.
+ Defaults to T.
Experimental: interface subject to change."
+ (declare (pathname-designator directory))
(let* ((fun (%coerce-callable-to-fun function))
- (realname (or (query-file-system directory :existence errorp)
- (return-from map-directory nil)))
- (host (pathname-host realname))
- ;; We want the trailing separator: better to ask the
- ;; provide it rather than reason about its presence here.
- (dirname (native-namestring realname :as-file nil)))
- (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
- (funcall fun (parse-native-namestring
- full host realname :as-directory t))))
- (:symlink
- (let* ((tmpname (parse-native-namestring
- full host realname :as-directory nil))
- (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
- (funcall fun (parse-native-namestring
- full host realname :as-directory t))))))
- (t
- ;; Anything else parses as a file.
- (when files
- (funcall fun (parse-native-namestring
- full host realname :as-directory nil)))))))))))
+ (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)))
+ (canonical (if realname
+ (parse-native-namestring realname
+ (pathname-host physical)
+ (sane-default-pathname-defaults)
+ :as-directory t)
+ (return-from map-directory nil)))
+ (dirname (native-namestring canonical)))
+ (flet ((map-it (name dirp)
+ (funcall fun
+ (merge-pathnames (parse-native-namestring
+ name nil 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))))
+ (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.
(map-wild function rest starting-point))
(t
;; Nothing wild -- the directory matches itself.
- (funcall function starting-point)))))
+ (funcall function starting-point))))
+ nil)
(defun last-directory-piece (pathname)
(car (last (pathname-directory pathname))))
;; end of the line
(funcall function subdirectory))
((or (eq :wild next) (typep next 'pattern))
- (lambda (pathname)
- (map-wild function more pathname)))
+ (map-wild function more subdirectory))
((eq :wild-inferiors next)
- (lambda (pathname)
- (map-wild-inferiors function more pathname)))
+ (map-wild-inferiors function more subdirectory))
(t
- (lambda (pathname)
- (let ((this (pathname-directory pathname)))
- (when (equal next (car (last this)))
- (map-matching-directories
- function
- (make-pathname :directory (append this more)
- :defaults pathname)))))))))
+ (let ((this (pathname-directory subdirectory)))
+ (map-matching-directories
+ function
+ (make-pathname :directory (append this more)
+ :defaults subdirectory)))))))
(map-directory
(if (eq :wild this)
#'cont
(lambda (sub)
- (awhen (pattern-matches this (last-directory-piece sub))
- (funcall #'cont it))))
+ (when (pattern-matches this (last-directory-piece sub))
+ (funcall #'cont sub))))
directory
:files nil
:directories t
:directories t
:errorp nil)))
-;;; Part of DIRECTORY: implements iterating over files in a directory, and matching
-;;; them.
-(defun map-matching-files (function directory match-name match-type match-dir)
+;;; Part of DIRECTORY: implements iterating over entries in a directory, and
+;;; matching them.
+(defun map-matching-entries (function directory match-name match-type)
(map-directory
(lambda (file)
- (let ((pname (pathname-name file))
- (ptype (pathname-type file)))
- (when (if (or pname ptype)
- (and (funcall match-name pname) (funcall match-type ptype))
- (funcall match-dir (last-directory-piece file)))
- (funcall function file))))
+ (when (and (funcall match-name (pathname-name file))
+ (funcall match-type (pathname-type file)))
+ (funcall function file)))
directory
:files t
- :directories t
+ :directories :as-files
:errorp nil))
;;; NOTE: There is a fair amount of hair below that is probably not
projects / sbcl.git / blobdiff