Changeset 14051 for branches

Timestamp:

Jul 26, 2010, 6:08:10 PM (14 years ago)

Author:

gz

Message:

Pathname fixes from trunk (r13579, r13582)

Location:

branches/qres/ccl

Files:

• . (modified) (1 prop)
• level-1/l1-pathnames.lisp (modified) (1 diff)
• lib/pathnames.lisp (modified) (11 diffs)

branches/qres/ccl/level-1/l1-pathnames.lisp

@@ -388 +388 @@
   ;; case-insensitive version for hosts. 
   ;; In addition, host components do not support wildcards.
-  (or (eq path-host wild-host)
+  (or (null wild-host) (eq wild-host :wild)
+      (null path-host) (eq path-host :wild)
+      (eq path-host wild-host)
       (and (stringp path-host)
            (stringp wild-host)

branches/qres/ccl/lib/pathnames.lisp

@@ -314 +314 @@
          (close-dir ,dirent)))))
 
+(defun path-is-link (path)
+  "Returns T if PATH is a (hard or symbolic) link, NIL otherwise."
+  (eq (%unix-file-kind (native-translated-namestring path) t) :link))
+
+
+(defun %add-directory-result (path result follow-links)
+  (let* ((resolved (and follow-links (path-is-link path) (probe-file path))))
+    (if resolved
+      (push (namestring resolved) (cdr result)) ; may introduce duplicates.
+      (push (namestring path) (car result)))
+    path))
+
+(defun %make-directory-result ()
+  (cons nil nil))
+
+(defun %process-directory-result (result)
+  (dolist (resolved (cdr result) (mapcar #'parse-namestring (sort (car result)  #'string<)))
+    (pushnew resolved (car result) :test #'string=)))
+
+  
 (defun directory (path &key (directories nil) ;; include subdirectories
                             (files t)         ;; include files
@@ -342 +362 @@
     (assert (eq (car (pathname-directory path)) :absolute) ()
             "full-pathname returned relative path ~s??" path)
-    ;; return sorted in alphabetical order, target-Xload-level-0 depends
-    ;; on this.
-    (nreverse
-     (delete-duplicates (%directory "/" dir path '(:absolute) keys) :test #'equal))))
-
-(defun %directory (dir rest path so-far keys)
+    (%process-directory-result (%directory "/" dir path '(:absolute) keys (%make-directory-result)))))
+
+(defun %directory (dir rest path so-far keys result)
   (multiple-value-bind (sub-dir wild rest) (%split-dir rest)
-    (%some-specific dir sub-dir wild rest path so-far keys)))
-
-(defun %some-specific (dir sub-dir wild rest path so-far keys)
+    (%some-specific dir sub-dir wild rest path so-far keys result)))
+
+(defun %some-specific (dir sub-dir wild rest path so-far keys result)
   (let* ((start 1)
          (end (length sub-dir))
@@ -360 +377 @@
         (setq start (%i+ 1 pos))))
     (cond ((null wild)
-           (%files-in-directory full-dir path so-far keys))
+           (%files-in-directory full-dir path so-far keys result))
           ((string= wild "**")
-           (%all-directories full-dir rest path so-far keys))
-          (t (%one-wild full-dir wild rest path so-far keys)))))
+           (%all-directories full-dir rest path so-far keys result))
+          (t (%one-wild full-dir wild rest path so-far keys result)))))
 
 ; for a * or *x*y
-(defun %one-wild (dir wild rest path so-far keys)
-  (let ((result ())
-        (device (pathname-device path))
+(defun %one-wild (dir wild rest path so-far keys result)
+  (let ((device (pathname-device path))
         (all (getf keys :all))
         name)
@@ -381 +397 @@
                 (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
             (declare (dynamic-extent so-far))
-            (setq result
-                  (nconc (%directory (%str-cat subdir "/") rest path so-far keys) result))))))
+            (%directory (%str-cat subdir "/") rest path so-far keys result)
+))))
     result))
 
-(defun %files-in-directory (dir path so-far keys)
+(defun %files-in-directory (dir path so-far keys result)
   (let ((device (pathname-device path))
         (name (pathname-name path))
@@ -396 +412 @@
         (all (getf keys :all))
         (include-emacs-lockfiles (getf keys :include-emacs-lockfiles))
-        (result ())
         sub dir-list ans)
     (if (not (or name type))
@@ -407 +422 @@
                       (%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)))))
+            (%add-directory-result ans result follow-links))))
       (with-open-dir (dirent (pathname-device path) dir)
         (while (setq sub (%read-dir dirent))
@@ -428 +443 @@
                         (%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))))))
+              (%add-directory-result ans result follow-links))))))
     result))
 
-(defun %all-directories (dir rest path so-far keys)
+(defun %all-directories (dir rest path so-far keys result)
   (let ((do-files nil)
         (do-dirs nil)
-        (result nil)
         (device (pathname-device path))
         (name (pathname-name path))
@@ -451 +465 @@
         (multiple-value-setq (next-dir next-wild next-rest) (%split-dir rest)))
       (cond ((not (string= next-dir "/"))
-             (setq result
-                   (%some-specific dir next-dir next-wild next-rest path so-far keys)))
+             (%some-specific dir next-dir next-wild next-rest path so-far keys result))
             (next-wild
-             (setq result
-                   (%one-wild dir next-wild next-rest path so-far keys)))
+             (%one-wild dir next-wild next-rest path so-far keys result))
             ((or name type)
              (when (getf keys :files) (setq do-files t))
@@ -464 +476 @@
                              (%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 device dir)
+                   (%add-directory-result sub result follow-links))))))
+    ;; now descend doing %all-dirs on dirs and collecting files & dirs
+    ;; if do-x is t
+    (with-open-dir (dirent device (%path-std-quotes dir nil "*;:"))
       (while (setq sub (%read-dir dirent))
         (when (and (or all (neq (%schar sub 0) #\.))
@@ -475 +488 @@
                    (std-sub (%path-std-quotes sub nil "/;:*"))
                    (so-far (cons std-sub so-far))
-                   (subdir (%str-cat subfile "/")))
+                   (subdir (%str-cat subfile  "/")))
               (declare (dynamic-extent so-far))
               (when (and do-dirs (%file*= name type sub))
@@ -483 +496 @@
                                             std-sub nil nil device)))
                 (when (or (null test) (funcall test ans))
-                  (push (if follow-links (truename ans) ans) result)))
-              (setq result (nconc (%all-directories subdir rest path so-far keys) result)))
+                  (%add-directory-result ans result follow-links)))
+              (%all-directories subdir rest path so-far keys result))
             (when (and do-files (%file*= name type sub))
               (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 nil device))
                 (when (or (null test) (funcall test ans))
-                  (push (if follow-links (truename ans) ans) result))))))))
+                  (%add-directory-result ans result follow-links))))))))
     result))