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

Last change on this file was 15714, checked in by Mark Evenson, 2 years ago

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