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 (java:jnew "java.util.jar.JarFile" (namestring file)))
172         (manifest (java:jcall "getManifest" jar))
173         (entries (java:jcall "toArray"
174                              (java:jcall "entrySet"
175                                          (java:jcall "getEntries" manifest)))))
176    (dolist (entry
177              (loop :for entry :across entries
178                 :collecting entry))
179      (let ((title (java:jcall "getValue"
180                               (java:jcall "getValue" entry)
181                               "Implementation-Title")))
182        (when (string-equal title id)
183          (return-from find-name-for-implementation-title
184            (java:jcall "getKey" entry))))
185    nil)))
186
187(defun find-contrib ()
188  "Introspect runtime classpaths to return a pathname containing
189  subdirectories containing ASDF definitions."
190
191  (or
192   ;; We identify the location of the directory within a jar file
193   ;; containing abcl-contrib ASDF definitions by looking for a section
194   ;; which contains the Implementation-Title "org.abcl-contrib".  The
195   ;; name of that section then identifies the relative pathname to the
196   ;; top-most directory in the Jar
197   ;;
198   ;; e.g. for an entry of the form
199   ;;
200   ;;     Name: contrib
201   ;;     Implementation-Title: org.abcl-contrib
202   ;;
203   ;; the directory 'contrib' would be searched for ASDF definitions.
204   (ignore-errors
205        (let* ((system-jar
206                (find-system-jar))
207               (relative-pathname
208                (find-name-for-implementation-title system-jar "org.abcl-contrib")))
209          (when (and system-jar relative-pathname)
210            (merge-pathnames (pathname (concatenate 'string
211                                                   relative-pathname "/"))
212                            (make-pathname
213                             :device (list system-jar))))))
214   (ignore-errors
215     (find-contrib-jar))
216   (ignore-errors
217     (let ((system-jar (find-system-jar)))
218       (when system-jar
219         (probe-file (make-pathname
220                      :defaults system-jar
221                      :name (concatenate 'string
222                                         "abcl-contrib"
223                                         (subseq (pathname-name system-jar) 4)))))))
224   (when (java:jinstance-of-p (boot-classloader) "java.net.URLClassLoader")
225     (some
226      (lambda (u)
227        (probe-file (make-pathname
228                     :defaults (java:jcall "toString" u)
229                     :name "abcl-contrib")))
230      (java:jcall "getURLs" (boot-classloader))))))
231
232(export '(find-system
233          find-contrib
234          system-artifacts-are-jars-p
235          java.class.path
236          *abcl-contrib*)
237        :system)
238
239(when (find-and-add-contrib :verbose cl:*load-verbose*)
240  (provide :abcl-contrib))
241