[armedbear-cvs] r11577 - trunk/abcl/src/org/armedbear/lisp

[Ville Voutilainen]

Author: vvoutilainen
Date: Fri Jan 23 19:37:18 2009
New Revision: 11577

Log:
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).



Modified:
   trunk/abcl/src/org/armedbear/lisp/directory.lisp
   trunk/abcl/src/org/armedbear/lisp/pathnames.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/directory.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/directory.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/directory.lisp	Fri Jan 23 19:37:18 2009
@@ -70,7 +70,8 @@
   (let ((pathname (merge-pathnames pathspec)))
     (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))
             #+windows

Modified: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/pathnames.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/pathnames.lisp	Fri Jan 23 19:37:18 2009
@@ -51,13 +51,46 @@
 (defun wild-pathname-p (pathname &optional field-key)
   (%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)
          t)
         ((null wild)
          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))
         (t