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