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

Last change on this file was 15503, checked in by Mark Evenson, 3 months ago

abcl-aio: fix finding ABCL-CONTRIB

Probably broken since the revision of the JAR-PATHNAME merging
semantics in abcl-1.8.0.

Resolves <https://github.com/armedbear/abcl/issues/372>,
<https://abcl.org/trac/ticket/486>.

File size: 9.2 KB
Line 
1;;;; Mechanisms for finding loadable artifacts from the environment,
2;;;; which are then used to locate the Common Lisp systems included as
3;;;; `abcl-contrib`.
4(require :asdf)
5
6(in-package :system)
7
8(defun boot-classloader ()
9  (let ((boot-class (java:jclass "org.armedbear.lisp.Main"))
10        (get-classloader (java:jmethod "java.lang.Class" "getClassLoader")))
11    (java:jcall get-classloader boot-class)))
12
13;;; java[678] packages the JVM system artifacts as jar files
14;;; java11 uses the module system
15(defun system-artifacts-are-jars-p ()
16  (java:jinstance-of-p (boot-classloader) "java.net.URLClassLoader"))
17
18(defun system-jar-p (p)
19  (or (named-jar-p "abcl" p)
20      (named-jar-p "abcl-aio" p)))
21
22(defun contrib-jar-p (p)
23  (or 
24   (named-jar-p "abcl-contrib" p)
25   (named-jar-p "abcl-aio" p)))
26
27(defun named-jar-p (name p)
28  (and (pathnamep p)
29       (equal (pathname-type p) "jar")
30       (or
31        (java:jstatic "matches"
32                      "java.util.regex.Pattern"
33                      (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]([+~-].+)?)?")
34                      (pathname-name p))
35        (java:jstatic "matches"
36                      "java.util.regex.Pattern"
37                      (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]\\.[0-9]([+~-]+)?)?")
38                      (pathname-name p)))
39       p))
40
41(defun find-system ()
42  "Find the location of the Armed Bear system implementation
43
44Used to determine relative pathname to find 'abcl-contrib.jar'."
45  (or
46   (ignore-errors
47     (find-system-jar))
48   (ignore-errors
49     (when (system-artifacts-are-jars-p)
50       (some
51        (lambda (u)
52          (probe-file (make-pathname
53                       :defaults (java:jcall "toString" u)
54                       :name "abcl")))
55        (java:jcall "getURLs" (boot-classloader)))))
56   ;; Need to test locating the system boot jar over the network, and
57   ;; it would minimally need to check version information.
58   (ignore-errors
59     (pathname "jar:https://abcl.org/releases/1.8.0/abcl.jar!/"))))
60
61(defun flatten (list)
62  (labels ((rflatten (list accumluator)
63     (dolist (element list)
64       (if (listp element)
65     (setf accumluator (rflatten element accumluator))
66     (push element accumluator)))
67     accumluator))
68    (let (result)
69      (reverse (rflatten list result)))))
70
71(defun java.class.path ()
72  "Return a list of the directories as pathnames referenced in the JVM classpath."
73  (let* ((separator (java:jstatic "getProperty" "java.lang.System" "path.separator"))
74   (paths (coerce (java:jcall "split"
75         (java:jstatic "getProperty" "java.lang.System"
76           "java.class.path")
77         separator)
78                        'list))
79         (p (coerce paths 'list)))
80    (flet ((directory-of (p) (make-pathname :defaults p :name nil :type nil)))
81      (values
82       (mapcar #'directory-of p)
83       p))))
84
85(defun enumerate-resource-directories ()
86  (flet ((directory-of (p)
87           (make-pathname :defaults p
88                          :name nil
89                          :type nil)))
90    (let ((result (java.class.path)))
91      (dolist (entry (flatten (java:dump-classpath)))
92        (cond
93          ((java:jinstance-of-p entry "java.net.URLClassLoader") ;; java1.[678]
94     (dolist (url (coerce (java:jcall "getURLs" entry)
95              'list))
96             (let ((p (directory-of (pathname (java:jcall "toString" url)))))
97         (when (probe-file p)
98           (pushnew p result :test 'equal)))))
99        ((pathnamep entry)
100         (pushnew (directory-of entry) result :test 'equal))
101        ((and (stringp entry)
102        (probe-file (pathname (directory-of entry))))
103         (pushnew (pathname (directory-of entry)) result :test 'equal))
104        (t
105         #+(or) ;; Possibly informative for debugging new JVM implementations
106         (format *standard-output*
107                 "~&Skipping enumeration of resource '~a' with type '~a'.~%"
108                 entry (type-of entry)))))
109      result)))
110
111(defun find-jar (predicate)
112  (dolist (d (enumerate-resource-directories))
113    (let ((entries (directory (make-pathname :defaults d
114               :name "*"
115               :type "jar"))))
116      (let ((jar (some predicate entries)))
117  (when (and jar (probe-file jar))
118    (return-from find-jar
119            (make-pathname :device (list (probe-file jar)))))))))
120
121(defun find-system-jar ()
122  "Return the pathname of the system jar, one of `abcl.jar` or
123`abcl-m.n.p.jar` or `abcl-m.n.p[.~-]something.jar`."
124  (find-jar #'system-jar-p))
125
126(defun find-contrib-jar ()
127  "Return the pathname of the contrib jar, one of `abcl-contrib.jar` or
128`abcl-contrib-m.n.p.jar` or `abcl-contrib-m.n.p[.~-]something.jar`."
129  (find-jar #'contrib-jar-p))
130
131(defvar *abcl-contrib* nil
132  "Pathname of the abcl-contrib artifact.
133
134Initialized via SYSTEM:FIND-CONTRIB.")
135
136;;; FIXME: stop using the obsolete ASDF:*CENTRAL-REGISTRY*
137(defun add-contrib (abcl-contrib-jar
138                    &key (verbose cl:*load-verbose*))
139  "Introspects the ABCL-CONTRIB-JAR path for sub-directories which
140  contain asdf definitions, adding those found to asdf."
141  (let ((jar-path (if (ext:pathname-jar-p abcl-contrib-jar)
142                      abcl-contrib-jar
143                      (make-pathname :device (list abcl-contrib-jar)))))
144    (dolist (asdf-file
145             (directory (merge-pathnames "*/*.asd" jar-path)))
146      (let ((asdf-directory (make-pathname :defaults asdf-file :name nil :type nil)))
147        (unless (find asdf-directory asdf:*central-registry* :test #'equal)
148          (push asdf-directory asdf:*central-registry*)
149          (format verbose "~&; Added ~A to ASDF.~%" asdf-directory))))))
150
151(defun find-and-add-contrib (&key (verbose cl:*load-verbose*))
152  "Attempt to find the ABCL contrib jar and add its contents to ASDF.
153returns the pathname of the contrib if it can be found."
154   (if *abcl-contrib*
155       (format verbose "~&; Finding contribs utilizing previously initialized value of SYS:*ABCL-CONTRIB* '~A'.~%"
156               *abcl-contrib*)
157       (progn
158         (let ((contrib (find-contrib)))
159           (when contrib
160             (format verbose "~&; Using probed value of SYS:*ABCL-CONTRIB* '~A'.~%"
161                     contrib)
162             (setf *abcl-contrib* contrib)))))
163   (when *abcl-contrib*  ;; For bootstrap compile there will be no contrib
164     (add-contrib *abcl-contrib*)))
165
166(defun find-name-for-implementation-title (file id)
167  "For a jar FILE containing a manifest, return the name of the
168  section which annotates 'Implementation-Title' whose string value is
169  ID."
170  (declare (type pathname file))
171  (let* ((jar-file
172           (java:jcall "getFile" (first (pathname-device file))))
173         (jar
174           (java:jnew "java.util.jar.JarFile" jar-file))
175         (manifest
176           (java:jcall "getManifest" jar))
177         (entries
178           (java:jcall "toArray"
179                       (java:jcall "entrySet"
180                                   (java:jcall "getEntries" manifest)))))
181    (dolist (entry 
182              (loop :for entry :across entries
183                 :collecting entry))
184      (let ((title (java:jcall "getValue"
185                               (java:jcall "getValue" entry)
186                               "Implementation-Title")))
187        (when (string-equal title id)
188          (return-from find-name-for-implementation-title
189            (java:jcall "getKey" entry))))
190    nil)))
191
192(defun find-contrib ()
193  "Introspect runtime classpaths to return a pathname containing
194  subdirectories containing ASDF definitions."
195
196  (or
197   ;; We identify the location of the directory within a jar file
198   ;; containing abcl-contrib ASDF definitions by looking for a section
199   ;; which contains the Implementation-Title "org.abcl-contrib".  The
200   ;; name of that section then identifies the relative pathname to the
201   ;; top-most directory in the Jar
202   ;;
203   ;; e.g. for an entry of the form
204   ;;
205   ;;     Name: contrib
206   ;;     Implementation-Title: org.abcl-contrib
207   ;;
208   ;; the directory 'contrib' would be searched for ASDF definitions.
209   (ignore-errors
210        (let* ((system-jar
211                (find-system-jar))
212               (relative-pathname 
213                (find-name-for-implementation-title system-jar "org.abcl-contrib")))
214          (when (and system-jar relative-pathname)
215            (merge-pathnames (pathname (concatenate 'string
216                                                    relative-pathname "/"))
217                             system-jar))))
218                                       
219   (ignore-errors
220     (find-contrib-jar))
221   (ignore-errors
222     (let ((system-jar (find-system-jar)))
223       (when system-jar
224         (probe-file (make-pathname
225                      :defaults system-jar
226                      :name (concatenate 'string
227                                         "abcl-contrib"
228                                         (subseq (pathname-name system-jar) 4)))))))
229   (when (java:jinstance-of-p (boot-classloader) "java.net.URLClassLoader")
230     (some
231      (lambda (u)
232        (probe-file (make-pathname
233                     :defaults (java:jcall "toString" u)
234                     :name "abcl-contrib")))
235      (java:jcall "getURLs" (boot-classloader))))))
236
237(export '(find-system
238          find-contrib
239          system-artifacts-are-jars-p
240          java.class.path
241          *abcl-contrib*)
242        :system)
243
244(when (find-and-add-contrib :verbose cl:*load-verbose*)
245  (provide :abcl-contrib))
Note: See TracBrowser for help on using the repository browser.