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

Wed May 6 10:56:58 PDT 2009

Oops, I mean CCL sometimes does, whereas SBCL
never does.  Sorry.
-- Dan

Dan Weinreb wrote:
> By the way, in case anyone cares, SBCL sometimes
> calls ensure-directories-exist implicitly, where CCL
> does not.  The language spec has nothing to say
> about it and I would have done it as CCL does.
> If you're porting from SBCL to CCL, you might
> have to add calls to ensure-directories-exist.
>
>
> Gary Byers wrote:
>> 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
>>>
>>>
>>>     
>> _______________________________________________
>> Openmcl-devel mailing list
>> Openmcl-devel at clozure.com
>> http://clozure.com/mailman/listinfo/openmcl-devel
>>   
> ------------------------------------------------------------------------
>
> _______________________________________________
> Openmcl-devel mailing list
> Openmcl-devel at clozure.com
> http://clozure.com/mailman/listinfo/openmcl-devel
>   
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20090506/de21ae8e/attachment.htm>