source: tags/1.5.0/contrib/abcl-asdf/asdf-jar.lisp

Last change on this file was 15008, checked in by Mark Evenson, 7 years ago

Normalize ASDF definitions to follow best practices

c.f. <https://gitlab.common-lisp.net/asdf/asdf/blob/master/doc/best_practices.md>

File size: 4.2 KB
Line 
1(in-package :abcl-asdf)
2
3(defvar *added-to-classpath* nil)
4
5(defvar *inhibit-add-to-classpath* nil)
6
7(defun add-directory-jars-to-class-path (directory recursive-p)
8  (loop :for jar :in (if recursive-p 
9                         (all-jars-below directory) 
10                         (directory (merge-pathnames "*.jar" directory)))
11     :do (java:add-to-classpath jar)))
12
13(defun all-jars-below (directory) 
14  (loop :with q = (system:list-directory directory) 
15     :while q :for top = (pop q)
16     :if (null (pathname-name top)) 
17     :do (setq q (append q (all-jars-below top))) 
18     :if (equal (pathname-type top) "jar") 
19     :collect top))
20
21(defun need-to-add-directory-jar? (directory recursive-p)
22  (loop :for jar :in (if recursive-p 
23                         (all-jars-below directory)
24                         (directory (merge-pathnames "*.jar" directory)))
25     :doing (if (not (member (namestring (truename jar)) 
26                             *added-to-classpath* :test 'equal))
27                (return-from need-to-add-directory-jar? t)))
28  nil)
29
30(defmethod java:add-to-classpath :around ((uri-or-uris t) &optional classloader)
31  (declare (ignore classloader))
32  (call-next-method)
33  (if (listp uri-or-uris)
34      (dolist (uri uri-or-uris)
35        (pushnew uri *added-to-classpath*))
36      (pushnew uri-or-uris *added-to-classpath*)))
37
38(in-package :asdf)
39
40(defclass jar-directory (static-file) ())
41
42(defmethod perform ((operation compile-op) (c jar-directory))
43  (unless abcl-asdf:*inhibit-add-to-classpath*
44    (abcl-asdf:add-directory-jars-to-class-path (truename (component-pathname c)) t)))
45
46(defmethod perform ((operation load-op) (c jar-directory))
47  (unless abcl-asdf:*inhibit-add-to-classpath*
48    (abcl-asdf:add-directory-jars-to-class-path (truename (component-pathname c)) t)))
49
50(defmethod operation-done-p ((operation load-op) (c jar-directory))
51  (or abcl-asdf:*inhibit-add-to-classpath*
52      (not (abcl-asdf:need-to-add-directory-jar? (component-pathname c) t))))
53
54(defmethod operation-done-p ((operation compile-op) (c jar-directory))
55  t)
56
57(defclass jar-file (static-file)
58  ((type :initform "jar")))
59
60(defmethod perform ((operation compile-op) (c jar-file))
61  (java:add-to-classpath (component-pathname c)))
62
63(defmethod perform ((operation load-op) (c jar-file))
64  (or abcl-asdf:*inhibit-add-to-classpath*
65      (java:add-to-classpath (component-pathname c))))
66
67;;; The original JSS specified jar pathnames as having a NAME ending
68;;; in ".jar" without a TYPE.  If we encounter such a definition, we
69;;; clean it up.
70(defmethod normalize-jar-name ((component jar-file))
71  (when (#"endsWith" (slot-value component 'name) ".jar")
72    (with-slots (name absolute-pathname) component
73      (let* ((new-name 
74              (subseq name 0 (- (length name) 4)))
75             (new-absolute-pathname 
76              (make-pathname :defaults absolute-pathname :name new-name)))
77        (setf name new-name
78              absolute-pathname new-absolute-pathname)))))
79
80(defmethod perform :before ((operation compile-op) (c jar-file))
81  (normalize-jar-name c))
82
83(defmethod perform :before ((operation load-op) (c jar-file))
84  (normalize-jar-name c))
85
86(defmethod operation-done-p :before ((operation load-op) (c jar-file))
87  (normalize-jar-name c))
88
89(defmethod operation-done-p ((operation load-op) (c jar-file))
90  (or abcl-asdf:*inhibit-add-to-classpath*
91      (member (namestring (truename (component-pathname c)))
92              abcl-asdf:*added-to-classpath* :test 'equal)))
93
94(defmethod operation-done-p ((operation compile-op) (c jar-file))
95  t)
96
97(defclass class-file-directory (static-file) ())
98
99(defmethod perform ((operation compile-op) (c class-file-directory))
100  (java:add-to-classpath (component-pathname c)))
101
102(defmethod perform ((operation load-op) (c class-file-directory))
103  (java:add-to-classpath (component-pathname c)))
104
105;; a jar file where the pathname and name are relative to JAVA_HOME
106(defclass jdk-jar (jar-file) ())
107
108(defmethod normalize-jar-name :after ((c jdk-jar))
109  (setf (slot-value c 'absolute-pathname)
110  (merge-pathnames
111   (merge-pathnames 
112    (slot-value c 'name)
113    (make-pathname :directory `(:relative ,(slot-value (component-parent c) 'relative-pathname))))
114   (java::jstatic "getProperty" "java.lang.System" "java.home"))))
115
116
117       
Note: See TracBrowser for help on using the repository browser.