source: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp

Last change on this file was 15105, checked in by Evenson Not Org, 17 months ago

Make use of warning muffling
(Olof-Joachim Frahm)

Merges <https://github.com/armedbear/abcl/pull/68>.

From <https://github.com/armedbear/abcl/pull/68/commits/c6e2dde2d824b3a74fc4a1d297c522cb38101d3f>.

File size: 6.4 KB
Line 
1;;;; The ABCL specific overrides in ASDF. 
2;;;;
3;;;; Extensions to ASDF for use by ABCL
4(require :asdf)
5(in-package :asdf)
6
7(defclass iri (component) 
8  ((schema :initform nil)
9   (authority :initform nil)
10   (path :initform nil)
11   (query :initform nil)
12   (fragment :initform nil)))
13
14(defclass mvn (iri) 
15  ((group-id :initarg :group-id :initform nil)
16   (artifact-id :initarg :artifact-id :initform nil)
17   (repositories :initarg :repositories :initform (list abcl-asdf::*default-repository*))
18   (resolved-classpath :initform nil :accessor resolved-classpath)
19   (classname :initarg :classname :initform nil)
20   (alternate-uri :initarg :alternate-uri :initform nil)
21   ;; inherited from ASDF:COMPONENT ??? what are the CL semantics on overriding -- ME 2012-04-01
22   #+nil   (version :initform nil)))
23
24(defmethod shared-initialize ((mvn mvn) slot-names &rest initargs &key (repository NIL repository-p) repositories &allow-other-keys)
25  (if repository-p
26      (let ((initargs (list* :repositories (cons repository repositories)
27                             (remove-plist-keys '(:repository :repositories) initargs))))
28        (apply #'call-next-method mvn slot-names initargs))
29      (call-next-method)))
30
31;;; We intercept compilation to ensure that load-op will succeed
32(defmethod perform ((op compile-op) (c mvn))
33  (unless (resolved-classpath c)
34    (setf (resolved-classpath c)
35          (abcl-asdf:resolve   
36           (ensure-parsed-mvn c)))))
37
38(defmethod perform ((operation load-op) (c mvn))
39  (let ((resolved-classpath (resolved-classpath c)))
40    (when (stringp resolved-classpath)
41      (java:add-to-classpath (abcl-asdf:as-classpath resolved-classpath)))))
42
43;;; A Maven URI has the form "mvn:group-id/artifact-id/version"
44;;;
45;;; Sometimes people write "group-id:artifact-id:version" to refer to
46;;; Maven artifacts.  One can use ABCL-ASDF:RESOLVE directly for
47;;; serialized references to artifacts of this form.
48;;;
49;;; Currently we "stuff" the group-id/artifact-id into the 'name' and
50;;; use the component 'version' for the version.  Parts of ASDF
51;;; *reallY* want ASDF:VERSION to be a triple of intergers, and never
52;;; anything more, so that is part of the motivation behind this effort.
53(defparameter *mvn-repositories* nil
54  "A list of all Maven repositories encountered in the lifetime of this instance of the implementation.")
55
56#+nil
57(defmethod slot-missing ((class mvn) object slot-name operation &optional new-value)
58  (setf (slot-value object slot-name) 
59        (if new-value
60            new-value
61            nil)))
62
63(defun ensure-parsed-mvn (component)
64  (with-slots (name group-id artifact-id
65                    version schema path repositories)
66      component
67    (when (null asdf::artifact-id) 
68      (let ((parsed (abcl-asdf::split-string name "/"))
69            (asdf-version-p (slot-boundp component 'version))
70            (default-version "LATEST"))
71        (cond ((= (length parsed) 3)
72               (setf 
73                group-id (first parsed)
74                artifact-id (second parsed)
75                version (third parsed)))
76              ((= (length parsed) 2)
77               (setf 
78                group-id (first parsed)
79                artifact-id (second parsed)
80                version (if asdf-version-p
81                            version
82                            default-version)))
83              (t
84               (error "Failed to construct a mvn reference from name '~A' and version '~A'"
85                      name version)))
86        (setf schema "mvn")
87        (when repositories
88          (setf *mvn-repositories* (union repositories *mvn-repositories* :test #'string=)))
89        ;;; Always set path to normalized path "on the way out" to
90        ;;; contain group-id/artifact-id/version
91        ;;; TODO? record repository as well in path of component
92        (setf path (format nil "~A/~A/~A" group-id artifact-id version))))
93    component))
94
95(eval-when (:compile-toplevel :load-toplevel :execute)
96  (export `(mvn iri ensure-parsed-mvn group-id artifact-id version) 
97          'asdf))
98
99(defmethod source-file-type ((component iri) (system system))
100  nil)
101
102(defmethod component-relative-pathname ((component iri))
103  nil)
104
105(in-package #:abcl-asdf)
106
107(defgeneric resolve (something)
108  (:documentation "Returns a string in JVM CLASSPATH format as entries delimited by classpath separator string."))
109
110(defmethod resolve ((mvn-component asdf::mvn))
111  "Resolve all runtime dependencies of MVN-COMPONENT.
112
113Returns either a string in jvm classpath format as entries delimited
114by classpath separator string or T.  If the value T is returned, it
115denotes that current JVM already has already loaded a given class. Can possibly be a
116single entry denoting a remote binary artifact."
117  (asdf::ensure-parsed-mvn mvn-component)
118  (let ((name (slot-value mvn-component 'asdf::name))
119        (group-id (slot-value mvn-component 'asdf::group-id))
120        (artifact-id (slot-value mvn-component 'asdf::artifact-id))
121        (classname (slot-value mvn-component 'asdf::classname))
122        (alternate-uri (slot-value mvn-component 'asdf::alternate-uri))
123        (repositories (slot-value mvn-component 'asdf::repositories))
124        (version (if (slot-value mvn-component 'asdf::version)
125                     (slot-value mvn-component 'asdf::version)
126                     "LATEST")))
127    (handler-case 
128        (when (and classname 
129                   (let ((jss:*muffle-warnings* T))
130                     (jss:find-java-class classname)))
131          (warn "Not loading ~A from the network because ~A is present in classpath."
132                name classname)
133          (return-from resolve t))
134      (java:java-exception (e)
135        (unless (java:jinstance-of-p (java:java-exception-cause e)
136                                     "java.lang.ClassNotFoundException")
137          (error "Unexpected Java exception~&~A.~&" e))))
138    (if (find-mvn)
139        (resolve-dependencies group-id artifact-id
140                              :version version
141                              :repository NIL
142                              :repositories repositories)
143        (if alternate-uri
144            (values (pathname alternate-uri) alternate-uri) 
145            (error "Failed to resolve MVN component name ~A." name)))))
146
147(defmethod resolve ((uri pathname))
148  (warn "Unimplemented."))
149
150(defun as-classpath (classpath)
151  "Break apart the JVM CLASSPATH string into a list of its consituents."
152  (split-string classpath 
153                (java:jfield "java.io.File" "pathSeparator")))
154
Note: See TracBrowser for help on using the repository browser.