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

Timestamp:

01/25/14 12:09:48 (10 years ago)

Author:

Mark Evenson

Message:

Find abcl-contrib even if not running from abcl.jar.

The java.lang.ClassLoader? of the org.lisp.armedbear.Main class is used
to find a place to guess at where `abcl-contrib.jar' may be located.

TODO: load from http location.

TODO: find abcl-contrib-m.n.p[-extra-stuff.jar as well.

File:

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

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

@@ -3 +3 @@
 (require :asdf)
 
+(defconstant +get-classloader+ (java:jmethod "java.lang.Class" "getClassLoader"))
+(defun boot-classloader () 
+  (let ((boot-class (java:jclass "org.armedbear.lisp.Main")))
+  (java:jcall +get-classloader+ boot-class)))
+
 (defun system-jar-p (p)
+  (named-jar-p "abcl" p))
+
+(defun contrib-jar-p (p)
+  (named-jar-p "abcl-contrib" p))
+
+(defun named-jar-p (name p)
   (and (pathnamep p)
        (equal (pathname-type p) "jar")
-       (let ((name (pathname-name p)))
-         (or 
-          (java:jstatic "matches"
-                        "java.util.regex.Pattern" 
-                        "abcl(-[0-9]\\.[0-9]\\.[0-9]([+~-].+)?)?" 
-                        name)
-          (java:jstatic "matches"
-                        "java.util.regex.Pattern" 
-                        "abcl(-[0-9]\\.[0-9]\\.[0-9]\\.[0-9]([+~-]+)?)?" 
-                        name)))
-       p))
+     (or 
+    (java:jstatic "matches"
+            "java.util.regex.Pattern" 
+            (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]([+~-].+)?)?")
+            (pathname-name p))
+    (java:jstatic "matches"
+            "java.util.regex.Pattern" 
+            (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]\\.[0-9]([+~-]+)?)?")
+            (pathname-name p)))
+     (make-pathname :defaults p :name name)))
+
+(defun find-system ()
+  "Find the location of the system.  
+
+Used to determine relative pathname to find 'abcl-contrib.jar'."
+  (or 
+   (ignore-errors 
+   (find-system-jar))
+   (ignore-errors
+   (some 
+    (lambda (u) 
+    (probe-file (make-pathname 
+           :defaults  (java:jcall "toString" u)
+           :name "abcl")))
+    (java:jcall "getURLs" (boot-classloader))))
+   (ignore-errors 
+   #p"http://abcl.org/releases/current/abcl.jar")))
 
 (defun find-system-jar () 
@@ -25 +52 @@
           (return abcl-jar)))))
 
-(defvar *abcl-jar* nil
-  "Pathname of the jar that ABCL was loaded from.
-Initialized via SYSTEM::FIND-SYSTEM-JAR.")
-
 (defvar *abcl-contrib* nil
   "Pathname of the ABCL contrib.
 Initialized via SYSTEM:FIND-CONTRIB")
 
+(defparameter *verbose* t)
+
+(defun add-contrib (abcl-contrib-jar)
+  "Introspects ABCL-CONTRIB-JAR for asdf systems to add to ASDF:*CENTRAL-REGISTRY*"
+  (when abcl-contrib-jar
+  (dolist (asdf-file
+        (directory (make-pathname :device (list abcl-contrib-jar)
+                    :directory '(:absolute :wild)
+                    :name :wild
+                    :type "asd")))
+    (let ((asdf-directory (make-pathname :defaults asdf-file :name nil :type nil)))
+    (unless (find asdf-directory asdf:*central-registry* :test #'equal)
+      (push asdf-directory asdf:*central-registry*)
+      (format *verbose* "~&Added ~A to ASDF.~&" asdf-directory))))))
+
+
 (defun find-and-add-contrib (&key (verbose nil))
   "Attempt to find the ABCL contrib jar and add its contents to ASDF.
 Returns the pathname of the contrib if it can be found."
-  (flet ((add-contrib (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)))
-                  (unless (find asdf-directory asdf:*central-registry* :test #'equal)
-                    (push asdf-directory asdf:*central-registry*)
-                    (format verbose "~&Added ~A to ASDF.~&" asdf-directory))))
-              *abcl-contrib*))
-    (unless *abcl-contrib*
-      (unless *abcl-jar*
-        (setf *abcl-jar* (find-system-jar)))
-      (when *abcl-jar*
-        (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)
-              (add-contrib abcl-contrib)
-              (let ((abcl-contrib  (make-pathname :defaults abcl-contrib
-                                                  :name "abcl-contrib")))
-                (if (probe-file abcl-contrib)
-                    (progn  
-                      (warn "Falling back to using '~A' to satisfy require." abcl-contrib)
-                      (add-contrib abcl-contrib)
-                      (error "Failed to find abcl-contrib at '~A'." abcl-contrib))))))))))
+  (if *abcl-contrib*
+    (format verbose "~&Using already initialized value of abcl-contrib:~&'~A'.~%"
+        *abcl-contrib*)
+    (progn 
+    (setf *abcl-contrib* (find-contrib))
+    (format verbose "~&Using probed value of abcl-contrib:~&'~A'.~%"
+        *abcl-contrib*)))
+  (add-contrib *abcl-contrib*))
 
+(defun find-contrib ()
+  "Introspect runtime classpaths to find a loadable ABCL-CONTRIB."
+  (or 
+   (ignore-errors (when (find-system-jar)
+          (probe-file 
+           (make-pathname :defaults (find-system-jar)
+                  :name "abcl-contrib"))))
+   (some 
+  (lambda (u) 
+    (probe-file (make-pathname 
+           :defaults  (java:jcall "toString" u)
+           :name "abcl-contrib")))
+  (java:jcall "getURLs" (boot-classloader)))))
+
+(export `(find-system 
+      find-contrib
+      *abcl-contrib*))
 (when (find-and-add-contrib :verbose t)
   (provide :abcl-contrib))