(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
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))
+ (let* ((pathname (translate-logical-pathname
+ (merge-pathnames file (sane-default-pathname-defaults))))
(namestring (native-namestring pathname :as-file t)))
- (truename file) ; for error-checking side-effect
#!+win32
(when (streamp file)
(close file))
(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."
+ (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
;;; 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 t) (errorp t))
#!+sb-doc
"Map over entries in DIRECTORY. Keyword arguments specify which entries to
map over, and how:
as a file in DIRECTORY. Otherwise the pathname used is a directory
pathname. Defaults to T.
+ :CLASSIFY-SYMLINKS
+ 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. 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.
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.
-
Experimental: interface subject to change."
(declare (pathname-designator directory))
(let* ((fun (%coerce-callable-to-fun function))
(when directories
(map-it name t)))
(:symlink
- (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)))))
+ (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
((or (null one) (eq one :unspecific)) two)
((or (null two) (eq two :unspecific)) one)
((string= one two) one)
- (t nil)))
+ (t (return-from pathname-intersections nil))))
(intersect-directory (one two)
(aver (typep one '(or null (member :wild :unspecific) list)))
(aver (typep two '(or null (member :wild :unspecific) list)))
projects / sbcl.git / blobdiff