|
rlm@10
|
1 ; Copyright (c) Rich Hickey. All rights reserved.
|
|
rlm@10
|
2 ; The use and distribution terms for this software are covered by the
|
|
rlm@10
|
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
|
rlm@10
|
4 ; which can be found in the file epl-v10.html at the root of this distribution.
|
|
rlm@10
|
5 ; By using this software in any fashion, you are agreeing to be bound by
|
|
rlm@10
|
6 ; the terms of this license.
|
|
rlm@10
|
7 ; You must not remove this notice, or any other, from this software.
|
|
rlm@10
|
8
|
|
rlm@10
|
9 (in-ns 'clojure.core)
|
|
rlm@10
|
10
|
|
rlm@10
|
11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; proxy ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
12
|
|
rlm@10
|
13 (import
|
|
rlm@10
|
14 '(clojure.asm ClassWriter ClassVisitor Opcodes Type)
|
|
rlm@10
|
15 '(java.lang.reflect Modifier Constructor)
|
|
rlm@10
|
16 '(clojure.asm.commons Method GeneratorAdapter)
|
|
rlm@10
|
17 '(clojure.lang IProxy Reflector DynamicClassLoader IPersistentMap PersistentHashMap RT))
|
|
rlm@10
|
18
|
|
rlm@10
|
19 (defn method-sig [^java.lang.reflect.Method meth]
|
|
rlm@10
|
20 [(. meth (getName)) (seq (. meth (getParameterTypes))) (. meth getReturnType)])
|
|
rlm@10
|
21
|
|
rlm@10
|
22 (defn- most-specific [rtypes]
|
|
rlm@10
|
23 (or (some (fn [t] (when (every? #(isa? t %) rtypes) t)) rtypes)
|
|
rlm@10
|
24 (throw (Exception. "Incompatible return types"))))
|
|
rlm@10
|
25
|
|
rlm@10
|
26 (defn- group-by-sig [coll]
|
|
rlm@10
|
27 "takes a collection of [msig meth] and returns a seq of maps from return-types to meths."
|
|
rlm@10
|
28 (vals (reduce (fn [m [msig meth]]
|
|
rlm@10
|
29 (let [rtype (peek msig)
|
|
rlm@10
|
30 argsig (pop msig)]
|
|
rlm@10
|
31 (assoc m argsig (assoc (m argsig {}) rtype meth))))
|
|
rlm@10
|
32 {} coll)))
|
|
rlm@10
|
33
|
|
rlm@10
|
34 (defn proxy-name
|
|
rlm@10
|
35 {:tag String}
|
|
rlm@10
|
36 [^Class super interfaces]
|
|
rlm@10
|
37 (let [inames (into (sorted-set) (map #(.getName ^Class %) interfaces))]
|
|
rlm@10
|
38 (apply str (.replace (str *ns*) \- \_) ".proxy"
|
|
rlm@10
|
39 (interleave (repeat "$")
|
|
rlm@10
|
40 (concat
|
|
rlm@10
|
41 [(.getName super)]
|
|
rlm@10
|
42 (map #(subs % (inc (.lastIndexOf ^String % "."))) inames)
|
|
rlm@10
|
43 [(Integer/toHexString (hash inames))])))))
|
|
rlm@10
|
44
|
|
rlm@10
|
45 (defn- generate-proxy [^Class super interfaces]
|
|
rlm@10
|
46 (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
|
|
rlm@10
|
47 cname (.replace (proxy-name super interfaces) \. \/) ;(str "clojure/lang/" (gensym "Proxy__"))
|
|
rlm@10
|
48 ctype (. Type (getObjectType cname))
|
|
rlm@10
|
49 iname (fn [^Class c] (.. Type (getType c) (getInternalName)))
|
|
rlm@10
|
50 fmap "__clojureFnMap"
|
|
rlm@10
|
51 totype (fn [^Class c] (. Type (getType c)))
|
|
rlm@10
|
52 to-types (fn [cs] (if (pos? (count cs))
|
|
rlm@10
|
53 (into-array (map totype cs))
|
|
rlm@10
|
54 (make-array Type 0)))
|
|
rlm@10
|
55 super-type ^Type (totype super)
|
|
rlm@10
|
56 imap-type ^Type (totype IPersistentMap)
|
|
rlm@10
|
57 ifn-type (totype clojure.lang.IFn)
|
|
rlm@10
|
58 obj-type (totype Object)
|
|
rlm@10
|
59 sym-type (totype clojure.lang.Symbol)
|
|
rlm@10
|
60 rt-type (totype clojure.lang.RT)
|
|
rlm@10
|
61 ex-type (totype java.lang.UnsupportedOperationException)
|
|
rlm@10
|
62 gen-bridge
|
|
rlm@10
|
63 (fn [^java.lang.reflect.Method meth ^java.lang.reflect.Method dest]
|
|
rlm@10
|
64 (let [pclasses (. meth (getParameterTypes))
|
|
rlm@10
|
65 ptypes (to-types pclasses)
|
|
rlm@10
|
66 rtype ^Type (totype (. meth (getReturnType)))
|
|
rlm@10
|
67 m (new Method (. meth (getName)) rtype ptypes)
|
|
rlm@10
|
68 dtype (totype (.getDeclaringClass dest))
|
|
rlm@10
|
69 dm (new Method (. dest (getName)) (totype (. dest (getReturnType))) (to-types (. dest (getParameterTypes))))
|
|
rlm@10
|
70 gen (new GeneratorAdapter (bit-or (. Opcodes ACC_PUBLIC) (. Opcodes ACC_BRIDGE)) m nil nil cv)]
|
|
rlm@10
|
71 (. gen (visitCode))
|
|
rlm@10
|
72 (. gen (loadThis))
|
|
rlm@10
|
73 (dotimes [i (count ptypes)]
|
|
rlm@10
|
74 (. gen (loadArg i)))
|
|
rlm@10
|
75 (if (-> dest .getDeclaringClass .isInterface)
|
|
rlm@10
|
76 (. gen (invokeInterface dtype dm))
|
|
rlm@10
|
77 (. gen (invokeVirtual dtype dm)))
|
|
rlm@10
|
78 (. gen (returnValue))
|
|
rlm@10
|
79 (. gen (endMethod))))
|
|
rlm@10
|
80 gen-method
|
|
rlm@10
|
81 (fn [^java.lang.reflect.Method meth else-gen]
|
|
rlm@10
|
82 (let [pclasses (. meth (getParameterTypes))
|
|
rlm@10
|
83 ptypes (to-types pclasses)
|
|
rlm@10
|
84 rtype ^Type (totype (. meth (getReturnType)))
|
|
rlm@10
|
85 m (new Method (. meth (getName)) rtype ptypes)
|
|
rlm@10
|
86 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
|
|
rlm@10
|
87 else-label (. gen (newLabel))
|
|
rlm@10
|
88 end-label (. gen (newLabel))
|
|
rlm@10
|
89 decl-type (. Type (getType (. meth (getDeclaringClass))))]
|
|
rlm@10
|
90 (. gen (visitCode))
|
|
rlm@10
|
91 (if (> (count pclasses) 18)
|
|
rlm@10
|
92 (else-gen gen m)
|
|
rlm@10
|
93 (do
|
|
rlm@10
|
94 (. gen (loadThis))
|
|
rlm@10
|
95 (. gen (getField ctype fmap imap-type))
|
|
rlm@10
|
96
|
|
rlm@10
|
97 (. gen (push (. meth (getName))))
|
|
rlm@10
|
98 ;lookup fn in map
|
|
rlm@10
|
99 (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)"))))
|
|
rlm@10
|
100 (. gen (dup))
|
|
rlm@10
|
101 (. gen (ifNull else-label))
|
|
rlm@10
|
102 ;if found
|
|
rlm@10
|
103 (.checkCast gen ifn-type)
|
|
rlm@10
|
104 (. gen (loadThis))
|
|
rlm@10
|
105 ;box args
|
|
rlm@10
|
106 (dotimes [i (count ptypes)]
|
|
rlm@10
|
107 (. gen (loadArg i))
|
|
rlm@10
|
108 (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
|
|
rlm@10
|
109 ;call fn
|
|
rlm@10
|
110 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type
|
|
rlm@10
|
111 (into-array (cons obj-type
|
|
rlm@10
|
112 (replicate (count ptypes) obj-type))))))
|
|
rlm@10
|
113 ;unbox return
|
|
rlm@10
|
114 (. gen (unbox rtype))
|
|
rlm@10
|
115 (when (= (. rtype (getSort)) (. Type VOID))
|
|
rlm@10
|
116 (. gen (pop)))
|
|
rlm@10
|
117 (. gen (goTo end-label))
|
|
rlm@10
|
118
|
|
rlm@10
|
119 ;else call supplied alternative generator
|
|
rlm@10
|
120 (. gen (mark else-label))
|
|
rlm@10
|
121 (. gen (pop))
|
|
rlm@10
|
122
|
|
rlm@10
|
123 (else-gen gen m)
|
|
rlm@10
|
124
|
|
rlm@10
|
125 (. gen (mark end-label))))
|
|
rlm@10
|
126 (. gen (returnValue))
|
|
rlm@10
|
127 (. gen (endMethod))))]
|
|
rlm@10
|
128
|
|
rlm@10
|
129 ;start class definition
|
|
rlm@10
|
130 (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
|
|
rlm@10
|
131 cname nil (iname super)
|
|
rlm@10
|
132 (into-array (map iname (cons IProxy interfaces)))))
|
|
rlm@10
|
133 ;add field for fn mappings
|
|
rlm@10
|
134 (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE))
|
|
rlm@10
|
135 fmap (. imap-type (getDescriptor)) nil nil))
|
|
rlm@10
|
136 ;add ctors matching/calling super's
|
|
rlm@10
|
137 (doseq [^Constructor ctor (. super (getDeclaredConstructors))]
|
|
rlm@10
|
138 (when-not (. Modifier (isPrivate (. ctor (getModifiers))))
|
|
rlm@10
|
139 (let [ptypes (to-types (. ctor (getParameterTypes)))
|
|
rlm@10
|
140 m (new Method "<init>" (. Type VOID_TYPE) ptypes)
|
|
rlm@10
|
141 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
|
|
rlm@10
|
142 (. gen (visitCode))
|
|
rlm@10
|
143 ;call super ctor
|
|
rlm@10
|
144 (. gen (loadThis))
|
|
rlm@10
|
145 (. gen (dup))
|
|
rlm@10
|
146 (. gen (loadArgs))
|
|
rlm@10
|
147 (. gen (invokeConstructor super-type m))
|
|
rlm@10
|
148
|
|
rlm@10
|
149 (. gen (returnValue))
|
|
rlm@10
|
150 (. gen (endMethod)))))
|
|
rlm@10
|
151 ;add IProxy methods
|
|
rlm@10
|
152 (let [m (. Method (getMethod "void __initClojureFnMappings(clojure.lang.IPersistentMap)"))
|
|
rlm@10
|
153 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
|
|
rlm@10
|
154 (. gen (visitCode))
|
|
rlm@10
|
155 (. gen (loadThis))
|
|
rlm@10
|
156 (. gen (loadArgs))
|
|
rlm@10
|
157 (. gen (putField ctype fmap imap-type))
|
|
rlm@10
|
158
|
|
rlm@10
|
159 (. gen (returnValue))
|
|
rlm@10
|
160 (. gen (endMethod)))
|
|
rlm@10
|
161 (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)"))
|
|
rlm@10
|
162 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
|
|
rlm@10
|
163 (. gen (visitCode))
|
|
rlm@10
|
164 (. gen (loadThis))
|
|
rlm@10
|
165 (. gen (dup))
|
|
rlm@10
|
166 (. gen (getField ctype fmap imap-type))
|
|
rlm@10
|
167 (.checkCast gen (totype clojure.lang.IPersistentCollection))
|
|
rlm@10
|
168 (. gen (loadArgs))
|
|
rlm@10
|
169 (. gen (invokeInterface (totype clojure.lang.IPersistentCollection)
|
|
rlm@10
|
170 (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)"))))
|
|
rlm@10
|
171 (. gen (checkCast imap-type))
|
|
rlm@10
|
172 (. gen (putField ctype fmap imap-type))
|
|
rlm@10
|
173
|
|
rlm@10
|
174 (. gen (returnValue))
|
|
rlm@10
|
175 (. gen (endMethod)))
|
|
rlm@10
|
176 (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()"))
|
|
rlm@10
|
177 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
|
|
rlm@10
|
178 (. gen (visitCode))
|
|
rlm@10
|
179 (. gen (loadThis))
|
|
rlm@10
|
180 (. gen (getField ctype fmap imap-type))
|
|
rlm@10
|
181 (. gen (returnValue))
|
|
rlm@10
|
182 (. gen (endMethod)))
|
|
rlm@10
|
183
|
|
rlm@10
|
184 ;calc set of supers' non-private instance methods
|
|
rlm@10
|
185 (let [[mm considered]
|
|
rlm@10
|
186 (loop [mm {} considered #{} c super]
|
|
rlm@10
|
187 (if c
|
|
rlm@10
|
188 (let [[mm considered]
|
|
rlm@10
|
189 (loop [mm mm
|
|
rlm@10
|
190 considered considered
|
|
rlm@10
|
191 meths (concat
|
|
rlm@10
|
192 (seq (. c (getDeclaredMethods)))
|
|
rlm@10
|
193 (seq (. c (getMethods))))]
|
|
rlm@10
|
194 (if (seq meths)
|
|
rlm@10
|
195 (let [^java.lang.reflect.Method meth (first meths)
|
|
rlm@10
|
196 mods (. meth (getModifiers))
|
|
rlm@10
|
197 mk (method-sig meth)]
|
|
rlm@10
|
198 (if (or (considered mk)
|
|
rlm@10
|
199 (not (or (Modifier/isPublic mods) (Modifier/isProtected mods)))
|
|
rlm@10
|
200 ;(. Modifier (isPrivate mods))
|
|
rlm@10
|
201 (. Modifier (isStatic mods))
|
|
rlm@10
|
202 (. Modifier (isFinal mods))
|
|
rlm@10
|
203 (= "finalize" (.getName meth)))
|
|
rlm@10
|
204 (recur mm (conj considered mk) (next meths))
|
|
rlm@10
|
205 (recur (assoc mm mk meth) (conj considered mk) (next meths))))
|
|
rlm@10
|
206 [mm considered]))]
|
|
rlm@10
|
207 (recur mm considered (. c (getSuperclass))))
|
|
rlm@10
|
208 [mm considered]))
|
|
rlm@10
|
209 ifaces-meths (into {}
|
|
rlm@10
|
210 (for [^Class iface interfaces meth (. iface (getMethods))
|
|
rlm@10
|
211 :let [msig (method-sig meth)] :when (not (considered msig))]
|
|
rlm@10
|
212 {msig meth}))
|
|
rlm@10
|
213 mgroups (group-by-sig (concat mm ifaces-meths))
|
|
rlm@10
|
214 rtypes (map #(most-specific (keys %)) mgroups)
|
|
rlm@10
|
215 mb (map #(vector (%1 %2) (vals (dissoc %1 %2))) mgroups rtypes)
|
|
rlm@10
|
216 bridge? (reduce into #{} (map second mb))
|
|
rlm@10
|
217 ifaces-meths (remove bridge? (vals ifaces-meths))
|
|
rlm@10
|
218 mm (remove bridge? (vals mm))]
|
|
rlm@10
|
219 ;add methods matching supers', if no mapping -> call super
|
|
rlm@10
|
220 (doseq [[^java.lang.reflect.Method dest bridges] mb
|
|
rlm@10
|
221 ^java.lang.reflect.Method meth bridges]
|
|
rlm@10
|
222 (gen-bridge meth dest))
|
|
rlm@10
|
223 (doseq [^java.lang.reflect.Method meth mm]
|
|
rlm@10
|
224 (gen-method meth
|
|
rlm@10
|
225 (fn [^GeneratorAdapter gen ^Method m]
|
|
rlm@10
|
226 (. gen (loadThis))
|
|
rlm@10
|
227 ;push args
|
|
rlm@10
|
228 (. gen (loadArgs))
|
|
rlm@10
|
229 ;call super
|
|
rlm@10
|
230 (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL)
|
|
rlm@10
|
231 (. super-type (getInternalName))
|
|
rlm@10
|
232 (. m (getName))
|
|
rlm@10
|
233 (. m (getDescriptor)))))))
|
|
rlm@10
|
234
|
|
rlm@10
|
235 ;add methods matching interfaces', if no mapping -> throw
|
|
rlm@10
|
236 (doseq [^java.lang.reflect.Method meth ifaces-meths]
|
|
rlm@10
|
237 (gen-method meth
|
|
rlm@10
|
238 (fn [^GeneratorAdapter gen ^Method m]
|
|
rlm@10
|
239 (. gen (throwException ex-type (. m (getName))))))))
|
|
rlm@10
|
240
|
|
rlm@10
|
241 ;finish class def
|
|
rlm@10
|
242 (. cv (visitEnd))
|
|
rlm@10
|
243 [cname (. cv toByteArray)]))
|
|
rlm@10
|
244
|
|
rlm@10
|
245 (defn- get-super-and-interfaces [bases]
|
|
rlm@10
|
246 (if (. ^Class (first bases) (isInterface))
|
|
rlm@10
|
247 [Object bases]
|
|
rlm@10
|
248 [(first bases) (next bases)]))
|
|
rlm@10
|
249
|
|
rlm@10
|
250 (defn get-proxy-class
|
|
rlm@10
|
251 "Takes an optional single class followed by zero or more
|
|
rlm@10
|
252 interfaces. If not supplied class defaults to Object. Creates an
|
|
rlm@10
|
253 returns an instance of a proxy class derived from the supplied
|
|
rlm@10
|
254 classes. The resulting value is cached and used for any subsequent
|
|
rlm@10
|
255 requests for the same class set. Returns a Class object."
|
|
rlm@10
|
256 {:added "1.0"}
|
|
rlm@10
|
257 [& bases]
|
|
rlm@10
|
258 (let [[super interfaces] (get-super-and-interfaces bases)
|
|
rlm@10
|
259 pname (proxy-name super interfaces)]
|
|
rlm@10
|
260 (or (RT/loadClassForName pname)
|
|
rlm@10
|
261 (let [[cname bytecode] (generate-proxy super interfaces)]
|
|
rlm@10
|
262 (. ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) (defineClass pname bytecode [super interfaces]))))))
|
|
rlm@10
|
263
|
|
rlm@10
|
264 (defn construct-proxy
|
|
rlm@10
|
265 "Takes a proxy class and any arguments for its superclass ctor and
|
|
rlm@10
|
266 creates and returns an instance of the proxy."
|
|
rlm@10
|
267 {:added "1.0"}
|
|
rlm@10
|
268 [c & ctor-args]
|
|
rlm@10
|
269 (. Reflector (invokeConstructor c (to-array ctor-args))))
|
|
rlm@10
|
270
|
|
rlm@10
|
271 (defn init-proxy
|
|
rlm@10
|
272 "Takes a proxy instance and a map of strings (which must
|
|
rlm@10
|
273 correspond to methods of the proxy superclass/superinterfaces) to
|
|
rlm@10
|
274 fns (which must take arguments matching the corresponding method,
|
|
rlm@10
|
275 plus an additional (explicit) first arg corresponding to this, and
|
|
rlm@10
|
276 sets the proxy's fn map."
|
|
rlm@10
|
277 {:added "1.0"}
|
|
rlm@10
|
278 [^IProxy proxy mappings]
|
|
rlm@10
|
279 (. proxy (__initClojureFnMappings mappings)))
|
|
rlm@10
|
280
|
|
rlm@10
|
281 (defn update-proxy
|
|
rlm@10
|
282 "Takes a proxy instance and a map of strings (which must
|
|
rlm@10
|
283 correspond to methods of the proxy superclass/superinterfaces) to
|
|
rlm@10
|
284 fns (which must take arguments matching the corresponding method,
|
|
rlm@10
|
285 plus an additional (explicit) first arg corresponding to this, and
|
|
rlm@10
|
286 updates (via assoc) the proxy's fn map. nil can be passed instead of
|
|
rlm@10
|
287 a fn, in which case the corresponding method will revert to the
|
|
rlm@10
|
288 default behavior. Note that this function can be used to update the
|
|
rlm@10
|
289 behavior of an existing instance without changing its identity."
|
|
rlm@10
|
290 {:added "1.0"}
|
|
rlm@10
|
291 [^IProxy proxy mappings]
|
|
rlm@10
|
292 (. proxy (__updateClojureFnMappings mappings)))
|
|
rlm@10
|
293
|
|
rlm@10
|
294 (defn proxy-mappings
|
|
rlm@10
|
295 "Takes a proxy instance and returns the proxy's fn map."
|
|
rlm@10
|
296 {:added "1.0"}
|
|
rlm@10
|
297 [^IProxy proxy]
|
|
rlm@10
|
298 (. proxy (__getClojureFnMappings)))
|
|
rlm@10
|
299
|
|
rlm@10
|
300 (defmacro proxy
|
|
rlm@10
|
301 "class-and-interfaces - a vector of class names
|
|
rlm@10
|
302
|
|
rlm@10
|
303 args - a (possibly empty) vector of arguments to the superclass
|
|
rlm@10
|
304 constructor.
|
|
rlm@10
|
305
|
|
rlm@10
|
306 f => (name [params*] body) or
|
|
rlm@10
|
307 (name ([params*] body) ([params+] body) ...)
|
|
rlm@10
|
308
|
|
rlm@10
|
309 Expands to code which creates a instance of a proxy class that
|
|
rlm@10
|
310 implements the named class/interface(s) by calling the supplied
|
|
rlm@10
|
311 fns. A single class, if provided, must be first. If not provided it
|
|
rlm@10
|
312 defaults to Object.
|
|
rlm@10
|
313
|
|
rlm@10
|
314 The interfaces names must be valid interface types. If a method fn
|
|
rlm@10
|
315 is not provided for a class method, the superclass methd will be
|
|
rlm@10
|
316 called. If a method fn is not provided for an interface method, an
|
|
rlm@10
|
317 UnsupportedOperationException will be thrown should it be
|
|
rlm@10
|
318 called. Method fns are closures and can capture the environment in
|
|
rlm@10
|
319 which proxy is called. Each method fn takes an additional implicit
|
|
rlm@10
|
320 first arg, which is bound to 'this. Note that while method fns can
|
|
rlm@10
|
321 be provided to override protected methods, they have no other access
|
|
rlm@10
|
322 to protected members, nor to super, as these capabilities cannot be
|
|
rlm@10
|
323 proxied."
|
|
rlm@10
|
324 {:added "1.0"}
|
|
rlm@10
|
325 [class-and-interfaces args & fs]
|
|
rlm@10
|
326 (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %))))
|
|
rlm@10
|
327 class-and-interfaces)
|
|
rlm@10
|
328 [super interfaces] (get-super-and-interfaces bases)
|
|
rlm@10
|
329 compile-effect (when *compile-files*
|
|
rlm@10
|
330 (let [[cname bytecode] (generate-proxy super interfaces)]
|
|
rlm@10
|
331 (clojure.lang.Compiler/writeClassFile cname bytecode)))
|
|
rlm@10
|
332 pc-effect (apply get-proxy-class bases)
|
|
rlm@10
|
333 pname (proxy-name super interfaces)]
|
|
rlm@10
|
334 ;remember the class to prevent it from disappearing before use
|
|
rlm@10
|
335 (intern *ns* (symbol pname) pc-effect)
|
|
rlm@10
|
336 `(let [;pc# (get-proxy-class ~@class-and-interfaces)
|
|
rlm@10
|
337 p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)]
|
|
rlm@10
|
338 (init-proxy p#
|
|
rlm@10
|
339 ~(loop [fmap {} fs fs]
|
|
rlm@10
|
340 (if fs
|
|
rlm@10
|
341 (let [[sym & meths] (first fs)
|
|
rlm@10
|
342 meths (if (vector? (first meths))
|
|
rlm@10
|
343 (list meths)
|
|
rlm@10
|
344 meths)
|
|
rlm@10
|
345 meths (map (fn [[params & body]]
|
|
rlm@10
|
346 (cons (apply vector 'this params) body))
|
|
rlm@10
|
347 meths)]
|
|
rlm@10
|
348 (if-not (contains? fmap (name sym))
|
|
rlm@10
|
349 (recur (assoc fmap (name sym) (cons `fn meths)) (next fs))
|
|
rlm@10
|
350 (throw (IllegalArgumentException.
|
|
rlm@10
|
351 (str "Method '" (name sym) "' redefined")))))
|
|
rlm@10
|
352 fmap)))
|
|
rlm@10
|
353 p#)))
|
|
rlm@10
|
354
|
|
rlm@10
|
355 (defn proxy-call-with-super [call this meth]
|
|
rlm@10
|
356 (let [m (proxy-mappings this)]
|
|
rlm@10
|
357 (update-proxy this (assoc m meth nil))
|
|
rlm@10
|
358 (let [ret (call)]
|
|
rlm@10
|
359 (update-proxy this m)
|
|
rlm@10
|
360 ret)))
|
|
rlm@10
|
361
|
|
rlm@10
|
362 (defmacro proxy-super
|
|
rlm@10
|
363 "Use to call a superclass method in the body of a proxy method.
|
|
rlm@10
|
364 Note, expansion captures 'this"
|
|
rlm@10
|
365 {:added "1.0"}
|
|
rlm@10
|
366 [meth & args]
|
|
rlm@10
|
367 `(proxy-call-with-super (fn [] (. ~'this ~meth ~@args)) ~'this ~(name meth)))
|
|
rlm@10
|
368
|
|
rlm@10
|
369 (defn bean
|
|
rlm@10
|
370 "Takes a Java object and returns a read-only implementation of the
|
|
rlm@10
|
371 map abstraction based upon its JavaBean properties."
|
|
rlm@10
|
372 {:added "1.0"}
|
|
rlm@10
|
373 [^Object x]
|
|
rlm@10
|
374 (let [c (. x (getClass))
|
|
rlm@10
|
375 pmap (reduce (fn [m ^java.beans.PropertyDescriptor pd]
|
|
rlm@10
|
376 (let [name (. pd (getName))
|
|
rlm@10
|
377 method (. pd (getReadMethod))]
|
|
rlm@10
|
378 (if (and method (zero? (alength (. method (getParameterTypes)))))
|
|
rlm@10
|
379 (assoc m (keyword name) (fn [] (clojure.lang.Reflector/prepRet (. method (invoke x nil)))))
|
|
rlm@10
|
380 m)))
|
|
rlm@10
|
381 {}
|
|
rlm@10
|
382 (seq (.. java.beans.Introspector
|
|
rlm@10
|
383 (getBeanInfo c)
|
|
rlm@10
|
384 (getPropertyDescriptors))))
|
|
rlm@10
|
385 v (fn [k] ((pmap k)))
|
|
rlm@10
|
386 snapshot (fn []
|
|
rlm@10
|
387 (reduce (fn [m e]
|
|
rlm@10
|
388 (assoc m (key e) ((val e))))
|
|
rlm@10
|
389 {} (seq pmap)))]
|
|
rlm@10
|
390 (proxy [clojure.lang.APersistentMap]
|
|
rlm@10
|
391 []
|
|
rlm@10
|
392 (containsKey [k] (contains? pmap k))
|
|
rlm@10
|
393 (entryAt [k] (when (contains? pmap k) (new clojure.lang.MapEntry k (v k))))
|
|
rlm@10
|
394 (valAt ([k] (v k))
|
|
rlm@10
|
395 ([k default] (if (contains? pmap k) (v k) default)))
|
|
rlm@10
|
396 (cons [m] (conj (snapshot) m))
|
|
rlm@10
|
397 (count [] (count pmap))
|
|
rlm@10
|
398 (assoc [k v] (assoc (snapshot) k v))
|
|
rlm@10
|
399 (without [k] (dissoc (snapshot) k))
|
|
rlm@10
|
400 (seq [] ((fn thisfn [plseq]
|
|
rlm@10
|
401 (lazy-seq
|
|
rlm@10
|
402 (when-let [pseq (seq plseq)]
|
|
rlm@10
|
403 (cons (new clojure.lang.MapEntry (first pseq) (v (first pseq)))
|
|
rlm@10
|
404 (thisfn (rest pseq)))))) (keys pmap))))))
|
|
rlm@10
|
405
|
|
rlm@10
|
406
|
|
rlm@10
|
407
|
