Changeset 12248

Jun 10, 2009, 9:34:22 PM (10 years ago)

r11996 from trunk

1 edited


  • branches/working-0711/ccl/lib/pathnames.lisp

    r11649 r12248  
    230230  bits.  Portable programs should avoid using the :MODE keyword
    231231  argument."
    232   (let* ((pathname (make-directory-pathname :directory (pathname-directory (translate-logical-pathname (merge-pathnames pathspec)))))
    233          (created-p nil))
     232  (let ((pathname (let ((pathspec (translate-logical-pathname (merge-pathnames pathspec))))
     233                    (make-directory-pathname :device (pathname-device pathspec)
     234                                             :directory (pathname-directory pathspec))))
     235        (created-p nil))
    234236    (when (wild-pathname-p pathname)
    235237      (error 'file-error
    300302;Directory Traversing
    302 (defmacro with-open-dir ((dirent dir) &body body)
    303   `(let ((,dirent (%open-dir ,dir)))
     304(defun %path-cat (device dir subdir)
     305  (if device
     306      (%str-cat device ":" dir subdir)
     307    (%str-cat dir subdir)))
     309(defmacro with-open-dir ((dirent device dir) &body body)
     310  `(let ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil)))))
    304311     (when ,dirent
    305312       (unwind-protect
    360367; for a * or *x*y
    361368(defun %one-wild (dir wild rest path so-far keys)
    362   (let ((result ()) (all (getf keys :all)) name subdir)
    363     (with-open-dir (dirent dir)
     369  (let ((result ())
     370        (device (pathname-device path))
     371        (all (getf keys :all))
     372        name)
     373    (with-open-dir (dirent device dir)
    364374      (while (setq name (%read-dir dirent))
    365375        (when (and (or all (neq (%schar name 0) #\.))
    367377                   (not (string= name ".."))
    368378                   (%path-pstr*= wild name)
    369                    (eq (%unix-file-kind (setq subdir (%str-cat dir name)) t) :directory))
    370           (let ((so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
     379                   (eq (%unix-file-kind (%path-cat device dir name) t) :directory))
     380          (let ((subdir (%path-cat nil dir name))
     381                (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
    371382            (declare (dynamic-extent so-far))
    372383            (setq result
    376387(defun %files-in-directory (dir path so-far keys)
    377   (let ((name (pathname-name path))
     388  (let ((device (pathname-device path))
     389        (name (pathname-name path))
    378390        (type (pathname-type path))
    379391        (directories (getf keys :directories))
    387399        sub dir-list ans)
    388400    (if (not (or name type))
    389       (when directories
    390         (setq ans (if directory-pathnames
    391                     (%cons-pathname (reverse so-far) nil nil)
    392                     (%cons-pathname (reverse (cdr so-far)) (car so-far) nil)))
    393         (when (and ans (or (null test) (funcall test ans)))
    394           (setq result (list ans))))
    395       (with-open-dir (dirent dir)
     401      (let (full-path)
     402        (when (and directories
     403                   (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device)))
     404                                        t)
     405                       :directory))
     406          (setq ans (if directory-pathnames full-path
     407                      (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device)))
     408          (when (and ans (or (null test) (funcall test ans)))
     409            (setq result (list ans)))))
     410      (with-open-dir (dirent (pathname-device path) dir)
    396411        (while (setq sub (%read-dir dirent))
    397412          (when (and (or all (neq (%schar sub 0) #\.))
    403418                     (%file*= name type sub))
    404419            (setq ans
    405                   (if (eq (%unix-file-kind (%str-cat dir sub) t) :directory)
     420                  (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
    406421                    (when directories
    407422                      (let* ((std-sub (%path-std-quotes sub nil "/;:*")))
    408423                        (if directory-pathnames
    409                           (%cons-pathname (reverse (cons std-sub so-far)) nil nil)
    410                           (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil))))
     424                          (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device)
     425                          (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil nil device))))
    411426                    (when files
    412427                      (multiple-value-bind (name type) (%std-name-and-type sub)
    413                         (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type)))))
     428                        (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device)))))
    414429            (when (and ans (or (null test) (funcall test ans)))
    415430              (push (if follow-links (or (probe-file ans) ans) ans) result))))))
    420435        (do-dirs nil)
    421436        (result nil)
     437        (device (pathname-device path))
    422438        (name (pathname-name path))
    423439        (type (pathname-type path))
    426442        (directory-pathnames (getf keys :directory-pathnames))
    427443        (follow-links (getf keys :follow-links))
    428         sub subfile dir-list ans)
     444        sub dir-list ans)
    429445    ;; First process the case that the ** stands for 0 components
    430446    (multiple-value-bind (next-dir next-wild next-rest) (%split-dir rest)
    445461            (t (when (getf keys :directories)
    446462                 (setq sub (if directory-pathnames
    447                              (%cons-pathname (setq dir-list (reverse so-far)) nil nil)
    448                              (%cons-pathname (reverse (cdr so-far)) (car so-far) nil)))
     463                             (%cons-pathname (setq dir-list (reverse so-far)) nil nil nil device)
     464                             (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device)))
    449465                 (when (or (null test) (funcall test sub))
    450466                   (setq result (list (if follow-links (truename sub) sub))))))))
    451467    ; now descend doing %all-dirs on dirs and collecting files & dirs if do-x is t
    452     (with-open-dir (dirent dir)
     468    (with-open-dir (dirent device dir)
    453469      (while (setq sub (%read-dir dirent))
    454470        (when (and (or all (neq (%schar sub 0) #\.))
    455471                   (not (string= sub "."))
    456472                   (not (string= sub "..")))
    457           (if (eq (%unix-file-kind (setq subfile (%str-cat dir sub)) t) :directory)
    458             (let* ((std-sub (%path-std-quotes sub nil "/;:*"))
     473          (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
     474            (let* ((subfile (%path-cat nil dir sub))
     475                   (std-sub (%path-std-quotes sub nil "/;:*"))
    459476                   (so-far (cons std-sub so-far))
    460477                   (subdir (%str-cat subfile "/")))
    462479              (when (and do-dirs (%file*= name type sub))
    463480                (setq ans (if directory-pathnames
    464                             (%cons-pathname (reverse so-far) nil nil)
     481                            (%cons-pathname (reverse so-far) nil nil nil device)
    465482                            (%cons-pathname (or dir-list (setq dir-list (reverse (cdr so-far))))
    466                                             std-sub nil)))
     483                                            std-sub nil nil device)))
    467484                (when (or (null test) (funcall test ans))
    468485                  (push (if follow-links (truename ans) ans) result)))
Note: See TracChangeset for help on using the changeset viewer.