Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 254 lines (223 sloc) 9.408 kb
479bb23 Stuart Halloway #453 reflection
stuarthalloway authored
1 ; Copyright (c) Rich Hickey. All rights reserved.
2 ; The use and distribution terms for this software are covered by the
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 ; which can be found in the file epl-v10.html at the root of this distribution.
5 ; By using this software in any fashion, you are agreeing to be bound by
6 ; the terms of this license.
7 ; You must not remove this notice, or any other, from this software.
8
9 ;; Java-specific parts of clojure.reflect
10 (in-ns 'clojure.reflect)
11
12 (require '[clojure.set :as set]
13 '[clojure.string :as str])
14 (import '[clojure.asm ClassReader ClassVisitor Type]
15 '[java.lang.reflect Modifier]
16 java.io.InputStream)
17
18 (extend-protocol TypeReference
19 clojure.lang.Symbol
20 (typename [s] (str/replace (str s) "<>" "[]"))
21
22 Class
23 ;; neither .getName not .getSimpleName returns the right thing, so best to delegate to Type
24 (typename
25 [c]
26 (typename (Type/getType c)))
27
28 Type
29 (typename
30 [t]
31 (-> (.getClassName t))))
32
33 (defn- typesym
34 "Given a typeref, create a legal Clojure symbol version of the
35 type's name."
36 [t]
37 (-> (typename t)
38 (str/replace "[]" "<>")
39 (symbol)))
40
41 (defn- resource-name
42 "Given a typeref, return implied resource name. Used by Reflectors
43 such as ASM that need to find and read classbytes from files."
44 [typeref]
45 (-> (typename typeref)
46 (str/replace "." "/")
47 (str ".class")))
48
49 (defn- access-flag
50 [[name flag & contexts]]
51 {:name name :flag flag :contexts (set (map keyword contexts))})
52
53 (defn- field-descriptor->class-symbol
54 "Convert a Java field descriptor to a Clojure class symbol. Field
55 descriptors are described in section 4.3.2 of the JVM spec, 2nd ed.:
56 http://java.sun.com/docs/books/jvms/second_edition/html/ClassFile.doc.html#14152"
57 [^String d]
58 {:pre [(string? d)]}
59 (typesym (Type/getType d)))
60
61 (defn- internal-name->class-symbol
62 "Convert a Java internal name to a Clojure class symbol. Internal
63 names uses slashes instead of dots, e.g. java/lang/String. See
64 Section 4.2 of the JVM spec, 2nd ed.:
65
66 http://java.sun.com/docs/books/jvms/second_edition/html/ClassFile.doc.html#14757"
67 [d]
68 {:pre [(string? d)]}
69 (typesym (Type/getObjectType d)))
70
71 (def ^{:doc "The Java access bitflags, along with their friendly names and
72 the kinds of objects to which they can apply."}
73 flag-descriptors
74 (vec
75 (map access-flag
76 [[:public 0x0001 :class :field :method]
77 [:private 0x002 :class :field :method]
78 [:protected 0x0004 :class :field :method]
79 [:static 0x0008 :field :method]
80 [:final 0x0010 :class :field :method]
81 ;; :super is ancient history and is unfindable (?) by
82 ;; reflection. skip it
83 #_[:super 0x0020 :class]
84 [:synchronized 0x0020 :method]
85 [:volatile 0x0040 :field]
86 [:bridge 0x0040 :method]
87 [:varargs 0x0080 :method]
88 [:transient 0x0080 :field]
89 [:native 0x0100 :method]
90 [:interface 0x0200 :class]
91 [:abstract 0x0400 :class :method]
92 [:strict 0x0800 :method]
93 [:synthetic 0x1000 :class :field :method]
94 [:annotation 0x2000 :class]
95 [:enum 0x4000 :class :field :inner]])))
96
97 (defn- parse-flags
98 "Convert reflection bitflags into a set of keywords."
99 [flags context]
100 (reduce
101 (fn [result fd]
102 (if (and (get (:contexts fd) context)
103 (not (zero? (bit-and flags (:flag fd)))))
104 (conj result (:name fd))
105 result))
106 #{}
107 flag-descriptors))
108
109 (defrecord Constructor
110 [name declaring-class parameter-types exception-types flags])
111
112 (defn- constructor->map
113 [^java.lang.reflect.Constructor constructor]
114 (Constructor.
115 (symbol (.getName constructor))
116 (typesym (.getDeclaringClass constructor))
117 (vec (map typesym (.getParameterTypes constructor)))
118 (vec (map typesym (.getExceptionTypes constructor)))
119 (parse-flags (.getModifiers constructor) :method)))
120
121 (defn- declared-constructors
122 "Return a set of the declared constructors of class as a Clojure map."
123 [^Class cls]
124 (set (map
125 constructor->map
126 (.getDeclaredConstructors cls))))
127
128 (defrecord Method
129 [name return-type declaring-class parameter-types exception-types flags])
130
131 (defn- method->map
132 [^java.lang.reflect.Method method]
133 (Method.
134 (symbol (.getName method))
135 (typesym (.getReturnType method))
136 (typesym (.getDeclaringClass method))
137 (vec (map typesym (.getParameterTypes method)))
138 (vec (map typesym (.getExceptionTypes method)))
139 (parse-flags (.getModifiers method) :method)))
140
141 (defn- declared-methods
142 "Return a set of the declared constructors of class as a Clojure map."
143 [^Class cls]
144 (set (map
145 method->map
146 (.getDeclaredMethods cls))))
147
148 (defrecord Field
149 [name type declaring-class flags])
150
151 (defn- field->map
152 [^java.lang.reflect.Field field]
153 (Field.
154 (symbol (.getName field))
155 (typesym (.getType field))
156 (typesym (.getDeclaringClass field))
157 (parse-flags (.getModifiers field) :field)))
158
159 (defn- declared-fields
160 "Return a set of the declared fields of class as a Clojure map."
161 [^Class cls]
162 (set (map
163 field->map
164 (.getDeclaredFields cls))))
165
166 (deftype JavaReflector [classloader]
167 Reflector
168 (do-reflect [_ typeref]
169 (let [cls (Class/forName (typename typeref) false classloader)]
170 {:bases (not-empty (set (map typesym (bases cls))))
171 :flags (parse-flags (.getModifiers cls) :class)
172 :members (set/union (declared-fields cls)
173 (declared-methods cls)
174 (declared-constructors cls))})))
175
176 (def ^:private default-reflector
177 (JavaReflector. (.getContextClassLoader (Thread/currentThread))))
178
179 (defn- parse-method-descriptor
180 [^String md]
181 {:parameter-types (vec (map typesym (Type/getArgumentTypes md)))
182 :return-type (typesym (Type/getReturnType md))})
183
184 (defprotocol ClassResolver
185 (^InputStream resolve-class [this name]
186 "Given a class name, return that typeref's class bytes as an InputStream."))
187
188 (extend-protocol ClassResolver
189 clojure.lang.Fn
190 (resolve-class [this typeref] (this typeref))
191
192 ClassLoader
193 (resolve-class [this typeref]
194 (.getResourceAsStream this (resource-name typeref))))
195
196 (deftype AsmReflector [class-resolver]
197 Reflector
198 (do-reflect [_ typeref]
199 (with-open [is (resolve-class class-resolver typeref)]
200 (let [class-symbol (typesym typeref)
201 r (ClassReader. is)
202 result (atom {:bases #{} :flags #{} :members #{}})]
203 (.accept
204 r
205 (reify
206 ClassVisitor
207 (visit [_ version access name signature superName interfaces]
208 (let [flags (parse-flags access :class)
209 ;; ignore java.lang.Object on interfaces to match reflection
210 superName (if (and (flags :interface)
211 (= superName "java/lang/Object"))
212 nil
213 superName)
214 bases (->> (cons superName interfaces)
215 (remove nil?)
216 (map internal-name->class-symbol)
217 (map symbol)
218 (set)
219 (not-empty))]
220 (swap! result merge {:bases bases
221 :flags flags})))
222 (visitSource [_ name debug])
223 (visitInnerClass [_ name outerName innerName access])
224 (visitField [_ access name desc signature value]
225 (swap! result update-in [:members] (fnil conj #{})
226 (Field. (symbol name)
227 (field-descriptor->class-symbol desc)
228 class-symbol
229 (parse-flags access :field)))
230 nil)
231 (visitMethod [_ access name desc signature exceptions]
232 (when-not (= name "<clinit>")
233 (let [constructor? (= name "<init>")]
234 (swap! result update-in [:members] (fnil conj #{})
235 (let [{:keys [parameter-types return-type]} (parse-method-descriptor desc)
236 flags (parse-flags access :method)]
237 (if constructor?
238 (Constructor. class-symbol
239 class-symbol
240 parameter-types
241 (vec (map internal-name->class-symbol exceptions))
242 flags)
243 (Method. (symbol name)
244 return-type
245 class-symbol
246 parameter-types
247 (vec (map internal-name->class-symbol exceptions))
248 flags))))))
249 nil)
250 (visitEnd [_])
251 ) 0)
252 @result))))
253
Something went wrong with that request. Please try again.