Changeset 13243


Ignore:
Timestamp:
03/12/11 19:18:05 (11 years ago)
Author:
vvoutilainen
Message:

This patch fixes
1) recursion with wild-inferiors for paths like "/usr/share//ui/*.xml"
The previous code didn't recurse into directories not named "ui" at
all in that case.
2) symlinks that point to the current directory
3) the listing returned by list-directories-with-wildcards can
return paths for which file-namestring is nil, protect the filtering
from barfing on those.
4) tabs in the file. Sure, this should be done separately but
we have reviewed the changes without the tab change so we'll do
it with the same patch.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/directory.lisp

    r13230 r13243  
    4949                                        resolve-symlinks)
    5050  (let* ((directory (pathname-directory pathname))
    51   (first-wild-inferior (and (not wild-inferiors-found)
    52            (position-if #'wild-inferiors-p directory)))
    53   (first-wild (position-if #'wild-p directory))
    54   (wild (when (or first-wild-inferior first-wild)
    55     (nthcdr (or first-wild-inferior first-wild) directory)))
    56   (non-wild (if (or first-wild-inferior first-wild)
    57            (nbutlast directory
    58         (- (length directory)
    59             (or first-wild-inferior first-wild)))
    60          directory))
    61   (newpath (make-pathname :directory non-wild
    62         :name nil :type nil :defaults pathname))
    63   (entries (list-directory newpath resolve-symlinks)))
     51        (first-wild-inferior (and (not wild-inferiors-found)
     52                                   (position-if #'wild-inferiors-p directory)))
     53        (first-wild (position-if #'wild-p directory))
     54        (wild (when (or first-wild-inferior first-wild)
     55                (nthcdr (or first-wild-inferior first-wild) directory)))
     56        (non-wild (if (or first-wild-inferior first-wild)
     57                       (nbutlast directory
     58                                (- (length directory)
     59                                    (or first-wild-inferior first-wild)))
     60                     directory))
     61        (newpath (make-pathname :directory non-wild
     62                                :name nil :type nil :defaults pathname))
     63        (entries (list-directory newpath resolve-symlinks)))
    6464    (if (not (or wild wild-inferiors-found))
    65   entries
    66   (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries)))
    67     (nconc
    68      (mapcan (lambda (entry)
    69          (when (pathname-match-p (pathname entry) pathname)
    70            (list entry)))
    71        inferior-entries)
    72      (mapcan (lambda (entry)
    73          (let* ((pathname (pathname entry))
    74           (directory (pathname-directory pathname))
    75           (rest-wild (cdr wild)))
    76            (unless (pathname-name pathname)
    77        (when (pathname-match-p (first (last directory))
    78             (cond ((eql (car wild) :wild)
    79              "*")
    80             ((eql (car wild) :wild-inferiors)
    81              "*")
    82             (wild
    83              (car wild))
    84             (t "")))
    85          (when rest-wild
    86            (setf directory (nconc directory rest-wild)))
    87          (list-directories-with-wildcards
    88           (make-pathname :directory directory
    89              :defaults newpath)
    90           (or first-wild-inferior wild-inferiors-found)
    91                             resolve-symlinks)))))
    92        entries))))))
     65        entries
     66        (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries)))
     67          (nconc
     68           (mapcan (lambda (entry)
     69                     (when (pathname-match-p (pathname entry) pathname)
     70                       (list entry)))
     71                   inferior-entries)
     72           (mapcan (lambda (entry)
     73                     (let* ((pathname (pathname entry))
     74                            (directory (pathname-directory pathname))
     75                            (rest-wild (cdr wild)))
     76                       (unless (pathname-name pathname)
     77                         (when (pathname-match-p (first (last directory))
     78                                    (cond ((eql (car wild) :wild)
     79                                           "*")
     80                                          ((eql (car wild) :wild-inferiors)
     81                                           "*")
     82                                          (wild
     83                                           (car wild))
     84                                          (t "")))
     85                           (when (and
     86                                  (not (or first-wild-inferior
     87                                           wild-inferiors-found))
     88                                  rest-wild)
     89                             (setf directory (nconc directory rest-wild)))
     90                           (let ((recurse (make-pathname :directory directory
     91                                                  :defaults newpath)))
     92                             (when (not (equal recurse newpath))
     93                               (list-directories-with-wildcards
     94                                recurse
     95                                (or first-wild-inferior wild-inferiors-found)
     96                                resolve-symlinks)))))))
     97                   entries))))))
    9398
    9499
     
    98103      (setq pathname (translate-logical-pathname pathname)))
    99104    (if (or (position #\* (namestring pathname))
    100       (wild-pathname-p pathname))
     105            (wild-pathname-p pathname))
    101106        (if (pathname-jar-p pathname)
    102107            (match-wild-jar-pathname pathname)
     
    114119                           (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname))
    115120                             (push entry matching-entries)))
    116                           ((pathname-match-p (file-namestring entry) (file-namestring pathname))
     121                          ((pathname-match-p (or (file-namestring entry) "") (file-namestring pathname))
    117122                           (push entry matching-entries))))
    118123                  matching-entries))))
Note: See TracChangeset for help on using the changeset viewer.