Changeset 11996

Timestamp:

May 3, 2009, 11:40:57 AM (11 years ago)

Author:

gb

Message:

Apply patch from
<​http://clozure.com/pipermail/openmcl-devel/2009-May/009292.html> (observe
PATHNAME-DEVICE in ENSURE-DIRECTORIES-EXIST, DIRECTORY.)

File:

• trunk/source/lib/pathnames.lisp (modified) (11 diffs)

trunk/source/lib/pathnames.lisp

@@ -230 +230 @@
   bits.  Portable programs should avoid using the :MODE keyword
   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)
       (error 'file-error
@@ -300 +302 @@
 ;Directory Traversing
 
-(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 (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil)))))
      (when ,dirent
        (unwind-protect
@@ -360 +367 @@
 ; for a * or *x*y
 (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))
         (when (and (or all (neq (%schar name 0) #\.))
@@ -367 +377 @@
                    (not (string= name ".."))
                    (%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))
             (setq result
@@ -375 +386 @@
 
 (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))
         (directories (getf keys :directories))
@@ -387 +399 @@
         sub dir-list ans)
     (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))
           (when (and (or all (neq (%schar sub 0) #\.))
@@ -403 +418 @@
                      (%file*= name type sub))
             (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
                       (let* ((std-sub (%path-std-quotes sub nil "/;:*")))
                         (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)))
               (push (if follow-links (or (probe-file ans) ans) ans) result))))))
@@ -420 +435 @@
         (do-dirs nil)
         (result nil)
+        (device (pathname-device path))
         (name (pathname-name path))
         (type (pathname-type path))
@@ -426 +442 @@
         (directory-pathnames (getf keys :directory-pathnames))
         (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
     (multiple-value-bind (next-dir next-wild next-rest) (%split-dir rest)
@@ -445 +461 @@
             (t (when (getf keys :directories)
                  (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))
                    (setq result (list (if follow-links (truename sub) sub))))))))
     ; 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))
         (when (and (or all (neq (%schar sub 0) #\.))
                    (not (string= sub "."))
                    (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))
                    (subdir (%str-cat subfile "/")))
@@ -462 +479 @@
               (when (and do-dirs (%file*= name type sub))
                 (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))
                   (push (if follow-links (truename ans) ans) result)))