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

[Ville Voutilainen]

Author: vvoutilainen
Date: Sun Feb  1 19:24:13 2009
New Revision: 11616

Log:
Better matching in directory listing. There are
still cases where I can break it with my own
trees, but it doesn't list superfluous entries
with this patch.


Modified:
   trunk/abcl/src/org/armedbear/lisp/directory.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	Sun Feb  1 19:24:13 2009
@@ -44,11 +44,11 @@
 (defun list-directories-with-wildcards (pathname)
   (let* ((directory (pathname-directory pathname))
 	 (first-wild (position-if #'wild-p directory))
-	 (wild (and first-wild (nthcdr first-wild directory)))
-	 (non-wild (or (and first-wild
-			    (nbutlast directory
-				      (- (length directory) first-wild))
-			    directory)))
+	 (wild (when first-wild (nthcdr first-wild directory)))
+	 (non-wild (if first-wild
+		       (nbutlast directory
+				 (- (length directory) first-wild))
+		       directory))
 	 (newpath (make-pathname :directory non-wild
 				 :name nil :type nil :defaults pathname))
 	 (entries (list-directory newpath)))
@@ -57,12 +57,13 @@
                           (let* ((pathname (pathname entry))
                                  (directory (pathname-directory pathname))
                                  (rest-wild (cdr wild)))
-                            (unless (file-namestring pathname)
-                              (when rest-wild
-                                (setf directory (nconc directory rest-wild)))
-                              (list-directories-with-wildcards
-                               (make-pathname :directory directory
-                                              :defaults newpath)))))
+                            (unless (pathname-name pathname)
+			      (when (pathname-match-p (first (last directory)) (if (eql (car wild) :wild) "*" (car wild)))
+				(when rest-wild
+				  (setf directory (nconc directory rest-wild)))
+  				(list-directories-with-wildcards
+				 (make-pathname :directory directory
+						:defaults newpath))))))
                         entries))))