[Openmcl-devel] ENSURE-DIRECTORIES-EXIST and DIRECTORY on Windows
Gary Byers
gb at clozure.com
Sun May 3 03:03:34 PDT 2009
Yes, both of those functions were neglecting to handle
PATHNAME-DEVICE. D'oh!
Thanks.
On Sun, 3 May 2009, Martin wrote:
> Hi!
>
> First, I want to appreciate the work you have put into the Windows port
> of Clozure CL. Thanks.
>
> At the end of this mail is a patch which attempts to make CCL's
> DIRECTORY and ENSURE-DIRECTORIES-EXIST functions nicer on Windows.
>
> (I am using 1.3-r11949 on Windows XP SP2.)
>
> Most of the changes typically involve the addition of the :DEVICE
> component for to make the functions `drive aware'---if you will.
>
> For 1 and 2, the `context' is:
>
> ? (PATHNAME-DEVICE (CURRENT-DIRECTORY)) => C
>
>
>
> 1.
>
> ? (ENSURE-DIRECTORIES-EXIST "D:/dir1/dir2/") => creates "C:/dir1/dir2/"
> instead.
>
>
>
> 2.
>
> ? (DIRECTORY "D:/dir1/dir2/*.*") => NIL (despite having files in
> D:/dir1/dir2/).
>
>
>
> 3. I have a file tree with the following structure:
>
> D:.
> | init.bat
> |
> +---.dir2
> | | .file3
> | | file1.txt
> | | file2
> | |
> | +---.dir1-2
> | | .file5
> | | file3.txt
> | | file4
> | |
> | \---dir1-1
> | .file3
> | file1.txt
> | file2
> |
> \---dir1
> | .file3
> | file1.txt
> | file2
> |
> +---.dir1-2
> | .file5
> | file3.txt
> | file4
> |
> \---dir1-1
> .file3
> file1.txt
> file2
>
>
> ? (DIRECTORY #P"D:/sources/lang/lisp/ccl/tests/**/.dir2/" :directories t))
> =>
> '(#P"/sources/lang/lisp/ccl/tests/.dir2/"
> #P"/sources/lang/lisp/ccl/tests/.dir2/.dir2/"
> #P"/sources/lang/lisp/ccl/tests/.dir2/.dir1-2/.dir2/"
> #P"/sources/lang/lisp/ccl/tests/.dir2/dir1-1/.dir2/"
> #P"/sources/lang/lisp/ccl/tests/dir1/.dir2/"
> #P"/sources/lang/lisp/ccl/tests/dir1/.dir1-2/.dir2/"
> #P"/sources/lang/lisp/ccl/tests/dir1/dir1-1/.dir2/")
>
> If I understand the Spec well, I expected:
> #P"D:/sources/lang/lisp/ccl/tests/.dir2/"
>
> Regards,
> Martin.
>
>
> Patch: (In the expected format, I hope.)
>
> ;;; --------------------------------------------------
> ;;; BOF
>
>
>
> --- pathnames.orig.lisp
> +++ pathnames.new.lisp
> @@ -231,4 +231,6 @@
> argument."
> - (let* ((pathname (make-directory-pathname :directory
> (pathname-directory (translate-logical-pathname (merge-pathnames
> pathspec)))))
> - (created-p nil))
> + (let ((pathname (let ((pathspec (translate-logical-pathname
> (merge-pathnames pathspec))))
> + (make-directory-pathname :device (pathname-device pathspec)
> + :directory (pathname-directory pathspec))))
> + (created-p nil))
> (when (wild-pathname-p pathname)
> @@ -301,4 +303,9 @@
>
> -(defmacro with-open-dir ((dirent dir) &body body)
> - `(let ((,dirent (%open-dir ,dir)))
> +(defun %path-cat (device dir subdir)
> + (if device
> + (%str-cat device ":" dir subdir)
> + (%str-cat dir subdir)))
> +
> +(defmacro with-open-dir ((dirent device dir) &body body)
> + `(let ((,dirent (%open-dir (namestring (make-pathname :device ,device
> :directory ,dir)))))
> (when ,dirent
> @@ -361,4 +368,7 @@
> (defun %one-wild (dir wild rest path so-far keys)
> - (let ((result ()) (all (getf keys :all)) name subdir)
> - (with-open-dir (dirent dir)
> + (let ((result ())
> + (device (pathname-device path))
> + (all (getf keys :all))
> + name)
> + (with-open-dir (dirent device dir)
> (while (setq name (%read-dir dirent))
> @@ -368,4 +378,5 @@
> (%path-pstr*= wild name)
> - (eq (%unix-file-kind (setq subdir (%str-cat dir name)) t) :directory))
> - (let ((so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
> + (eq (%unix-file-kind (%path-cat device dir name) t) :directory))
> + (let ((subdir (%path-cat nil dir name))
> + (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
> (declare (dynamic-extent so-far))
> @@ -376,3 +387,4 @@
> (defun %files-in-directory (dir path so-far keys)
> - (let ((name (pathname-name path))
> + (let ((device (pathname-device path))
> + (name (pathname-name path))
> (type (pathname-type path))
> @@ -388,9 +400,12 @@
> (if (not (or name type))
> - (when directories
> - (setq ans (if directory-pathnames
> - (%cons-pathname (reverse so-far) nil nil)
> - (%cons-pathname (reverse (cdr so-far)) (car so-far) nil)))
> - (when (and ans (or (null test) (funcall test ans)))
> - (setq result (list ans))))
> - (with-open-dir (dirent dir)
> + (let (full-path)
> + (when (and directories
> + (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname
> (reverse so-far) nil nil nil device)))
> + t)
> + :directory))
> + (setq ans (if directory-pathnames full-path
> + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil
> device)))
> + (when (and ans (or (null test) (funcall test ans)))
> + (setq result (list ans)))))
> + (with-open-dir (dirent (pathname-device path) dir)
> (while (setq sub (%read-dir dirent))
> @@ -404,3 +419,3 @@
> (setq ans
> - (if (eq (%unix-file-kind (%str-cat dir sub) t) :directory)
> + (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
> (when directories
> @@ -408,7 +423,7 @@
> (if directory-pathnames
> - (%cons-pathname (reverse (cons std-sub so-far)) nil nil)
> - (%cons-pathname (or dir-list (setq dir-list (reverse so-far)))
> std-sub nil))))
> + (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device)
> + (%cons-pathname (or dir-list (setq dir-list (reverse so-far)))
> std-sub nil nil device))))
> (when files
> (multiple-value-bind (name type) (%std-name-and-type sub)
> - (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name
> type)))))
> + (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name
> type nil device)))))
> (when (and ans (or (null test) (funcall test ans)))
> @@ -421,2 +436,3 @@
> (result nil)
> + (device (pathname-device path))
> (name (pathname-name path))
> @@ -427,3 +443,3 @@
> (follow-links (getf keys :follow-links))
> - sub subfile dir-list ans)
> + sub dir-list ans)
> ;; First process the case that the ** stands for 0 components
> @@ -446,4 +462,4 @@
> (setq sub (if directory-pathnames
> - (%cons-pathname (setq dir-list (reverse so-far)) nil nil)
> - (%cons-pathname (reverse (cdr so-far)) (car so-far) nil)))
> + (%cons-pathname (setq dir-list (reverse so-far)) nil nil nil
> device)
> + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil
> device)))
> (when (or (null test) (funcall test sub))
> @@ -451,3 +467,3 @@
> ; now descend doing %all-dirs on dirs and collecting files & dirs
> if do-x is t
> - (with-open-dir (dirent dir)
> + (with-open-dir (dirent device dir)
> (while (setq sub (%read-dir dirent))
> @@ -456,4 +472,5 @@
> (not (string= sub "..")))
> - (if (eq (%unix-file-kind (setq subfile (%str-cat dir sub)) t)
> :directory)
> - (let* ((std-sub (%path-std-quotes sub nil "/;:*"))
> + (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
> + (let* ((subfile (%path-cat nil dir sub))
> + (std-sub (%path-std-quotes sub nil "/;:*"))
> (so-far (cons std-sub so-far))
> @@ -463,5 +480,5 @@
> (setq ans (if directory-pathnames
> - (%cons-pathname (reverse so-far) nil nil)
> + (%cons-pathname (reverse so-far) nil nil nil device)
> (%cons-pathname (or dir-list (setq dir-list (reverse (cdr
> so-far))))
> - std-sub nil)))
> + std-sub nil nil device)))
> (when (or (null test) (funcall test ans))
> @@ -471,3 +488,3 @@
> (multiple-value-bind (name type) (%std-name-and-type sub)
> - (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse
> so-far))) name type))
> + (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse
> so-far))) name type nil device))
> (when (or (null test) (funcall test ans))
>
>
>
> ;;; EOF
> ;;; --------------------------------------------------
>
>
>
> _______________________________________________
> Openmcl-devel mailing list
> Openmcl-devel at clozure.com
> http://clozure.com/mailman/listinfo/openmcl-devel
>
>
More information about the Openmcl-devel
mailing list