From ec0e9da75fd4ca7206df53854c4ab74713b1ef05 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 15 Oct 2010 10:16:48 +0000 Subject: [PATCH] 1.0.43.62: implement SB-EXT:DELETE-DIRECTORY Extend MAP-DIRECTORY with :CLASSIFY-SYMLINKS so implementing "delete symlinks but don't follow them" behaviour for :RECURSIVE T is nice and easy. --- NEWS | 1 + doc/manual/beyond-ansi.texinfo | 1 + package-data-list.lisp-expr | 1 + src/code/filesys.lisp | 86 +++++++++++++++++++++++++++++++--------- tests/filesys.test.sh | 41 +++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 113 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 0775db5..7d7c01f 100644 --- a/NEWS +++ b/NEWS @@ -14,6 +14,7 @@ changes relative to sbcl-1.0.43: * enhancement: the system detects known type-erros in calls better, signalling a full warning about violated proclaimed FTYPEs and violations of derived FTYPEs within the same file, including self-calls. + * enhancement: new function: SB-EXT:DELETE-DIRECTORY is now provided. * optimization: constant-folding exploits numeric and character types, in addition member types. * optimization: numeric, character and member types that are inhabited by diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index e2858f6..83197f6 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -408,6 +408,7 @@ arguments to @code{make-hash-table}. @section Miscellaneous Extensions @include fun-sb-ext-array-storage-vector.texinfo +@include fun-sb-ext-delete-directory.texinfo @include fun-sb-ext-get-time-of-day.texinfo @include fun-sb-ext-seed-random-state.texinfo diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 9d51a31..13ec91b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -762,6 +762,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "SEED-RANDOM-STATE" "TYPEXPAND-1" "TYPEXPAND" "TYPEXPAND-ALL" "DEFINED-TYPE-NAME-P" "VALID-TYPE-SPECIFIER-P" + "DELETE-DIRECTORY" ;; stepping interface "STEP-CONDITION" "STEP-FORM-CONDITION" "STEP-FINISHED-CONDITION" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index cd62fa6..a0d844e 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -487,6 +487,50 @@ per standard Unix unlink() behaviour." (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)))))) (defun sbcl-homedir-pathname () (let ((sbcl-home (posix-getenv "SBCL_HOME"))) @@ -676,7 +720,8 @@ matching filenames." ;;; 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: @@ -691,16 +736,18 @@ 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)) @@ -733,17 +780,20 @@ Experimental: interface subject to change." (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 diff --git a/tests/filesys.test.sh b/tests/filesys.test.sh index 0d69b36..6840181 100644 --- a/tests/filesys.test.sh +++ b/tests/filesys.test.sh @@ -257,5 +257,46 @@ test -d foo?bar 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 diff --git a/version.lisp-expr b/version.lisp-expr index 7341f52..148ae33 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.43.61" +"1.0.43.62" -- 1.7.10.4