[Openmcl-devel] ENSURE-DIRECTORIES-EXIST and DIRECTORY on Windows

[Martin]

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
;;; --------------------------------------------------