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

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

pathname: various fixed in order to work Windows

Don't use #P reader macro in source as it can throw errors. Use
PATHNAME function instead.

LOAD for URL-PATHNAME working under Windows

TODO work through ramifications of needing to uri-encode whitespace
and other components for URLPathname.

Give up on java.net.{URL,URI} for construction of pathnames, as they
provide no help in uri encoding and fail to account for
MSDOS drive letters.

File size: 9.0 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.7.1/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         (format *standard-output*
106                 "~&Skipping enumeration of resource '~a' with type '~a'.~%"
107                 entry (type-of entry)))))
108      result)))
109
110(defun find-jar (predicate)
111  (dolist (d (enumerate-resource-directories))
112    (let ((entries (directory (make-pathname :defaults d
113               :name "*"
114               :type "jar"))))
115      (let ((jar (some predicate entries)))
116  (when (and jar (probe-file jar))
117    (return-from find-jar
118            (make-pathname :device (list (probe-file jar)))))))))
119
120(defun find-system-jar ()
121  "Return the pathname of the system jar, one of `abcl.jar` or
122`abcl-m.n.p.jar` or `abcl-m.n.p[.~-]something.jar`."
123  (find-jar #'system-jar-p))
124
125(defun find-contrib-jar ()
126  "Return the pathname of the contrib jar, one of `abcl-contrib.jar` or
127`abcl-contrib-m.n.p.jar` or `abcl-contrib-m.n.p[.~-]something.jar`."
128  (find-jar #'contrib-jar-p))
129
130(defvar *abcl-contrib* nil
131  "Pathname of the abcl-contrib artifact.
132
133Initialized via SYSTEM:FIND-CONTRIB.")
134
135;;; FIXME: stop using the obsolete ASDF:*CENTRAL-REGISTRY*
136(defun add-contrib (abcl-contrib-jar
137                    &key (verbose cl:*load-verbose*))
138  "Introspects the ABCL-CONTRIB-JAR path for sub-directories which
139  contain asdf definitions, adding those found to asdf."
140  (let ((jar-path (if (ext:pathname-jar-p abcl-contrib-jar)
141                      abcl-contrib-jar
142                      (make-pathname :device (list abcl-contrib-jar)))))
143    (dolist (asdf-file
144             (directory (merge-pathnames "*/*.asd" jar-path)))
145      (let ((asdf-directory (make-pathname :defaults asdf-file :name nil :type nil)))
146        (unless (find asdf-directory asdf:*central-registry* :test #'equal)
147          (push asdf-directory asdf:*central-registry*)
148          (format verbose "~&; Added ~A to ASDF.~%" asdf-directory))))))
149
150(defun find-and-add-contrib (&key (verbose cl:*load-verbose*))
151  "Attempt to find the ABCL contrib jar and add its contents to ASDF.
152returns the pathname of the contrib if it can be found."
153   (if *abcl-contrib*
154       (format verbose "~&; Finding contribs utilizing previously initialized value of SYS:*ABCL-CONTRIB* '~A'.~%"
155               *abcl-contrib*)
156       (progn
157         (let ((contrib (find-contrib)))
158           (when contrib
159             (format verbose "~&; Using probed value of SYS:*ABCL-CONTRIB* '~A'.~%"
160                     contrib)
161             (setf *abcl-contrib* contrib)))))
162   (when *abcl-contrib*  ;; For bootstrap compile there will be no contrib
163     (add-contrib *abcl-contrib*)))
164
165(defun find-name-for-implementation-title (file id)
166  "For a jar FILE containing a manifest, return the name of the
167  section which annotates 'Implementation-Title' whose string value is
168  ID."
169  (declare (type pathname file))
170  (let* ((jar (java:jnew "java.util.jar.JarFile" (namestring file)))
171         (manifest (java:jcall "getManifest" jar))
172         (entries (java:jcall "toArray"
173                              (java:jcall "entrySet"
174                                          (java:jcall "getEntries" manifest)))))
175    (dolist (entry 
176              (loop :for entry :across entries
177                 :collecting entry))
178      (let ((title (java:jcall "getValue"
179                               (java:jcall "getValue" entry)
180                               "Implementation-Title")))
181        (when (string-equal title id)
182          (return-from find-name-for-implementation-title
183            (java:jcall "getKey" entry))))
184    nil)))
185
186(defun find-contrib ()
187  "Introspect runtime classpaths to return a pathname containing
188  subdirectories containing ASDF definitions."
189
190  (or
191   ;; We identify the location of the directory within a jar file
192   ;; containing abcl-contrib ASDF definitions by looking for a section
193   ;; which contains the Implementation-Title "org.abcl-contrib".  The
194   ;; name of that section then identifies the relative pathname to the
195   ;; top-most directory in the Jar
196   ;;
197   ;; e.g. for an entry of the form
198   ;;
199   ;;     Name: contrib
200   ;;     Implementation-Title: org.abcl-contrib
201   ;;
202   ;; the directory 'contrib' would be searched for ASDF definitions.
203   (ignore-errors
204        (let* ((system-jar
205                (find-system-jar))
206               (relative-pathname 
207                (find-name-for-implementation-title system-jar "org.abcl-contrib")))
208          (when (and system-jar relative-pathname)
209            (merge-pathnames (pathname (concatenate 'string
210                                                   relative-pathname "/"))
211                            (make-pathname
212                             :device (list system-jar))))))
213   (ignore-errors
214     (find-contrib-jar))
215   (ignore-errors
216     (let ((system-jar (find-system-jar)))
217       (when system-jar
218         (probe-file (make-pathname
219                      :defaults system-jar
220                      :name (concatenate 'string
221                                         "abcl-contrib"
222                                         (subseq (pathname-name system-jar) 4)))))))
223   (when (java:jinstance-of-p (boot-classloader) "java.net.URLClassLoader")
224     (some
225      (lambda (u)
226        (probe-file (make-pathname
227                     :defaults (java:jcall "toString" u)
228                     :name "abcl-contrib")))
229      (java:jcall "getURLs" (boot-classloader))))))
230
231(export '(find-system
232          find-contrib
233          system-artifacts-are-jars-p
234          java.class.path
235          *abcl-contrib*)
236        :system)
237
238(when (find-and-add-contrib :verbose cl:*load-verbose*)
239  (provide :abcl-contrib))
Note: See TracBrowser for help on using the repository browser.