(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")))
;;; 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
"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 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.
-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
check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 2" $? \
0 "(directory exists)"
+# DELETE-DIRECTORY
+use_test_subdirectory
+mkdir dont_delete_me
+touch me_neither
+mkdir simple_test_subdir1
+mkdir simple_test_subdir2
+mkdir -p deep/1/2/
+touch deep/a
+touch deep/b
+touch deep/1/c
+touch deep/1/d
+touch deep/1/2/e
+touch deep/1/2/f
+ln -s `pwd`/dont_delete_me deep/linky
+ln -s `pwd`/me_neither deep/1/another_linky
+
+run_sbcl --eval '(sb-ext:delete-directory "simple_test_subdir1")' \
+ --eval '(sb-ext:delete-directory "simple_test_subdir2/")' \
+ --eval '(sb-ext:delete-directory "deep" :recursive t)' \
+ --eval '(sb-ext:quit)'
+
+test -e simple_test_subdir1
+check_status_maybe_lose "delete-directory 1" $? \
+ 1 "deleted"
+
+test -e simple_test_subdir2
+check_status_maybe_lose "delete-directory 2" $? \
+ 1 "deleted"
+
+test -e deep
+check_status_maybe_lose "delete-directory 3" $? \
+ 1 "deleted"
+
+test -e dont_delete_me
+check_status_maybe_lose "delete-directory 4" $? \
+ 0 "didn't follow link"
+
+test -e me_neither
+check_status_maybe_lose "delete-directory 5" $? \
+ 0 "didn't follow link"
+
# success convention for script
exit $EXIT_TEST_WIN
projects / sbcl.git / commitdiff