Changeset 13730 for trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp

Timestamp:

01/09/12 10:53:45 (11 years ago)

Author:

Mark Evenson

Message:

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.

File:

• trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp (modified) (3 diffs)

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

@@ -3 +3 @@
 (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
@@ -27 +27 @@
 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*
@@ -33 +33 @@
       (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))
+
+
+
+