source: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp @ 14610

Last change on this file since 14610 was 14610, checked in by Mark Evenson, 8 years ago

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 size: 3.2 KB
Line 
1(in-package :system)
2
3(require :asdf)
4
5(defconstant +get-classloader+ (java:jmethod "java.lang.Class" "getClassLoader"))
6(defun boot-classloader () 
7  (let ((boot-class (java:jclass "org.armedbear.lisp.Main")))
8  (java:jcall +get-classloader+ boot-class)))
9
10(defun system-jar-p (p)
11  (named-jar-p "abcl" p))
12
13(defun contrib-jar-p (p)
14  (named-jar-p "abcl-contrib" p))
15
16(defun named-jar-p (name p)
17  (and (pathnamep p)
18       (equal (pathname-type p) "jar")
19     (or 
20    (java:jstatic "matches"
21            "java.util.regex.Pattern" 
22            (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]([+~-].+)?)?")
23            (pathname-name p))
24    (java:jstatic "matches"
25            "java.util.regex.Pattern" 
26            (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]\\.[0-9]([+~-]+)?)?")
27            (pathname-name p)))
28     (make-pathname :defaults p :name name)))
29
30(defun find-system ()
31  "Find the location of the system. 
32
33Used to determine relative pathname to find 'abcl-contrib.jar'."
34  (or 
35   (ignore-errors 
36   (find-system-jar))
37   (ignore-errors
38   (some 
39    (lambda (u) 
40    (probe-file (make-pathname 
41           :defaults  (java:jcall "toString" u)
42           :name "abcl")))
43    (java:jcall "getURLs" (boot-classloader))))
44   (ignore-errors 
45   #p"http://abcl.org/releases/current/abcl.jar")))
46
47(defun find-system-jar () 
48  "Return the pathname of the system jar, one of `abcl.jar` or `abcl-m.n.p.jar` or `abcl-m.n.p[.~-]something.jar`."
49    (dolist (loader (java:dump-classpath))
50      (let ((abcl-jar (some #'system-jar-p loader)))
51        (when abcl-jar
52          (return abcl-jar)))))
53
54(defvar *abcl-contrib* nil
55  "Pathname of the ABCL contrib.
56Initialized via SYSTEM:FIND-CONTRIB")
57
58(defparameter *verbose* t)
59
60(defun add-contrib (abcl-contrib-jar)
61  "Introspects ABCL-CONTRIB-JAR for asdf systems to add to ASDF:*CENTRAL-REGISTRY*"
62  (when abcl-contrib-jar
63  (dolist (asdf-file
64        (directory (make-pathname :device (list abcl-contrib-jar)
65                    :directory '(:absolute :wild)
66                    :name :wild
67                    :type "asd")))
68    (let ((asdf-directory (make-pathname :defaults asdf-file :name nil :type nil)))
69    (unless (find asdf-directory asdf:*central-registry* :test #'equal)
70      (push asdf-directory asdf:*central-registry*)
71      (format *verbose* "~&Added ~A to ASDF.~&" asdf-directory))))))
72
73
74(defun find-and-add-contrib (&key (verbose nil))
75  "Attempt to find the ABCL contrib jar and add its contents to ASDF.
76Returns the pathname of the contrib if it can be found."
77  (if *abcl-contrib*
78    (format verbose "~&Using already initialized value of abcl-contrib:~&'~A'.~%"
79        *abcl-contrib*)
80    (progn 
81    (setf *abcl-contrib* (find-contrib))
82    (format verbose "~&Using probed value of abcl-contrib:~&'~A'.~%"
83        *abcl-contrib*)))
84  (add-contrib *abcl-contrib*))
85
86(defun find-contrib ()
87  "Introspect runtime classpaths to find a loadable ABCL-CONTRIB."
88  (or 
89   (ignore-errors (when (find-system-jar)
90          (probe-file 
91           (make-pathname :defaults (find-system-jar)
92                  :name "abcl-contrib"))))
93   (some 
94  (lambda (u) 
95    (probe-file (make-pathname 
96           :defaults  (java:jcall "toString" u)
97           :name "abcl-contrib")))
98  (java:jcall "getURLs" (boot-classloader)))))
99
100(export `(find-system 
101      find-contrib
102      *abcl-contrib*))
103(when (find-and-add-contrib :verbose t)
104  (provide :abcl-contrib))
105
106
107
108
109
110
111
112       
113 
Note: See TracBrowser for help on using the repository browser.