Changeset 11577


Ignore:
Timestamp:
01/23/09 19:37:18 (12 years ago)
Author:
vvoutilainen
Message:

Support "partial" wildcards in DIRECTORY, like

"/path/somewh*re/foo*.txt". This also makes cl-bench

report.lisp work with either CL*.* (the form in report.lisp)
or CL* (the form which is the only one that clisp works with).

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r11391 r11577  
    7171    (when (logical-pathname-p pathname)
    7272      (setq pathname (translate-logical-pathname pathname)))
    73     (if (wild-pathname-p pathname)
     73    (if (or (position #\* (namestring pathname))
     74      (wild-pathname-p pathname))
    7475        (let ((namestring (directory-namestring pathname)))
    7576          (when (and namestring (> (length namestring) 0))
  • trunk/abcl/src/org/armedbear/lisp/pathnames.lisp

    r11391 r11577  
    5252  (%wild-pathname-p pathname field-key))
    5353
     54(defun component-match-wild-p (thing wild ignore-case)
     55  (let ((testfunc (if ignore-case #'equalp #'equal)))
     56    (labels ((split-string (delim str)
     57         (flet ((finder (char) (find char delim)))
     58     (loop  for x = (position-if-not #'finder str) then
     59          (position-if-not #'finder str :start (or y (length str)))
     60        for y = (position-if #'finder str :start x) then
     61          (position-if #'finder str :start (or x (length str))) while x
     62        collect (subseq str x y))))
     63       (positions-larger (thing substrings previous-pos)
     64         (let ((new-pos (search (car substrings)
     65              thing
     66              :start2 previous-pos
     67              :test testfunc)))
     68     (or
     69      (not substrings)
     70      (and new-pos
     71           (>= new-pos previous-pos)
     72           (positions-larger thing
     73           (cdr substrings)
     74           new-pos))))))
     75      (let ((split-result (split-string "*" wild)))
     76  (and (positions-larger thing split-result 0)
     77       (if (eql (elt wild 0) #\*)
     78     t
     79     (eql (search (first split-result) thing :test testfunc) 0))
     80       (if (eql (elt wild (1- (length wild))) #\*)
     81     t
     82     (let ((last-split-result (first (last split-result))))
     83       (eql (search last-split-result thing :from-end t
     84        :test testfunc)
     85      (- (length thing) (length last-split-result))))))))))
     86
    5487(defun component-match-p (thing wild ignore-case)
    5588  (cond ((eq wild :wild)
     
    5891         t)
    5992        ((and (stringp wild) (position #\* wild))
    60          (error "Unsupported wildcard pattern: ~S" wild))
     93   (component-match-wild-p thing wild ignore-case))
    6194        (ignore-case
    6295         (equalp thing wild))
Note: See TracChangeset for help on using the changeset viewer.