Ignore:
Timestamp:
10/30/10 17:53:45 (11 years ago)
Author:
vvoutilainen
Message:

Add WILD-INFERIORS support for DIRECTORY.

File:
1 edited

Legend:

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

    r12503 r12985  
    4242                   :version nil)))
    4343
    44 (defun list-directories-with-wildcards (pathname)
     44(defun wild-inferiors-p (component)
     45  (eq component :wild-inferiors))
     46
     47(defun list-directories-with-wildcards (pathname
     48          &optional (wild-inferiors-found nil))
    4549  (let* ((directory (pathname-directory pathname))
     50   (first-wild-inferior (and (not wild-inferiors-found)
     51           (position-if #'wild-inferiors-p directory)))
    4652   (first-wild (position-if #'wild-p directory))
    47    (wild (when first-wild (nthcdr first-wild directory)))
    48    (non-wild (if first-wild
     53   (wild (when (or first-wild-inferior first-wild)
     54     (nthcdr (or first-wild-inferior first-wild) directory)))
     55   (non-wild (if (or first-wild-inferior first-wild)
    4956           (nbutlast directory
    50          (- (length directory) first-wild))
    51            directory))
     57         (- (length directory)
     58            (or first-wild-inferior first-wild)))
     59         directory))
    5260   (newpath (make-pathname :directory non-wild
    5361         :name nil :type nil :defaults pathname))
    5462   (entries (list-directory newpath)))
    55     (if (not wild)
    56   entries
    57         (mapcan (lambda (entry)
    58                   (let* ((pathname (pathname entry))
    59                          (directory (pathname-directory pathname))
    60                          (rest-wild (cdr wild)))
    61                     (unless (pathname-name pathname)
    62                       (when (pathname-match-p (first (last directory))
    63                                               (if (eql (car wild) :wild) "*" (car wild)))
    64                         (when rest-wild
    65                           (setf directory (nconc directory rest-wild)))
    66                         (list-directories-with-wildcards
    67                          (make-pathname :directory directory
    68                                         :defaults newpath))))))
    69                 entries))))
     63    (if (not (or wild wild-inferiors-found))
     64  entries
     65  (let ((inferior-entries (when (or wild-inferiors-found first-wild-inferior) entries)))
     66    (nconc
     67     (mapcan (lambda (entry)
     68         (when (pathname-match-p (pathname entry) pathname)
     69           (list entry)))
     70       inferior-entries)
     71     (mapcan (lambda (entry)
     72         (let* ((pathname (pathname entry))
     73          (directory (pathname-directory pathname))
     74          (rest-wild (cdr wild)))
     75           (unless (pathname-name pathname)
     76       (when (pathname-match-p (first (last directory))
     77            (cond ((eql (car wild) :wild)
     78             "*")
     79            ((eql (car wild) :wild-inferiors)
     80             "*")
     81            (wild
     82             (car wild))
     83            (t "")))
     84         (when rest-wild
     85           (setf directory (nconc directory rest-wild)))
     86         (list-directories-with-wildcards
     87          (make-pathname :directory directory
     88             :defaults newpath)
     89          (or first-wild-inferior wild-inferiors-found))))))
     90       entries))))))
    7091
    7192
Note: See TracChangeset for help on using the changeset viewer.