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

Last change on this file was 14974, checked in by Evenson Not Org, 2 years ago

Standardize use CL:*LOAD-VERBOSE* to control loading verbosity

Normalize logging output to a Lisp comment prefix (#\;) with a single tag
that identifies the "subsystem" emitting the diagnostic.

ABCL-ASDF:*MAVEN-VERBOSE* SYS:*ABCL-CONTRIB-VERBOSE* have been removed; use
CL:*LOAD-VERBOSE* to control them.

ASDF::*VERBOSE-OUT* and QUICKLISP-CLIENT::*QUICKLOAD-VERBOSE* cannot
be easily modified while keeping in-sync with upstream, but they both
seem to respect setting CL:*LOAD-VERBOSE* to nil to muffle output.

EXT::*WARN-ON-REDEFINITION* signals conditions rather than just
emitting error messages, so it has not been touched as theoretically
some compiler tooling may be somehow be depending on its SIGNAL
behavior. As such, once an implementation that signals the same
warnings as EXT::*WARN-ON-REDEFINITION* based on CL:*COMPILE-VERBOSE*
setting should be maintained during a deprecation phase.


# From <https://github.com/armedbear/abcl/commit/6cc94a54cf9256b2a0f13857d4c448d3b5c044fc>

## Alan Ruttenberg

Really this should just respect load-verbose. If you really want to
fix this properly, do that. There are a proliferation of settings one
has to know about if one wants ABCL to shut up while starting up, and
any beginner will have a hell of a time accomplishing this. There
ought to be a single variable that indicates you don't want these
messages.

  • *load-verbose*
  • system::*verbose*
  • asdf::*verbose-out*
  • abcl-asdf::*maven-verbose
  • quicklisp-client::*quickload-verbose*
  • ext::*warn-on-redefinition*

## Mark Evenson

Using CL:LOAD-VERBOSE to unify the control of all this logging
behavior for ABCL is an excellent way forward here.

This wouldn't help with quicklisp-client::quickload-verbose (not our code).

An alternative would be to have some sort of "categorical logging
system" (ala log4j) which would allow one to selectively enable
classes of logging output ("show me all diagnostic from loading
ABCL-CONTRIB"), but a basic boolean predicate here, unified into the
standardized mechanism would go a long ways.


Originated with <https://github.com/armedbear/abcl/pull/37>.

File size: 6.4 KB
Line 
1(in-package :system)
2
3(require :asdf)
4
5(defconstant +get-classloader+
6  (java:jmethod "java.lang.Class" "getClassLoader"))
7
8(defun boot-classloader ()
9  (let ((boot-class (java:jclass "org.armedbear.lisp.Main")))
10    (java:jcall +get-classloader+ boot-class)))
11
12(defun system-jar-p (p)
13  (or (named-jar-p "abcl" p)
14      (named-jar-p "abcl-aio" p)))
15
16(defun contrib-jar-p (p)
17  (or 
18   (named-jar-p "abcl-contrib" p)
19   (named-jar-p "abcl-aio" p)))
20
21(defun named-jar-p (name p)
22  (and (pathnamep p)
23       (equal (pathname-type p) "jar")
24       (or
25        (java:jstatic "matches"
26                      "java.util.regex.Pattern"
27                      (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]([+~-].+)?)?")
28                      (pathname-name p))
29        (java:jstatic "matches"
30                      "java.util.regex.Pattern"
31                      (concatenate 'string name "(-[0-9]\\.[0-9]\\.[0-9]\\.[0-9]([+~-]+)?)?")
32                      (pathname-name p)))
33       p))
34
35(defun find-system ()
36  "Find the location of the Armed Bear system implementation
37
38Used to determine relative pathname to find 'abcl-contrib.jar'."
39  (or
40   (ignore-errors
41     (find-system-jar))
42   (ignore-errors
43     (some
44      (lambda (u)
45        (probe-file (make-pathname
46                     :defaults (java:jcall "toString" u)
47                     :name "abcl")))
48      (java:jcall "getURLs" (boot-classloader))))
49   (ignore-errors
50     #p"http://abcl.org/releases/current/abcl.jar")))
51
52(defun find-jar (predicate)
53  (dolist (loader (java:dump-classpath))
54    (let ((jar (some predicate loader)))
55      (when jar
56        (return jar)))))
57
58(defun find-system-jar ()
59  "Return the pathname of the system jar, one of `abcl.jar` or
60`abcl-m.n.p.jar` or `abcl-m.n.p[.~-]something.jar`."
61  (find-jar #'system-jar-p))
62
63(defun find-contrib-jar ()
64  "Return the pathname of the contrib jar, one of `abcl-contrib.jar` or
65`abcl-contrib-m.n.p.jar` or `abcl-contrib-m.n.p[.~-]something.jar`."
66  (find-jar #'contrib-jar-p))
67
68(defvar *abcl-contrib* nil
69  "Pathname of the abcl-contrib artifact.
70
71Initialized via SYSTEM:FIND-CONTRIB.")
72
73;;; FIXME: stop using the obsolete ASDF:*CENTRAL-REGISTRY*
74(defun add-contrib (abcl-contrib-jar
75                    &key (verbose cl:*load-verbose*))
76  "Introspects the ABCL-CONTRIB-JAR path for sub-directories which
77  contain asdf definitions, adding those found to asdf."
78  (let ((jar-path (if (ext:pathname-jar-p abcl-contrib-jar)
79                      abcl-contrib-jar
80                      (make-pathname :device (list abcl-contrib-jar)))))
81    (dolist (asdf-file
82             (directory (merge-pathnames "*/*.asd" jar-path)))
83      (let ((asdf-directory (make-pathname :defaults asdf-file :name nil :type nil)))
84        (unless (find asdf-directory asdf:*central-registry* :test #'equal)
85          (push asdf-directory asdf:*central-registry*)
86          (format verbose "~&; abcl-contrib; Added ~A to ASDF.~&" asdf-directory))))))
87
88(defun find-and-add-contrib (&key (verbose cl:*load-verbose*))
89  "Attempt to find the ABCL contrib jar and add its contents to ASDF.
90returns the pathname of the contrib if it can be found."
91   (if *abcl-contrib*
92       (format verbose "~&; abcl-contrib; Using already initialized value of SYS:*ABCL-CONTRIB* '~A'.~%"
93               *abcl-contrib*)
94       (progn
95         (let ((contrib (find-contrib)))
96           (when contrib
97             (format verbose "~&; abcl-contrib; Using probed value of SYS:*ABCL-CONTRIB* '~A'.~%"
98                     contrib)
99             (setf *abcl-contrib* contrib)))))
100   (when *abcl-contrib*  ;; For bootstrap compile there will be no contrib
101     (add-contrib *abcl-contrib*)))
102
103(defun find-name-for-implementation-title (file id)
104  "For a jar FILE containing a manifest, return the name of the
105  section which annotates 'Implementation-Title' whose string value is
106  ID."
107  (declare (type pathname file))
108  (let* ((jar (java:jnew "java.util.jar.JarFile" (namestring file)))
109         (manifest (java:jcall "getManifest" jar))
110         (entries (java:jcall "toArray"
111                              (java:jcall "entrySet"
112                                          (java:jcall "getEntries" manifest)))))
113    (dolist (entry 
114              (loop :for entry :across entries
115                 :collecting entry))
116      (let ((title (java:jcall "getValue"
117                               (java:jcall "getValue" entry)
118                               "Implementation-Title")))
119        (when (string-equal title id)
120          (return-from find-name-for-implementation-title
121            (java:jcall "getKey" entry))))
122    nil)))
123
124(defun find-contrib ()
125  "Introspect runtime classpaths to return a pathname containing
126  subdirectories containing ASDF definitions."
127
128  (or
129   ;; We identify the location of the directory within a jar file
130   ;; containing abcl-contrib ASDF definitions by looking for a section
131   ;; which contains the Implementation-Title "org.abcl-contrib".  The
132   ;; name of that section then identifies the relative pathname to the
133   ;; top-most directory in the Jar
134   ;;
135   ;; e.g. for an entry of the form
136   ;;
137   ;;     Name: contrib
138   ;;     Implementation-Title: org.abcl-contrib
139   ;;
140   ;; the directory 'contrib' would be searched for ASDF definitions.
141   (ignore-errors
142        (let* ((system-jar
143                (find-system-jar))
144               (relative-pathname 
145                (find-name-for-implementation-title system-jar "org.abcl-contrib")))
146          (when (and system-jar relative-pathname)
147            (merge-pathnames (pathname (concatenate 'string
148                                                   relative-pathname "/"))
149                            (make-pathname
150                             :device (list system-jar))))))
151   (ignore-errors
152     (find-contrib-jar))
153   (ignore-errors
154     (let ((system-jar (find-system-jar)))
155       (when system-jar
156         (probe-file (make-pathname
157                      :defaults system-jar
158                      :name (concatenate 'string
159                                         "abcl-contrib"
160                                         (subseq (pathname-name system-jar) 4)))))))
161   (some
162    (lambda (u)
163      (probe-file (make-pathname
164                   :defaults (java:jcall "toString" u)
165                   :name "abcl-contrib")))
166    (java:jcall "getURLs" (boot-classloader)))))
167
168(export '(find-system
169          find-contrib
170          *abcl-contrib*)
171        :system)
172
173(when (find-and-add-contrib :verbose cl:*load-verbose*)
174  (provide :abcl-contrib))
Note: See TracBrowser for help on using the repository browser.