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

Last change on this file since 14655 was 14655, checked in by Mark Evenson, 10 years ago

Normalized indentation.

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