[armedbear-cvs] r12503 - in trunk/abcl: . doc/design/pathnames src/org/armedbear/lisp
Mark Evenson
mevenson at common-lisp.net
Mon Feb 22 16:32:47 UTC 2010
Author: mevenson
Date: Mon Feb 22 11:32:45 2010
New Revision: 12503
Log:
DIRECTORY now works for jar pathnames.
The semantics for listing directories are a little bit different from
DIRECTORY on filesystems because directory entries in jar files
*always* have a trailing '/'.
Modified:
trunk/abcl/CHANGES
trunk/abcl/doc/design/pathnames/abcl-jar-url.text
trunk/abcl/src/org/armedbear/lisp/Pathname.java
trunk/abcl/src/org/armedbear/lisp/directory.lisp
Modified: trunk/abcl/CHANGES
==============================================================================
--- trunk/abcl/CHANGES (original)
+++ trunk/abcl/CHANGES Mon Feb 22 11:32:45 2010
@@ -14,8 +14,8 @@
* [svn 12447] [ticket:80] REQUIRE now searches for ASDF systems.
* [svn r12422] Jar pathname support extensively re-worked and tested
- so that LOAD, PROBE-FILE, TRUENAME, and WRITE-FILE-DATE all work
- both for local and remote jar pathnames of the form
+ so that LOAD, PROBE-FILE, TRUENAME, DIRECTORY, and WRITE-FILE-DATE
+ all work both for local and remote jar pathnames of the form
"jar:URL!/JAR-ENTRY".
The loading ASDF systems from jar files is now possible.
@@ -23,8 +23,7 @@
SYS:PATHNAME-JAR-P predicate signals whether a pathname references a
jar.
- NB: jar pathnames do *not* currently work as an argument to OPEN or
- DIRECTORY.
+ NB: jar pathnames do *not* currently work as an argument to OPEN.
SYS:UNZIP implemented to unpack ZIP files.
Modified: trunk/abcl/doc/design/pathnames/abcl-jar-url.text
==============================================================================
--- trunk/abcl/doc/design/pathnames/abcl-jar-url.text (original)
+++ trunk/abcl/doc/design/pathnames/abcl-jar-url.text Mon Feb 22 11:32:45 2010
@@ -3,7 +3,7 @@
Mark Evenson
Created: 09 JAN 2010
-Modified: 08 FEB 2010
+Modified: 22 FEB 2010
Notes towards sketching an implementation of "jar:" references to be
contained in PATHNAMEs within ABCL.
@@ -53,11 +53,9 @@
Status
------
-As of svn r12431, all the above goals have been implemented and tested
+As of svn r12501, all the above goals have been implemented and tested
*except* for:
-5. DIRECTORY working within JAR files
-
7. Make jar pathnames work as a valid argument for OPEN.
Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon Feb 22 11:32:45 2010
@@ -38,19 +38,14 @@
import java.io.IOException;
import java.io.InputStream;
import java.io.FileInputStream;
-import java.net.JarURLConnection;
import java.net.MalformedURLException;
import java.net.URL;
-import java.net.URLConnection;
import java.net.URLDecoder;
-import java.util.HashMap;
+import java.util.Enumeration;
import java.util.StringTokenizer;
-import java.util.jar.JarEntry;
-import java.util.jar.JarFile;
import java.util.zip.ZipEntry;
import java.util.zip.ZipFile;
import java.util.zip.ZipInputStream;
-import java.util.zip.ZipException;
public class Pathname extends LispObject {
@@ -1246,6 +1241,20 @@
}
}
}
+
+ private static Function pathname_match_p;
+ private static LispObject matchesWildcard(LispObject pathname, LispObject wildcard) {
+ if (pathname_match_p == null) {
+ pathname_match_p
+ = (Function) PACKAGE_SYS.findAccessibleSymbol("PATHNAME-MATCH-P")
+ .getSymbolFunction();
+ if (pathname_match_p == null) {
+ Debug.assertTrue(false);
+ }
+ }
+ return pathname_match_p.execute(pathname, wildcard);
+ }
+
// ### list-directory directory
private static final Primitive LIST_DIRECTORY = new pf_list_directory();
private static class pf_list_directory extends Primitive {
@@ -1258,10 +1267,53 @@
if (pathname instanceof LogicalPathname) {
pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname);
}
+
+ LispObject result = NIL;
if (pathname.isJar()) {
- return error(new FileError("Unimplemented directory listing of JAR files.", pathname));
+ String directory = pathname.asEntryPath();
+ Debug.assertTrue(directory != null); // We should only be listing directories
+
+ if (pathname.device.cdr() instanceof Cons) {
+ return error(new FileError("Unimplemented directory listing of JAR within JAR.", pathname));
+ }
+
+ if (directory.length() == 0) {
+ directory = "/*";
+ } else {
+ if (directory.endsWith("/")) {
+ directory = "/" + directory + "*";
+ } else {
+ directory = "/" + directory + "/*";
+ }
+ }
+ SimpleString wildcard = new SimpleString(directory);
+ SimpleString wildcardDirectory = new SimpleString(directory + "/");
+
+ ZipFile jar = ZipCache.get(pathname.device.car());
+ LispObject matches;
+ for (Enumeration<? extends ZipEntry> entries = jar.entries();
+ entries.hasMoreElements();) {
+ ZipEntry entry = entries.nextElement();
+ String entryName = "/" + entry.getName();
+
+ if (entryName.endsWith("/")) {
+ matches = matchesWildcard(new SimpleString(entryName),
+ wildcardDirectory);
+ } else {
+ matches = matchesWildcard(new SimpleString(entryName),
+ wildcard);
+ }
+ if (!matches.equals(NIL)) {
+ String namestring = new String(pathname.getNamestring());
+ namestring = namestring.substring(0, namestring.lastIndexOf("!/") + 2)
+ + entry.getName();
+ Pathname p = new Pathname(namestring);
+ result = new Cons(p, result);
+ }
+ }
+ return result;
}
- LispObject result = NIL;
+
String s = pathname.getNamestring();
if (s != null) {
File f = new File(s);
@@ -1292,6 +1344,62 @@
}
}
+ // ### match-wild-jar-pathname wild-jar-pathname
+ private static final Primitive LIST_JAR_DIRECTORY = new pf_match_wild_jar_pathname();
+ private static class pf_match_wild_jar_pathname extends Primitive {
+ pf_match_wild_jar_pathname() {
+ super("match-wild-jar-pathname", PACKAGE_SYS, false, "wild-jar-pathname");
+ }
+ @Override
+ public LispObject execute(LispObject arg) {
+ Pathname pathname = coerceToPathname(arg);
+ if (pathname instanceof LogicalPathname) {
+ pathname = LogicalPathname.translateLogicalPathname((LogicalPathname) pathname);
+ }
+ if (!pathname.isJar()) {
+ return new FileError("Not a jar pathname.", pathname);
+ }
+ if (!pathname.isWild()) {
+ return new FileError("Not a wild pathname.", pathname);
+ }
+ Pathname jarPathname = new Pathname(pathname);
+ jarPathname.directory = NIL;
+ jarPathname.name = NIL;
+ jarPathname.type = NIL;
+ jarPathname.invalidateNamestring();
+ // will propagate an appropiate Lisp error if jarPathname
+ // doesn't exist.
+ LispObject jarTruename = truename(jarPathname, true);
+
+ LispObject result = NIL;
+ String wild = "/" + pathname.asEntryPath();
+
+ if (pathname.device.cdr() instanceof Cons) {
+ return error(new FileError("Unimplemented directory listing of JAR within JAR.", pathname));
+ }
+
+ final SimpleString wildcard = new SimpleString(wild);
+
+ ZipFile jar = ZipCache.get(pathname.device.car());
+
+ for (Enumeration<? extends ZipEntry> entries = jar.entries(); entries.hasMoreElements();) {
+ ZipEntry entry = entries.nextElement();
+ String entryName = "/" + entry.getName();
+
+ LispObject matches = matchesWildcard(new SimpleString(entryName), wildcard);
+
+ if (!matches.equals(NIL)) {
+ String namestring = new String(pathname.getNamestring());
+ namestring = namestring.substring(0, namestring.lastIndexOf("!/") + 2)
+ + entry.getName();
+ Pathname p = new Pathname(namestring);
+ result = new Cons(p, result);
+ }
+ }
+ return result;
+ }
+ }
+
public boolean isAbsolute() {
if (!directory.equals(NIL) || !(directory == null)) {
if (directory instanceof Cons) {
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 Mon Feb 22 11:32:45 2010
@@ -53,18 +53,20 @@
:name nil :type nil :defaults pathname))
(entries (list-directory newpath)))
(if (not wild)
- entries (mapcan (lambda (entry)
- (let* ((pathname (pathname entry))
- (directory (pathname-directory pathname))
- (rest-wild (cdr wild)))
- (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))))
+ entries
+ (mapcan (lambda (entry)
+ (let* ((pathname (pathname entry))
+ (directory (pathname-directory pathname))
+ (rest-wild (cdr wild)))
+ (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))))
(defun directory (pathspec &key)
@@ -73,21 +75,23 @@
(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))
- (when (featurep :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)))
+ (if (pathname-jar-p pathname)
+ (match-wild-jar-pathname pathname)
+ (let ((namestring (directory-namestring pathname)))
+ (when (and namestring (> (length namestring) 0))
+ (when (featurep :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
More information about the armedbear-cvs
mailing list