Ignore:
Timestamp:
Jul 27, 2010, 1:08:10 AM (9 years ago)
Author:
gz
Message:

Pathname fixes from trunk (r13579, r13582)

Location:
branches/qres/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/lib/pathnames.lisp

    r13070 r14051  
    314314         (close-dir ,dirent)))))
    315315
     316(defun path-is-link (path)
     317  "Returns T if PATH is a (hard or symbolic) link, NIL otherwise."
     318  (eq (%unix-file-kind (native-translated-namestring path) t) :link))
     319
     320
     321(defun %add-directory-result (path result follow-links)
     322  (let* ((resolved (and follow-links (path-is-link path) (probe-file path))))
     323    (if resolved
     324      (push (namestring resolved) (cdr result)) ; may introduce duplicates.
     325      (push (namestring path) (car result)))
     326    path))
     327
     328(defun %make-directory-result ()
     329  (cons nil nil))
     330
     331(defun %process-directory-result (result)
     332  (dolist (resolved (cdr result) (mapcar #'parse-namestring (sort (car result)  #'string<)))
     333    (pushnew resolved (car result) :test #'string=)))
     334
     335 
    316336(defun directory (path &key (directories nil) ;; include subdirectories
    317337                            (files t)         ;; include files
     
    342362    (assert (eq (car (pathname-directory path)) :absolute) ()
    343363            "full-pathname returned relative path ~s??" path)
    344     ;; return sorted in alphabetical order, target-Xload-level-0 depends
    345     ;; on this.
    346     (nreverse
    347      (delete-duplicates (%directory "/" dir path '(:absolute) keys) :test #'equal))))
    348 
    349 (defun %directory (dir rest path so-far keys)
     364    (%process-directory-result (%directory "/" dir path '(:absolute) keys (%make-directory-result)))))
     365
     366(defun %directory (dir rest path so-far keys result)
    350367  (multiple-value-bind (sub-dir wild rest) (%split-dir rest)
    351     (%some-specific dir sub-dir wild rest path so-far keys)))
    352 
    353 (defun %some-specific (dir sub-dir wild rest path so-far keys)
     368    (%some-specific dir sub-dir wild rest path so-far keys result)))
     369
     370(defun %some-specific (dir sub-dir wild rest path so-far keys result)
    354371  (let* ((start 1)
    355372         (end (length sub-dir))
     
    360377        (setq start (%i+ 1 pos))))
    361378    (cond ((null wild)
    362            (%files-in-directory full-dir path so-far keys))
     379           (%files-in-directory full-dir path so-far keys result))
    363380          ((string= wild "**")
    364            (%all-directories full-dir rest path so-far keys))
    365           (t (%one-wild full-dir wild rest path so-far keys)))))
     381           (%all-directories full-dir rest path so-far keys result))
     382          (t (%one-wild full-dir wild rest path so-far keys result)))))
    366383
    367384; for a * or *x*y
    368 (defun %one-wild (dir wild rest path so-far keys)
    369   (let ((result ())
    370         (device (pathname-device path))
     385(defun %one-wild (dir wild rest path so-far keys result)
     386  (let ((device (pathname-device path))
    371387        (all (getf keys :all))
    372388        name)
     
    381397                (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
    382398            (declare (dynamic-extent so-far))
    383             (setq result
    384                   (nconc (%directory (%str-cat subdir "/") rest path so-far keys) result))))))
     399            (%directory (%str-cat subdir "/") rest path so-far keys result)
     400))))
    385401    result))
    386402
    387 (defun %files-in-directory (dir path so-far keys)
     403(defun %files-in-directory (dir path so-far keys result)
    388404  (let ((device (pathname-device path))
    389405        (name (pathname-name path))
     
    396412        (all (getf keys :all))
    397413        (include-emacs-lockfiles (getf keys :include-emacs-lockfiles))
    398         (result ())
    399414        sub dir-list ans)
    400415    (if (not (or name type))
     
    407422                      (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device)))
    408423          (when (and ans (or (null test) (funcall test ans)))
    409             (setq result (list ans)))))
     424            (%add-directory-result ans result follow-links))))
    410425      (with-open-dir (dirent (pathname-device path) dir)
    411426        (while (setq sub (%read-dir dirent))
     
    428443                        (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device)))))
    429444            (when (and ans (or (null test) (funcall test ans)))
    430               (push (if follow-links (or (probe-file ans) ans) ans) result))))))
     445              (%add-directory-result ans result follow-links))))))
    431446    result))
    432447
    433 (defun %all-directories (dir rest path so-far keys)
     448(defun %all-directories (dir rest path so-far keys result)
    434449  (let ((do-files nil)
    435450        (do-dirs nil)
    436         (result nil)
    437451        (device (pathname-device path))
    438452        (name (pathname-name path))
     
    451465        (multiple-value-setq (next-dir next-wild next-rest) (%split-dir rest)))
    452466      (cond ((not (string= next-dir "/"))
    453              (setq result
    454                    (%some-specific dir next-dir next-wild next-rest path so-far keys)))
     467             (%some-specific dir next-dir next-wild next-rest path so-far keys result))
    455468            (next-wild
    456              (setq result
    457                    (%one-wild dir next-wild next-rest path so-far keys)))
     469             (%one-wild dir next-wild next-rest path so-far keys result))
    458470            ((or name type)
    459471             (when (getf keys :files) (setq do-files t))
     
    464476                             (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device)))
    465477                 (when (or (null test) (funcall test sub))
    466                    (setq result (list (if follow-links (truename sub) sub))))))))
    467     ; now descend doing %all-dirs on dirs and collecting files & dirs if do-x is t
    468     (with-open-dir (dirent device dir)
     478                   (%add-directory-result sub result follow-links))))))
     479    ;; now descend doing %all-dirs on dirs and collecting files & dirs
     480    ;; if do-x is t
     481    (with-open-dir (dirent device (%path-std-quotes dir nil "*;:"))
    469482      (while (setq sub (%read-dir dirent))
    470483        (when (and (or all (neq (%schar sub 0) #\.))
     
    475488                   (std-sub (%path-std-quotes sub nil "/;:*"))
    476489                   (so-far (cons std-sub so-far))
    477                    (subdir (%str-cat subfile "/")))
     490                   (subdir (%str-cat subfile  "/")))
    478491              (declare (dynamic-extent so-far))
    479492              (when (and do-dirs (%file*= name type sub))
     
    483496                                            std-sub nil nil device)))
    484497                (when (or (null test) (funcall test ans))
    485                   (push (if follow-links (truename ans) ans) result)))
    486               (setq result (nconc (%all-directories subdir rest path so-far keys) result)))
     498                  (%add-directory-result ans result follow-links)))
     499              (%all-directories subdir rest path so-far keys result))
    487500            (when (and do-files (%file*= name type sub))
    488501              (multiple-value-bind (name type) (%std-name-and-type sub)
    489502                (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device))
    490503                (when (or (null test) (funcall test ans))
    491                   (push (if follow-links (truename ans) ans) result))))))))
     504                  (%add-directory-result ans result follow-links))))))))
    492505    result))
    493506
Note: See TracChangeset for help on using the changeset viewer.