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

[Mark Evenson]

Author: mevenson
Date: Sat Feb 20 18:52:28 2010
New Revision: 12491

Log:
DIRECTORY works for (some) jar:file cases.

Doesn't handle JAR in JAR or JAR not file:.



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	Sat Feb 20 18:52:28 2010
@@ -71,25 +71,53 @@
   (let ((pathname (merge-pathnames pathspec)))
     (when (logical-pathname-p pathname)
       (setq pathname (translate-logical-pathname pathname)))
-    (if (or (position #\* (namestring pathname))
-	    (wild-pathname-p pathname))
-        (let ((namestring (directory-namestring pathname)))
-          (when (and namestring (> (length namestring) 0))
-            #+windows
-            (let ((device (pathname-device pathname)))
-              (when device
-                (setq namestring (concatenate 'string device ":" namestring))))
-            (let ((entries (list-directories-with-wildcards namestring))
-                  (matching-entries ()))
-              (dolist (entry entries)
-                (cond ((file-directory-p entry)
-                       (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname))
-                         (push entry matching-entries)))
-                      ((pathname-match-p (file-namestring entry) (file-namestring pathname))
-                       (push entry matching-entries))))
-              matching-entries)))
-        ;; Not wild.
-        (let ((truename (probe-file pathname)))
-          (if truename
-              (list (pathname truename))
+    (if (pathname-jar-p pathname)
+        (directory-jar pathspec)
+        (if (or (position #\* (namestring pathname))
+                (wild-pathname-p pathname))
+            (let ((namestring (directory-namestring pathname)))
+              (when (and namestring (> (length namestring) 0))
+                #+windows
+                (let ((device (pathname-device pathname)))
+                  (when device
+                    (setq namestring (concatenate 'string device ":" namestring))))
+                (let ((entries (list-directories-with-wildcards namestring))
+                      (matching-entries ()))
+                  (dolist (entry entries)
+                    (cond ((file-directory-p entry)
+                           (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname))
+                             (push entry matching-entries)))
+                          ((pathname-match-p (file-namestring entry) (file-namestring pathname))
+                           (push entry matching-entries))))
+                  matching-entries)))
+            ;; Not wild.
+            (let ((truename (probe-file pathname)))
+              (if truename
+                  (list (pathname truename))
+                  nil))))))
+
+;;; Thanks to Alan "Never touch Java unless you have to" Ruttenberg
+;;; XXX need to handle JAR in JAR cases
+;;; XXX doesn't handle non file: JAR entries
+(defun directory-jar (pathname)
+  (let* ((device (pathname-device pathname))
+	 (jarfile (namestring (car device)))
+	 (rest-pathname (namestring (make-pathname :directory `(:absolute ,@(cdr (pathname-directory pathname)))
+						   :name (pathname-name pathname)
+						   :type (pathname-type pathname)))))
+    (if (or (position #\* (namestring rest-pathname))
+	    (wild-pathname-p rest-pathname))
+	(let ((jar (java:jnew "java.util.zip.ZipFile" jarfile)))
+	  (let ((els (java:jcall "entries" jar)))
+	    (loop :while (java:jcall "hasMoreElements" els)
+	       :for name = (java:jcall "getName"
+                                       (java:jcall "nextElement" els))
+	       :when (pathname-match-p (concatenate 'string "/" name) rest-pathname)
+	       :collect (make-pathname :device (pathname-device pathname)
+                                       :name (pathname-name name)
+                                       :type (pathname-type name)
+                                       :directory `(:relative ,@(cdr (pathname-directory name)))))))
+	(let ((truename (probe-file pathname)))
+	  (if truename
+              (list truename)
               nil)))))