Changeset 15096 for release


Ignore:
Timestamp:
Nov 29, 2011, 2:14:22 PM (8 years ago)
Author:
gb
Message:

Propagate r15083 (DIRECTORY and symbolic links) to 1.7

Location:
release/1.7/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/1.7/source/level-1/linux-files.lisp

    r15010 r15096  
    363363       #-(or linux-target solaris-target)
    364364       (round (pref stat :stat.st_mtimespec.tv_nsec) 1000)
    365        (pref stat :stat.st_gid))
    366       (values nil nil nil nil nil nil nil)))
     365       (pref stat :stat.st_gid)
     366       (pref stat :stat.st_dev))
     367      (values nil nil nil nil nil nil nil nil nil nil)))
    367368
    368369#+win64-target
     
    378379       #$BUFSIZ
    379380       (pref stat :_stat64.st_mtime)     ; ???
    380        (pref stat :_stat64.st_gid))
    381       (values nil nil nil nil nil nil nil nil nil)))
     381       (pref stat :_stat64.st_gid)
     382       (pref stat :_stat64.st_dev))
     383      (values nil nil nil nil nil nil nil nil nil nil)))
    382384
    383385#+win32-target
     
    393395       #$BUFSIZ
    394396       (pref stat :__stat64.st_mtime)     ; ???
    395        (pref stat :__stat64.st_gid))
    396       (values nil nil nil nil nil nil nil nil nil)))
     397       (pref stat :__stat64.st_gid)
     398       (pref stat :__stat64.st_dev))
     399      (values nil nil nil nil nil nil nil nil nil nil)))
    397400
    398401#+windows-target
  • release/1.7/source/lib/pathnames.lisp

    r14358 r15096  
    331331    (%str-cat dir subdir)))
    332332
    333 (defmacro with-open-dir ((dirent device dir) &body body)
    334   `(let ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil)))))
    335      (when ,dirent
    336        (unwind-protect
    337            (progn ,@body)
    338          (close-dir ,dirent)))))
     333(defmacro with-open-dir ((dirent device dir state follow-links) &body body)
     334  (let* ((namestring (gensym)))
     335    `(let* ((,namestring (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil))))
     336      (when (%new-directory-p ,namestring ,follow-links ,state)
     337        (let* ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil)))))
     338          (when ,dirent
     339            (unwind-protect
     340                 (progn ,@body)
     341              (close-dir ,dirent))))))))
    339342
    340343(defun path-is-link (path)
    341344  "Returns T if PATH is a (hard or symbolic) link, NIL otherwise."
     345  ;; Actually, it's a bit more subtle than that; it basically
     346  ;; returns information about the last component of PATH.  If
     347  ;; some enclosing directory name is a link but the last component
     348  ;; isn't, this'll return false.
    342349  (eq (%unix-file-kind (native-translated-namestring path) t) :link))
    343350
    344 
    345 (defun %add-directory-result (path result follow-links)
    346   (let* ((resolved (and follow-links (path-is-link path) (probe-file path))))
    347     (if resolved
    348       (push (namestring resolved) (cdr result)) ; may introduce duplicates.
    349       (push (namestring path) (car result)))
    350     path))
    351 
    352 (defun %make-directory-result ()
    353   (cons nil nil))
     351(defstruct (directory-result (:constructor %make-directory-result))
     352  (truenames (make-hash-table :shared nil :test 'string= :hash-function 'sxhash))
     353  (directories-seen ()))
     354
     355
     356;;; If no component of the pathname involves a link we could avoid the call to
     357;;; TRUENAME here.  Later ...
     358(defun %add-directory-result (path result follow-links &optional followed-some-links)
     359  (declare (ignore followed-some-links))
     360  (let* ((truename (if follow-links (truename path) path))
     361         (namestring (namestring truename))
     362         (truenames (directory-result-truenames result)))
     363    (or (gethash namestring truenames)
     364        (setf (gethash namestring truenames) truename))))
     365   
    354366
    355367(defun %process-directory-result (result)
    356   (dolist (resolved (cdr result) (mapcar #'parse-namestring (sort (car result)  #'string<)))
    357     (pushnew resolved (car result) :test #'string=)))
     368  (collect ((pairs))
     369    (maphash (lambda (namestring truename) (pairs (cons namestring truename))) (directory-result-truenames result))
     370    (mapcar #'cdr (sort (pairs) #'string< :key #'car))))
     371
     372(defun %new-directory-p (namestring follow-links result)
     373  (multiple-value-bind (win mode size mtime inode uid blocksize rmtime  gid dev)
     374      (%stat namestring (not follow-links))
     375    (declare (ignore size mtime uid blocksize rmtime gid #+windows-target inode #+windows-target dev))
     376    (when (and win (= (logand mode #$S_IFMT) #$S_IFDIR))
     377      #+windows-target
     378      (let* ((dirname (namestring (truename (pathname namestring)))))
     379        (unless (member dirname (directory-result-directories-seen result) :test #'string=)
     380          (push dirname (directory-result-directories-seen result))
     381          t))
     382      #-windows-target
     383      (when (dolist (pair (directory-result-directories-seen result) t)
     384              (when (and (eql inode (car pair))
     385                         (eql dev (cdr pair)))
     386                (return)))
     387        (push (cons inode dev) (directory-result-directories-seen result))
     388        t))))
    358389
    359390 
    360 (defun directory (path &key (directories nil) ;; include subdirectories
     391(defun directory (path &key (directories t) ;; include subdirectories
    361392                            (files t)         ;; include files
    362393                            (all t)           ;; include Unix dot files (other than dot and dot dot)
     
    410441  (let ((device (pathname-device path))
    411442        (all (getf keys :all))
     443        (follow-links (getf keys :follow-links))
    412444        name)
    413     (with-open-dir (dirent device dir)
     445    (with-open-dir (dirent device dir result follow-links)
    414446      (while (setq name (%read-dir dirent))
    415447        (when (and (or all (neq (%schar name 0) #\.))
     
    417449                   (not (string= name ".."))
    418450                   (%path-pstr*= wild name)
    419                    (eq (%unix-file-kind (%path-cat device dir name) t) :directory))
     451                   (eq (%unix-file-kind (%path-cat device dir name) (not follow-links)) :directory))
    420452          (let ((subdir (%path-cat nil dir name))
    421453                (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
     
    441473        (when (and directories
    442474                   (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device)))
    443                                         t)
     475                                        (not follow-links))
    444476                       :directory))
    445477          (setq ans (if directory-pathnames full-path
     
    447479          (when (and ans (or (null test) (funcall test ans)))
    448480            (%add-directory-result ans result follow-links))))
    449       (with-open-dir (dirent (pathname-device path) dir)
     481      (with-open-dir (dirent (pathname-device path) dir result follow-links)
    450482        (while (setq sub (%read-dir dirent))
    451483          (when (and (or all (neq (%schar sub 0) #\.))
     
    457489                     (%file*= name type sub))
    458490            (setq ans
    459                   (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
     491                  (if (eq (%unix-file-kind (%path-cat device dir sub) (not follow-links)) :directory)
    460492                    (when directories
    461493                      (let* ((std-sub (%path-std-quotes sub nil "/;:*")))
     
    503535    ;; now descend doing %all-dirs on dirs and collecting files & dirs
    504536    ;; if do-x is t
    505     (with-open-dir (dirent device (%path-std-quotes dir nil "*;:"))
     537    (with-open-dir (dirent device (%path-std-quotes dir nil "*;:") result follow-links)
    506538      (while (setq sub (%read-dir dirent))
    507539        (when (and (or all (neq (%schar sub 0) #\.))
    508540                   (not (string= sub "."))
    509541                   (not (string= sub "..")))
    510           (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
     542          (if (eq (%unix-file-kind (%path-cat device dir sub) (not follow-links)) :directory)
    511543            (let* ((subfile (%path-cat nil dir sub))
    512544                   (std-sub (%path-std-quotes sub nil "/;:*"))
Note: See TracChangeset for help on using the changeset viewer.