From 71d9292d4c2627c4d76b763443be759f95423c2c Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 15 Jun 2009 10:03:54 +0000
Subject: [PATCH] 1.0.29.6: regression in DIRECTORY when matching directory
 patterns

 * Don't recurse on the return value of PATTERN-MATCHES, but rather
   the subdirectory that matches.
---
 NEWS                  |    2 ++
 src/code/filesys.lisp |    5 +++--
 tests/filesys.test.sh |   29 +++++++++++++++++++++++++++++
 version.lisp-expr     |    2 +-
 4 files changed, 35 insertions(+), 3 deletions(-)

diff --git a/NEWS b/NEWS
index 03aeaed..9218928 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,8 @@
   * bug fix: better error signalling when calls to functions seeking elements
     from lists (eg. ADJOIN) are compiled with both :TEST and :TEST-NOT.
     (reported by Tobias Rittweiler)
+  * bug fix: regression in DIRECTORY from 1.0.28.61, pattern matching of
+    directory components now works again.
 
 changes in sbcl-1.0.29 relative to 1.0.28:
   * IMPORTANT: bug database has moved from the BUGS file to Launchpad
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index cfd654c..db7bf8a 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -704,6 +704,7 @@ directory, the provided pathname is not fully resolved, but rather names the
 symbolic link as an immediate child of DIRECTORY.
 
 Experimental: interface subject to change."
+  (declare (pathname-designator directory))
   (let* ((fun (%coerce-callable-to-fun function))
          (physical (physicalize-pathname directory))
          ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows
@@ -807,8 +808,8 @@ Experimental: interface subject to change."
        (if (eq :wild this)
            #'cont
            (lambda (sub)
-             (awhen (pattern-matches this (last-directory-piece sub))
-               (funcall #'cont it))))
+             (when (pattern-matches this (last-directory-piece sub))
+               (funcall #'cont sub))))
        directory
        :files nil
        :directories t
diff --git a/tests/filesys.test.sh b/tests/filesys.test.sh
index 9b720a9..b636184 100644
--- a/tests/filesys.test.sh
+++ b/tests/filesys.test.sh
@@ -197,6 +197,35 @@ Lisp filename syntax idiosyncrasies)."
 (sb-ext:quit :unix-status $EXIT_LISP_WIN)
 EOF
 check_status_maybe_lose "DIRECTORY/TRUENAME part 3" $?
+cleanup_test_subdirectory
+
+# DIRECTORY pattern matching
+use_test_subdirectory
+
+mkdir foo
+touch foo/aa.txt
+touch foo/aa.tmp
+mkdir far
+touch far/ab.txt
+touch far/ab.tmp
+mkdir qar
+touch qar/ac.txt
+touch qar/ac.tmp
+run_sbcl <<EOF
+(defun test (pattern &rest expected)
+  (let ((wanted (sort (mapcar #'truename expected) #'string< :key #'namestring))
+        (got (sort (directory pattern) #'string< :key #'namestring)))
+    (unless (equal wanted got)
+      (format t "wanted:~%  ~Sgot:~%  ~S" wanted got)
+      (error "wanted:~%  ~Sgot:~%  ~S" wanted got))))                 
+(test "*/a*.txt" "foo/aa.txt" "far/ab.txt" "qar/ac.txt")
+(test "fo*/a*.t*" "foo/aa.txt" "foo/aa.tmp")
+(test "*/*b.*" "far/ab.txt" "far/ab.tmp")
+(test "*a*/*.txt" "far/ab.txt" "qar/ac.txt")
+(test "*ar/*.txt" "far/ab.txt" "qar/ac.txt")
+(quit :unix-status $EXIT_LISP_WIN)
+EOF
+check_status_maybe_lose "DIRECTORY/PATTERNS" $?
 
 # Test whether ENSURE-DIRECTORIES-EXIST can create a directory whose
 # name contains a wildcard character (it used to get itself confused
diff --git a/version.lisp-expr b/version.lisp-expr
index 67060a1..be30965 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.29.6"
+"1.0.29.7"
-- 
1.7.10.4