Raymond Toy pushed to branch master at cmucl / cmucl Commits: e65f9f5c by Raymond Toy at 2025-12-17T07:04:10-08:00 Fix #457: delete-directory signals errors - - - - - 6034f935 by Raymond Toy at 2025-12-17T07:04:10-08:00 Merge branch 'issue-457-delete-directory-signals-errors' into 'master' Fix #457: delete-directory signals errors Closes #457 See merge request cmucl/cmucl!336 - - - - - 4 changed files: - src/code/exports.lisp - src/code/extensions.lisp - src/i18n/locale/cmucl.pot - tests/pathname.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1213,7 +1213,8 @@ "INVALID-FASL" "WITH-TEMPORARY-DIRECTORY" - "WITH-TEMPORARY-FILE") + "WITH-TEMPORARY-FILE" + "DELETE-DIRECTORY") ;; gencgc features #+gencgc (:export "GET-GC-ASSERTIONS" ===================================== src/code/extensions.lisp ===================================== @@ -673,9 +673,9 @@ (defun delete-directory (dirname &key recursive) _N"Delete the directory Dirname. If the Recursive is non-NIL, recursively delete the directory Dirname including all files and - subdirectories. Dirname must be a pathname to a directory. Any NAME - or TYPE components in Dirname are ignored." - (declare (type pathname dirname)) + subdirectories. Dirname must name a directory. Any NAME or TYPE + components in Dirname are ignored. A FILE-ERROR is signaled if any + directory cannot be deleted." (when recursive ;; Find all the files or directories in DIRNAME. (dolist (path (directory (merge-pathnames "*.*" dirname))) @@ -685,8 +685,15 @@ (delete-directory path :recursive t) (delete-file path)))) ;; Finally delete the directory. - (unix:unix-rmdir (namestring dirname)) - (values)) + (multiple-value-bind (ok errno) + (unix:unix-rmdir (namestring dirname)) + (unless ok + (error 'kernel:simple-file-error + :pathname dirname + :format-control (intl:gettext "Could not remove directory \"~A\": ~A.") + :format-arguments (list dirname + (unix:get-unix-error-msg errno)))) + ok)) ;;; WITH-TEMPORARY-DIRECTORY -- Public ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6011,8 +6011,13 @@ msgstr "" msgid "" "Delete the directory Dirname. If the Recursive is non-NIL,\n" " recursively delete the directory Dirname including all files and\n" -" subdirectories. Dirname must be a pathname to a directory. Any NAME\n" -" or TYPE components in Dirname are ignored." +" subdirectories. Dirname must name a directory. Any NAME or TYPE\n" +" components in Dirname are ignored. A FILE-ERROR is signaled if any\n" +" directory cannot be deleted." +msgstr "" + +#: src/code/extensions.lisp +msgid "Could not remove directory \"~A\": ~A." msgstr "" #: src/code/extensions.lisp ===================================== tests/pathname.lisp ===================================== @@ -144,14 +144,13 @@ (assert-equal dir-tilde dir-home)))) (define-test delete-directory - (let ((dir (ensure-directories-exist "tmp/a/b/c/"))) - ;; Verify that the directories were created. - (assert-equal "tmp/a/b/c/" - dir) - ;; Try to delete the directory. It should fail, which we verify - ;; by noting the directory listing is not empty. - (ext::delete-directory (pathname "tmp/")) - (assert-true (directory "tmp/")) - ;; Now recursively delete the directory. - (ext::delete-directory (pathname "tmp/") :recursive t) - (assert-false (directory "tmp/")))) + (:tag :issues) + (ext:with-temporary-directory (path) + (let ((dir (ensure-directories-exist (merge-pathnames "tmp/a/b/c/" path)))) + ;; Try to delete the directory. It should fail.. + (assert-error 'kernel:simple-file-error + (ext:delete-directory (merge-pathnames "tmp/" path))) + ;; Now recursively delete the directory. + (assert-true (ext:delete-directory (merge-pathnames "tmp/" path) + :recursive t)) + (assert-false (directory "tmp/"))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/7ebc26546b69498a94f8c55... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/7ebc26546b69498a94f8c55... You're receiving this email because of your account on gitlab.common-lisp.net.