The branch "master" has been updated in SBCL:
via d269194b61cad24590c75fe2df7d9237a668668c (commit)
from b7a594e50e4da48ee230c148d2410881e7ed4a7c (commit)
- Log -----------------------------------------------------------------
commit d269194b61cad24590c75fe2df7d9237a668668c
Author: Stas Boukarev <stassats@...>
Date: Fri Mar 9 00:13:49 2012 +0400
ensure-directories-exist: Signal an error when trying to create a
directory with the same name as an existing file.
Previously (ensure-directories-exist "/foo/bar/"), where /foo/bar is a
regular file, just silently returned "/foo/bar/", NIL.
---
src/code/filesys.lisp | 71 +++++++++++++++++++++++++++++--------------------
1 files changed, 42 insertions(+), 29 deletions(-)
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index d01a738..4543713 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -1118,6 +1118,12 @@ Experimental: interface subject to change."
(car one) (car two)) x))
(intersect-directory-helper (cdr one) (cdr two)))))))))
+
+(defun directory-pathname-p (pathname)
+ (and (pathnamep pathname)
+ (null (pathname-name pathname))
+ (null (pathname-type pathname))))
+
(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
#!+sb-doc
"Test whether the directories containing the specified file
@@ -1132,35 +1138,42 @@ Experimental: interface subject to change."
:pathname pathspec))
(let ((dir (pathname-directory pathname)))
(loop for i from 1 upto (length dir)
- do (let ((newpath (make-pathname
- :host (pathname-host pathname)
- :device (pathname-device pathname)
- :directory (subseq dir 0 i))))
- (unless (probe-file newpath)
- (let ((namestring (coerce (native-namestring newpath)
- 'string)))
- (when verbose
- (format *standard-output*
- "~&creating directory: ~A~%"
- namestring))
- (sb!unix:unix-mkdir namestring mode)
- (unless (probe-file newpath)
- (restart-case (error
- 'simple-file-error
- :pathname pathspec
- :format-control
- "can't create directory ~A"
- :format-arguments (list namestring))
- (retry ()
- :report "Retry directory creation."
- (ensure-directories-exist
- pathspec
- :verbose verbose :mode mode))
- (continue ()
- :report
- "Continue as if directory creation was successful."
- nil)))
- (setf created-p t)))))
+ do
+ (let* ((newpath (make-pathname
+ :host (pathname-host pathname)
+ :device (pathname-device pathname)
+ :directory (subseq dir 0 i)))
+ (probed (probe-file newpath)))
+ (unless (directory-pathname-p probed)
+ (let ((namestring (coerce (native-namestring newpath)
+ 'string)))
+ (when verbose
+ (format *standard-output*
+ "~&creating directory: ~A~%"
+ namestring))
+ (sb!unix:unix-mkdir namestring mode)
+ (unless (directory-pathname-p (probe-file newpath))
+ (restart-case
+ (error
+ 'simple-file-error
+ :pathname pathspec
+ :format-control
+ (if (and probed
+ (not (directory-pathname-p probed)))
+ "Can't create directory ~A,~
+ ~%a file with the same name already exists."
+ "Can't create directory ~A")
+ :format-arguments (list namestring))
+ (retry ()
+ :report "Retry directory creation."
+ (ensure-directories-exist
+ pathspec
+ :verbose verbose :mode mode))
+ (continue ()
+ :report
+ "Continue as if directory creation was successful."
+ nil)))
+ (setf created-p t)))))
(values pathspec created-p))))
(/show0 "filesys.lisp 1000")
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|