[armedbear-cvs] r13336 - in trunk/abcl: . contrib/asdf-jar src/org/armedbear/lisp src/org/armedbear/lisp/protocol test/lisp/abcl
mevenson at common-lisp.net
mevenson at common-lisp.net
Thu Jun 16 14:56:53 UTC 2011
Author: mevenson
Date: Thu Jun 16 07:56:53 2011
New Revision: 13336
Log:
Create form of SYSTEM:ZIP that uses a hashtable to map files to entries.
SYSTEM:ZIP PATH HASHTABLE now creates entries in a zipfile at PATH
whose entries are the contents of for each (KEY VALUE) in HASHTABLE
for which KEY refers to an object on the filesystem and VALUE is the
location in the zip archive.
Introduce Java interfaces in org.armedbear.lisp.protocol to start
encapsulating behavior of Java system. By retroactively adding
markers to the object hierarchy rooted on LispObject we gain the
ability to have our JVM code optionally work with interfaces but we
leave the core dispatch functions alone for speed.
Added:
trunk/abcl/src/org/armedbear/lisp/protocol/
trunk/abcl/src/org/armedbear/lisp/protocol/Hashtable.java
trunk/abcl/src/org/armedbear/lisp/protocol/Inspectable.java
trunk/abcl/src/org/armedbear/lisp/protocol/LispObject.java
trunk/abcl/test/lisp/abcl/zip.lisp
Modified:
trunk/abcl/abcl.asd
trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
trunk/abcl/src/org/armedbear/lisp/HashTable.java
trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java
trunk/abcl/src/org/armedbear/lisp/zip.java
Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd Thu Jun 16 07:56:43 2011 (r13335)
+++ trunk/abcl/abcl.asd Thu Jun 16 07:56:53 2011 (r13336)
@@ -57,6 +57,8 @@
("file-system-tests"))
#+abcl
(:file "weak-hash-tables")
+ #+abcl
+ (:file "zip")
#+abcl
(:file "pathname-tests" :depends-on
("utilities"))))))
Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
==============================================================================
--- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Jun 16 07:56:43 2011 (r13335)
+++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Thu Jun 16 07:56:53 2011 (r13336)
@@ -4,29 +4,93 @@
(in-package :asdf-jar)
+
(defvar *systems*)
(defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system))
(push c *systems*))
-(defun package (system-name &key (recursive t) (verbose t))
- (declare (ignore recursive))
+;; (defvar *sources*)
+;; (defmethod asdf:perform :before ((op asdf:compile-op) (s asdf:source-file))
+;; (push c *sources*))
+
+(eval-when (:compile-toplevel :execute)
+ (ql:quickload "cl-fad"))
+
+(defun package (system-name
+ &key (out #p"/var/tmp/")
+ (recursive t)
+ (verbose t))
(asdf:disable-output-translations)
- (let* ((system (asdf:find-system system-name))
- (name (slot-value system 'asdf::name)))
+ (let* ((system
+ (asdf:find-system system-name))
+ (name
+ (slot-value system 'asdf::name))
+ (version
+ (slot-value system 'asdf:version))
+ (package-jar-name
+ (format nil "~A~A-~A.jar" name (when recursive "-all") version))
+ (package-jar
+ (make-pathname :directory out :defaults package-jar-name))
+ (tmpdir (tmpdir (pathname-name (pathname package-jar-name)))))
(when verbose
- (format verbose "Packaging ASDF definition of~A~%" system))
+ (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
(setf *systems* nil)
(asdf:compile-system system :force t)
(let* ((dir (asdf:component-pathname system))
(wild-contents (merge-pathnames "**/*" dir))
(contents (directory wild-contents))
- (output (format nil "/var/tmp/~A.jar" name))
(topdir (truename (merge-pathnames "../" dir))))
(when verbose
- (format verbose "Packaging contents in ~A.~%" output))
- (system:zip output contents topdir)))
+ (format verbose "~&Packaging contents in ~A." package-jar))
+ (dolist (system (append (list system) *systems*))
+ (copy-recursively system tmpdir))
+ (system:zip package-jar contents topdir)))
(asdf:initialize-output-translations))
+(defun copy-recursively (source destination)
+ (let* ((source (truename source))
+ (source-directories (1- (length (pathname-directory source))))
+ (destination (truename destination)))
+ (cl-fad:walk-directory
+ source
+ (lambda (p)
+ (let* ((relative-depth (- (length (pathname-directory p))
+ (length (pathname-directory source))))
+ (subdir '(nthcdr (+ source-directories relative-depth)
+ (pathname-directory source)))
+ (orig (merge-pathnames p
+ (make-pathname :directory (append (pathname-directory
+ source)
+ subdir))))
+ (dest (merge-pathnames p
+ (make-pathname :directory (append (pathname-directory
+ destination)
+ subdir)))))
+ (format t "~&Would copy ~A~&to ~A." orig dest))))))
+
+
+(defun tmpdir (name)
+ "Return a the named temporary directory."
+ (let* ((temp-file (java:jcall "getAbsolutePath"
+ (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
+ (temp-path (pathname temp-file)))
+ (make-pathname
+ :directory (nconc (pathname-directory temp-path)
+ (list name)))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/HashTable.java Thu Jun 16 07:56:43 2011 (r13335)
+++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Thu Jun 16 07:56:53 2011 (r13336)
@@ -36,7 +36,10 @@
import java.util.concurrent.locks.ReentrantLock;
import static org.armedbear.lisp.Lisp.*;
-public class HashTable extends LispObject {
+public class HashTable
+ extends LispObject
+ implements org.armedbear.lisp.protocol.Hashtable
+{
protected static final float loadFactor = 0.75f;
protected final LispObject rehashSize;
@@ -347,8 +350,13 @@
}
}
- // Returns a list of (key . value) pairs.
+
public LispObject ENTRIES() {
+ return getEntries();
+ }
+
+ // Returns a list of (key . value) pairs.
+ public LispObject getEntries() {
// No need to take out a read lock, for the same reason as MAPHASH
HashEntry[] b = buckets;
LispObject list = NIL;
Modified: trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Thu Jun 16 07:56:43 2011 (r13335)
+++ trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Thu Jun 16 07:56:53 2011 (r13336)
@@ -57,6 +57,7 @@
// WeakHashTable type to be parameterized on an enclosed type.
public class WeakHashTable
extends LispObject
+ implements org.armedbear.lisp.protocol.Hashtable
{
protected static final float loadFactor = 0.75f;
protected final LispObject rehashSize;
@@ -508,8 +509,13 @@
}
}
- // Returns a list of (key . value) pairs.
+ @Deprecated
public LispObject ENTRIES() {
+ return getEntries();
+ }
+
+ /** @returns A list of (key . value) pairs. */
+ public LispObject getEntries() {
HashEntry[] b = getTable();
LispObject list = NIL;
for (int i = b.length; i-- > 0;) {
Added: trunk/abcl/src/org/armedbear/lisp/protocol/Hashtable.java
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/protocol/Hashtable.java Thu Jun 16 07:56:53 2011 (r13336)
@@ -0,0 +1,11 @@
+package org.armedbear.lisp.protocol;
+
+/** Mark object as implementing the Hashtable protocol. */
+public interface Hashtable
+ extends org.armedbear.lisp.protocol.LispObject
+{
+ public org.armedbear.lisp.LispObject getEntries();
+
+ @Deprecated
+ public org.armedbear.lisp.LispObject ENTRIES();
+}
\ No newline at end of file
Added: trunk/abcl/src/org/armedbear/lisp/protocol/Inspectable.java
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/protocol/Inspectable.java Thu Jun 16 07:56:53 2011 (r13336)
@@ -0,0 +1,7 @@
+package org.armedbear.lisp.protocol;
+
+/** Object implements a protocol for dynamic introspection. */
+public interface Inspectable {
+ public org.armedbear.lisp.LispObject getParts();
+}
+
Added: trunk/abcl/src/org/armedbear/lisp/protocol/LispObject.java
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/abcl/src/org/armedbear/lisp/protocol/LispObject.java Thu Jun 16 07:56:53 2011 (r13336)
@@ -0,0 +1,8 @@
+package org.armedbear.lisp.protocol;
+
+/** Mark implementation of the LispObject protocol. */
+public interface LispObject {
+ public org.armedbear.lisp.LispObject typeOf();
+ // TODO fill in with other functions as need arises
+}
+
Modified: trunk/abcl/src/org/armedbear/lisp/zip.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/zip.java Thu Jun 16 07:56:43 2011 (r13335)
+++ trunk/abcl/src/org/armedbear/lisp/zip.java Thu Jun 16 07:56:53 2011 (r13336)
@@ -58,11 +58,15 @@
{
super("zip", PACKAGE_SYS, true);
}
+
@Override
public LispObject execute(LispObject first, LispObject second)
{
Pathname zipfilePathname = coerceToPathname(first);
+ if (second instanceof org.armedbear.lisp.protocol.Hashtable) {
+ return execute(zipfilePathname, (org.armedbear.lisp.protocol.Hashtable)second);
+ }
byte[] buffer = new byte[4096];
try {
String zipfileNamestring = zipfilePathname.getNamestring();
@@ -80,8 +84,8 @@
out.close();
File zipfile = new File(zipfileNamestring);
zipfile.delete();
- return error(new SimpleError("Pathname has no namestring: " +
- pathname.writeToString()));
+ return error(new SimpleError("Pathname has no namestring: "
+ + pathname.writeToString()));
}
File file = new File(namestring);
makeEntry(out, file);
@@ -95,6 +99,8 @@
return zipfilePathname;
}
+
+
@Override
public LispObject execute(LispObject first, LispObject second, LispObject third)
{
@@ -154,6 +160,82 @@
}
return zipfilePathname;
}
+
+ static class Directories extends HashSet<String> {
+ private Directories() {
+ super();
+ }
+
+ ZipOutputStream out;
+ public Directories(ZipOutputStream out) {
+ this.out = out;
+ }
+
+ public void ensure(String path)
+ throws IOException
+ {
+ int i = 0;
+ int j;
+ while ((j = path.indexOf(Pathname.separator, i)) != -1) {
+ i = j + 1;
+ final String directory = path.substring(0, j) + Pathname.separator;
+ if (!contains(directory)) {
+ add(directory);
+ ZipEntry entry = new ZipEntry(directory);
+ out.putNextEntry(entry);
+ out.closeEntry();
+ }
+ }
+ }
+ }
+
+ public LispObject execute(final Pathname zipfilePathname, final org.armedbear.lisp.protocol.Hashtable table) {
+ LispObject entriesObject = (LispObject)table.getEntries();
+ if (!(entriesObject instanceof Cons)) {
+ return NIL;
+ }
+ Cons entries = (Cons)entriesObject;
+
+ String zipfileNamestring = zipfilePathname.getNamestring();
+ if (zipfileNamestring == null)
+ return error(new SimpleError("Pathname has no namestring: " +
+ zipfilePathname.writeToString()));
+ ZipOutputStream out = null;
+ try {
+ out = new ZipOutputStream(new FileOutputStream(zipfileNamestring));
+ } catch (FileNotFoundException e) {
+ return error(new FileError("Failed to create file for writing zip archive", zipfilePathname));
+ }
+ Directories directories = new Directories(out);
+
+
+ for (LispObject head = entries; head != NIL; head = head.cdr()) {
+ final LispObject key = head.car().car();
+ final LispObject value = head.car().cdr();
+
+ final Pathname source = Lisp.coerceToPathname(key);
+ final Pathname destination = Lisp.coerceToPathname(value);
+ final File file = Utilities.getFile(source);
+ try {
+ String jarEntry = destination.getNamestring();
+ if (jarEntry.startsWith("/")) {
+ jarEntry = jarEntry.substring(1);
+ }
+ directories.ensure(jarEntry);
+ makeEntry(out, file, jarEntry);
+ } catch (FileNotFoundException e) {
+ return error(new FileError("Failed to read file for incoporation in zip archive.", source));
+ } catch (IOException e) {
+ return error(new FileError("Failed to add file to zip archive.", source));
+ }
+ }
+ try {
+ out.close();
+ } catch (IOException ex) {
+ return error(new FileError("Failed to close zip archive.", zipfilePathname));
+ }
+ return zipfilePathname;
+ }
private static final Primitive zip = new zip();
Added: trunk/abcl/test/lisp/abcl/zip.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/abcl/test/lisp/abcl/zip.lisp Thu Jun 16 07:56:53 2011 (r13336)
@@ -0,0 +1,20 @@
+(in-package #:abcl.test.lisp)
+
+(deftest zip.1
+ (let ((mapping (make-hash-table :test 'equal)))
+ (loop :for (key value)
+ :in `(("/etc/hosts" "/etc/hosts")
+ ("/etc/group" "groups")
+ ("/etc/resolv.conf" "/opt/etc/resolv.conf"))
+ :doing
+ (setf (gethash key mapping) value))
+ (values
+ (system:zip #p"/var/tmp/foo.jar" mapping)
+ (not (probe-file "jar:file:/var/tmp/foo.jar!/etc/hosts"))
+ (not (probe-file "jar:file:/var/tmp/foo.jar!/groups"))
+ (not (probe-file "jar:file:/var/tmp/foo.jar!/opt/etc/resolv.conf"))))
+ #p"/var/tmp/foo.jar" nil nil nil)
+
+(eval-when (:load-toplevel)
+ (if (not (find :unix *features*))
+ (pushnew 'zip.1 *expected-failures*)))
More information about the armedbear-cvs
mailing list