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

[mevenson at common-lisp.net]

Author: mevenson
Date: Mon Jan  9 02:53:45 2012
New Revision: 13730

Log:
Fix #177: make logic for finding abcl-contrib more robust.

Issuing a (REQUIRE 'ABCL-CONTRIB) will now use the full name of the
jar archive ABCL was loaded from if it is of the form `abcl.jar' or
`abcl-x.y.z.jar` or `abcl-x.y.z-some-arbitrary-string.jar' to
determine the location of the jar containing the ABCL-CONTRIB
packages.  The namestrings of the ASDF systems located by this
mechanism are now printed to *STANDARD-OUTPUT*.

Installations of the implementations loading from non-standard
locations may use the SYS::*ABCL-JAR* and SYS:*ABCL-CONTRIB* specials
to override this behavior.

Modified:
   trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp	Mon Jan  9 01:55:58 2012	(r13729)
+++ trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp	Mon Jan  9 02:53:45 2012	(r13730)
@@ -2,21 +2,21 @@
 
 (require :asdf)
 
-;;; XXX make less sensitive to ABCL jar being called "abcl.jar"
-;;;     allow being called "abcl-x.y.z.jar for semantic versioning 
-;;;     allow customization in system.lisp
+;;; TODO possibly allow customization in system.lisp?
 (defun find-system-jar () 
-  (dolist (loader (java:dump-classpath))
-    (let ((abcl-jar
-	   (find-if (lambda (p) (and 
-                                 (or (equal (pathname-name p) "abcl")
-                                     (equal (pathname-name p) 
-                                            (format nil "abcl-~A" 
-                                                    (lisp-implementation-version))))
-				     (equal (pathname-type p) "jar")))
-		    (rest loader))))
-      (when abcl-jar
-	(return abcl-jar)))))
+  (flet ((match-system-jar (p)
+           "Match `abcl.jar` or `abcl-1.0.1.jar` or `abcl-1.0.1-something.jar`"
+           (and (pathnamep p)
+                (equal (pathname-type p) "jar")
+                (java:jstatic "matches"
+                              "java.util.regex.Pattern" 
+                              "abcl(-[0-9]\\.[0-9]\\.[0-9](-.+)?)?" 
+                              (pathname-name p))
+                p)))
+    (dolist (loader (java:dump-classpath))
+      (let ((abcl-jar (some #'match-system-jar loader)))
+        (when abcl-jar
+          (return abcl-jar))))))
 
 (defvar *abcl-jar* nil
   "Pathname of the jar that ABCL was loaded from.
@@ -26,32 +26,41 @@
   "Pathname of the ABCL contrib.
 Initialized via SYSTEM:FIND-CONTRIB")
 
-(defun find-contrib (&optional (verbose nil))
+(defun find-contrib (&key (verbose nil))
 "Attempt to find the ABCL contrib jar and add its contents to ASDF."
   (unless *abcl-contrib*
     (unless *abcl-jar*
       (setf *abcl-jar* (find-system-jar)))
     (when *abcl-jar*
-      (let ((abcl-contrib (make-pathname :defaults *abcl-jar*
-					 :name "abcl-contrib")))
-	(when (probe-file abcl-contrib)
-	  (setf *abcl-contrib* abcl-contrib)
-	  (dolist (asdf-file
-		    (directory (make-pathname :device (list *abcl-contrib*)
-					      :directory '(:absolute :wild)
-					      :name :wild
-					      :type "asd")))
-	    (let ((asdf-directory 
-		   (make-pathname :defaults asdf-file :name nil :type nil)))
-	      (when verbose
-		(format t "Adding ~A to ASDF.~%" asdf-directory))
-	      (push asdf-directory asdf:*central-registry*)))
-	  *abcl-contrib*)))))
+      (let* ((abcl-contrib-name
+              (concatenate 'string "abcl-contrib"
+                           (subseq (pathname-name *abcl-jar*) 4)))
+             (abcl-contrib (make-pathname :defaults *abcl-jar*
+                                          :name abcl-contrib-name)))
+	(if (probe-file abcl-contrib)
+            (progn
+              (setf *abcl-contrib* abcl-contrib)
+              (dolist (asdf-file
+                        (directory (make-pathname :device (list *abcl-contrib*)
+                                                  :directory '(:absolute :wild)
+                                                  :name :wild
+                                                  :type "asd")))
+                (let ((asdf-directory 
+                       (make-pathname :defaults asdf-file :name nil :type nil)))
+                  (format verbose "Adding ~A to ASDF.~%" asdf-directory)
+                  (push asdf-directory asdf:*central-registry*)))
+              *abcl-contrib*)
+        (format verbose "Failed to find abcl-contrib at '~A'." abcl-contrib))))))
 
-(when (find-contrib)
+
+(when (find-contrib :verbose t)
   (provide :abcl-contrib))
 
 
 
+
+
+
+