Changeset 11577

Timestamp:

01/23/09 19:37:18 (14 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:

• directory.lisp (modified) (1 diff)
• pathnames.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/directory.lisp

@@ -71 +71 @@
     (when (logical-pathname-p pathname)
       (setq pathname (translate-logical-pathname pathname)))
-    (if (wild-pathname-p pathname)
+    (if (or (position #\* (namestring pathname))
+      (wild-pathname-p pathname))
         (let ((namestring (directory-namestring pathname)))
           (when (and namestring (> (length namestring) 0))

trunk/abcl/src/org/armedbear/lisp/pathnames.lisp

@@ -52 +52 @@
   (%wild-pathname-p pathname field-key))
 
+(defun component-match-wild-p (thing wild ignore-case)
+  (let ((testfunc (if ignore-case #'equalp #'equal)))
+    (labels ((split-string (delim str)
+         (flet ((finder (char) (find char delim)))
+     (loop  for x = (position-if-not #'finder str) then
+          (position-if-not #'finder str :start (or y (length str)))
+        for y = (position-if #'finder str :start x) then
+          (position-if #'finder str :start (or x (length str))) while x 
+        collect (subseq str x y))))
+       (positions-larger (thing substrings previous-pos)
+         (let ((new-pos (search (car substrings) 
+              thing 
+              :start2 previous-pos
+              :test testfunc)))
+     (or 
+      (not substrings)
+      (and new-pos
+           (>= new-pos previous-pos)
+           (positions-larger thing 
+           (cdr substrings) 
+           new-pos))))))
+      (let ((split-result (split-string "*" wild)))
+  (and (positions-larger thing split-result 0)
+       (if (eql (elt wild 0) #\*)
+     t
+     (eql (search (first split-result) thing :test testfunc) 0))
+       (if (eql (elt wild (1- (length wild))) #\*)
+     t
+     (let ((last-split-result (first (last split-result))))
+       (eql (search last-split-result thing :from-end t 
+        :test testfunc)
+      (- (length thing) (length last-split-result))))))))))
+
 (defun component-match-p (thing wild ignore-case)
   (cond ((eq wild :wild)
@@ -58 +91 @@
          t)
         ((and (stringp wild) (position #\* wild))
-         (error "Unsupported wildcard pattern: ~S" wild))
+   (component-match-wild-p thing wild ignore-case))
         (ignore-case
          (equalp thing wild))