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

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

abcl-contrib: Fix whitespace.

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
76(defun find-and-add-contrib (&key (verbose nil))
77  "Attempt to find the ABCL contrib jar and add its contents to ASDF.
78Returns the pathname of the contrib if it can be found."
79  (if *abcl-contrib*
80      (format verbose "~&Using already initialized value of abcl-contrib:~&'~A'.~%"
81              *abcl-contrib*)
82      (progn 
83        (setf *abcl-contrib* (find-contrib))
84        (format verbose "~&Using probed value of abcl-contrib:~&'~A'.~%"
85                *abcl-contrib*)))
86  (add-contrib *abcl-contrib*))
87
88(defun find-contrib ()
89  "Introspect runtime classpaths to find a loadable ABCL-CONTRIB."
90  (or (ignore-errors 
91    (when (find-system-jar)
92      (probe-file 
93       (make-pathname :defaults (find-system-jar)
94              :name "abcl-contrib"))))
95    (some 
96     (lambda (u) 
97     (probe-file (make-pathname 
98            :defaults  (java:jcall "toString" u)
99            :name "abcl-contrib")))
100     (java:jcall "getURLs" (boot-classloader)))))
101
102(export `(find-system 
103          find-contrib
104          *abcl-contrib*))
105(when (find-and-add-contrib :verbose t)
106  (provide :abcl-contrib))
107
108
109
110
111
112
113
114           
115 
Note: See TracBrowser for help on using the repository browser.