1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/core_proxy.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,407 @@
     1.4 +;   Copyright (c) Rich Hickey. All rights reserved.
     1.5 +;   The use and distribution terms for this software are covered by the
     1.6 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.7 +;   which can be found in the file epl-v10.html at the root of this distribution.
     1.8 +;   By using this software in any fashion, you are agreeing to be bound by
     1.9 +;   the terms of this license.
    1.10 +;   You must not remove this notice, or any other, from this software.
    1.11 +
    1.12 +(in-ns 'clojure.core)
    1.13 +
    1.14 +;;;;;;;;;;;;;;;;;;;;;;;;;;;; proxy ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.15 +
    1.16 +(import
    1.17 + '(clojure.asm ClassWriter ClassVisitor Opcodes Type) 
    1.18 + '(java.lang.reflect Modifier Constructor)
    1.19 + '(clojure.asm.commons Method GeneratorAdapter)
    1.20 + '(clojure.lang IProxy Reflector DynamicClassLoader IPersistentMap PersistentHashMap RT))
    1.21 +
    1.22 +(defn method-sig [^java.lang.reflect.Method meth]
    1.23 +  [(. meth (getName)) (seq (. meth (getParameterTypes))) (. meth getReturnType)])
    1.24 +
    1.25 +(defn- most-specific [rtypes]
    1.26 +  (or (some (fn [t] (when (every? #(isa? t %) rtypes) t)) rtypes)
    1.27 +    (throw (Exception. "Incompatible return types"))))
    1.28 +
    1.29 +(defn- group-by-sig [coll]
    1.30 + "takes a collection of [msig meth] and returns a seq of maps from return-types to meths."
    1.31 +  (vals (reduce (fn [m [msig meth]]
    1.32 +                  (let [rtype (peek msig)
    1.33 +                        argsig (pop msig)]
    1.34 +                    (assoc m argsig (assoc (m argsig {}) rtype meth))))
    1.35 +          {} coll)))
    1.36 +
    1.37 +(defn proxy-name
    1.38 + {:tag String} 
    1.39 + [^Class super interfaces]
    1.40 +  (let [inames (into (sorted-set) (map #(.getName ^Class %) interfaces))]
    1.41 +    (apply str (.replace (str *ns*) \- \_) ".proxy"
    1.42 +      (interleave (repeat "$")
    1.43 +        (concat
    1.44 +          [(.getName super)]
    1.45 +          (map #(subs % (inc (.lastIndexOf ^String % "."))) inames)
    1.46 +          [(Integer/toHexString (hash inames))])))))
    1.47 +
    1.48 +(defn- generate-proxy [^Class super interfaces]
    1.49 +  (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
    1.50 +        cname (.replace (proxy-name super interfaces) \. \/) ;(str "clojure/lang/" (gensym "Proxy__"))
    1.51 +        ctype (. Type (getObjectType cname))
    1.52 +        iname (fn [^Class c] (.. Type (getType c) (getInternalName)))
    1.53 +        fmap "__clojureFnMap"
    1.54 +        totype (fn [^Class c] (. Type (getType c)))
    1.55 +        to-types (fn [cs] (if (pos? (count cs))
    1.56 +                            (into-array (map totype cs))
    1.57 +                            (make-array Type 0)))
    1.58 +        super-type ^Type (totype super)
    1.59 +        imap-type ^Type (totype IPersistentMap)
    1.60 +        ifn-type (totype clojure.lang.IFn)
    1.61 +        obj-type (totype Object)
    1.62 +        sym-type (totype clojure.lang.Symbol)
    1.63 +        rt-type  (totype clojure.lang.RT)
    1.64 +        ex-type  (totype java.lang.UnsupportedOperationException)
    1.65 +        gen-bridge 
    1.66 +        (fn [^java.lang.reflect.Method meth ^java.lang.reflect.Method dest]
    1.67 +            (let [pclasses (. meth (getParameterTypes))
    1.68 +                  ptypes (to-types pclasses)
    1.69 +                  rtype ^Type (totype (. meth (getReturnType)))
    1.70 +                  m (new Method (. meth (getName)) rtype ptypes)
    1.71 +                  dtype (totype (.getDeclaringClass dest))
    1.72 +                  dm (new Method (. dest (getName)) (totype (. dest (getReturnType))) (to-types (. dest (getParameterTypes))))
    1.73 +                  gen (new GeneratorAdapter (bit-or (. Opcodes ACC_PUBLIC) (. Opcodes ACC_BRIDGE)) m nil nil cv)]
    1.74 +              (. gen (visitCode))
    1.75 +              (. gen (loadThis))
    1.76 +              (dotimes [i (count ptypes)]
    1.77 +                  (. gen (loadArg i)))
    1.78 +              (if (-> dest .getDeclaringClass .isInterface)
    1.79 +                (. gen (invokeInterface dtype dm))
    1.80 +                (. gen (invokeVirtual dtype dm)))
    1.81 +              (. gen (returnValue))
    1.82 +              (. gen (endMethod))))
    1.83 +        gen-method
    1.84 +        (fn [^java.lang.reflect.Method meth else-gen]
    1.85 +            (let [pclasses (. meth (getParameterTypes))
    1.86 +                  ptypes (to-types pclasses)
    1.87 +                  rtype ^Type (totype (. meth (getReturnType)))
    1.88 +                  m (new Method (. meth (getName)) rtype ptypes)
    1.89 +                  gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
    1.90 +                  else-label (. gen (newLabel))
    1.91 +                  end-label (. gen (newLabel))
    1.92 +                  decl-type (. Type (getType (. meth (getDeclaringClass))))]
    1.93 +              (. gen (visitCode))
    1.94 +              (if (> (count pclasses) 18)
    1.95 +                (else-gen gen m)
    1.96 +                (do
    1.97 +                  (. gen (loadThis))
    1.98 +                  (. gen (getField ctype fmap imap-type))
    1.99 +                  
   1.100 +                  (. gen (push (. meth (getName))))
   1.101 +                                        ;lookup fn in map
   1.102 +                  (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)"))))
   1.103 +                  (. gen (dup))
   1.104 +                  (. gen (ifNull else-label))
   1.105 +                                        ;if found
   1.106 +                  (.checkCast gen ifn-type)
   1.107 +                  (. gen (loadThis))
   1.108 +                                        ;box args
   1.109 +                  (dotimes [i (count ptypes)]
   1.110 +                      (. gen (loadArg i))
   1.111 +                    (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
   1.112 +                                        ;call fn
   1.113 +                  (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 
   1.114 +                                                        (into-array (cons obj-type 
   1.115 +                                                                          (replicate (count ptypes) obj-type))))))
   1.116 +                                        ;unbox return
   1.117 +                  (. gen (unbox rtype))
   1.118 +                  (when (= (. rtype (getSort)) (. Type VOID))
   1.119 +                    (. gen (pop)))
   1.120 +                  (. gen (goTo end-label))
   1.121 +                  
   1.122 +                                        ;else call supplied alternative generator
   1.123 +                  (. gen (mark else-label))
   1.124 +                  (. gen (pop))
   1.125 +                  
   1.126 +                  (else-gen gen m)
   1.127 +                  
   1.128 +                  (. gen (mark end-label))))
   1.129 +              (. gen (returnValue))
   1.130 +              (. gen (endMethod))))]
   1.131 +    
   1.132 +                                        ;start class definition
   1.133 +    (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
   1.134 +                 cname nil (iname super) 
   1.135 +                 (into-array (map iname (cons IProxy interfaces)))))
   1.136 +                                        ;add field for fn mappings
   1.137 +    (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE))
   1.138 +                      fmap (. imap-type (getDescriptor)) nil nil))          
   1.139 +                                        ;add ctors matching/calling super's
   1.140 +    (doseq [^Constructor ctor (. super (getDeclaredConstructors))]
   1.141 +        (when-not (. Modifier (isPrivate (. ctor (getModifiers))))
   1.142 +          (let [ptypes (to-types (. ctor (getParameterTypes)))
   1.143 +                m (new Method "<init>" (. Type VOID_TYPE) ptypes)
   1.144 +                gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
   1.145 +            (. gen (visitCode))
   1.146 +                                        ;call super ctor
   1.147 +            (. gen (loadThis))
   1.148 +            (. gen (dup))
   1.149 +            (. gen (loadArgs))
   1.150 +            (. gen (invokeConstructor super-type m))
   1.151 +            
   1.152 +            (. gen (returnValue))
   1.153 +            (. gen (endMethod)))))
   1.154 +                                        ;add IProxy methods
   1.155 +    (let [m (. Method (getMethod "void __initClojureFnMappings(clojure.lang.IPersistentMap)"))
   1.156 +          gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
   1.157 +      (. gen (visitCode))
   1.158 +      (. gen (loadThis))
   1.159 +      (. gen (loadArgs))
   1.160 +      (. gen (putField ctype fmap imap-type))
   1.161 +      
   1.162 +      (. gen (returnValue))
   1.163 +      (. gen (endMethod)))
   1.164 +    (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)"))
   1.165 +          gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
   1.166 +      (. gen (visitCode))
   1.167 +      (. gen (loadThis))
   1.168 +      (. gen (dup))
   1.169 +      (. gen (getField ctype fmap imap-type))
   1.170 +      (.checkCast gen (totype clojure.lang.IPersistentCollection))
   1.171 +      (. gen (loadArgs))
   1.172 +      (. gen (invokeInterface (totype clojure.lang.IPersistentCollection)
   1.173 +                              (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)"))))
   1.174 +      (. gen (checkCast imap-type))
   1.175 +      (. gen (putField ctype fmap imap-type))
   1.176 +      
   1.177 +      (. gen (returnValue))
   1.178 +      (. gen (endMethod)))
   1.179 +    (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()"))
   1.180 +          gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
   1.181 +      (. gen (visitCode))
   1.182 +      (. gen (loadThis))
   1.183 +      (. gen (getField ctype fmap imap-type))
   1.184 +      (. gen (returnValue))
   1.185 +      (. gen (endMethod)))
   1.186 +    
   1.187 +                                        ;calc set of supers' non-private instance methods
   1.188 +    (let [[mm considered]
   1.189 +            (loop [mm {} considered #{} c super]
   1.190 +              (if c
   1.191 +                (let [[mm considered]
   1.192 +                      (loop [mm mm 
   1.193 +                             considered considered 
   1.194 +                             meths (concat 
   1.195 +                                    (seq (. c (getDeclaredMethods)))
   1.196 +                                    (seq (. c (getMethods))))]
   1.197 +                        (if (seq meths)
   1.198 +                          (let [^java.lang.reflect.Method meth (first meths)
   1.199 +                                mods (. meth (getModifiers))
   1.200 +                                mk (method-sig meth)]
   1.201 +                            (if (or (considered mk)
   1.202 +                                    (not (or (Modifier/isPublic mods) (Modifier/isProtected mods)))
   1.203 +                                    ;(. Modifier (isPrivate mods)) 
   1.204 +                                    (. Modifier (isStatic mods))
   1.205 +                                    (. Modifier (isFinal mods))
   1.206 +                                    (= "finalize" (.getName meth)))
   1.207 +                              (recur mm (conj considered mk) (next meths))
   1.208 +                              (recur (assoc mm mk meth) (conj considered mk) (next meths))))
   1.209 +                          [mm considered]))]
   1.210 +                  (recur mm considered (. c (getSuperclass))))
   1.211 +                [mm considered]))
   1.212 +          ifaces-meths (into {} 
   1.213 +                         (for [^Class iface interfaces meth (. iface (getMethods))
   1.214 +                               :let [msig (method-sig meth)] :when (not (considered msig))]
   1.215 +                           {msig meth}))
   1.216 +          mgroups (group-by-sig (concat mm ifaces-meths))
   1.217 +          rtypes (map #(most-specific (keys %)) mgroups)
   1.218 +          mb (map #(vector (%1 %2) (vals (dissoc %1 %2))) mgroups rtypes)
   1.219 +          bridge? (reduce into #{} (map second mb))
   1.220 +          ifaces-meths (remove bridge? (vals ifaces-meths))
   1.221 +          mm (remove bridge? (vals mm))]
   1.222 +                                        ;add methods matching supers', if no mapping -> call super
   1.223 +      (doseq [[^java.lang.reflect.Method dest bridges] mb
   1.224 +              ^java.lang.reflect.Method meth bridges]
   1.225 +          (gen-bridge meth dest))
   1.226 +      (doseq [^java.lang.reflect.Method meth mm]
   1.227 +          (gen-method meth 
   1.228 +                      (fn [^GeneratorAdapter gen ^Method m]
   1.229 +                          (. gen (loadThis))
   1.230 +                                        ;push args
   1.231 +                        (. gen (loadArgs))
   1.232 +                                        ;call super
   1.233 +                        (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 
   1.234 +                                                (. super-type (getInternalName))
   1.235 +                                                (. m (getName))
   1.236 +                                                (. m (getDescriptor)))))))
   1.237 +      
   1.238 +                                        ;add methods matching interfaces', if no mapping -> throw
   1.239 +      (doseq [^java.lang.reflect.Method meth ifaces-meths]
   1.240 +                (gen-method meth 
   1.241 +                            (fn [^GeneratorAdapter gen ^Method m]
   1.242 +                                (. gen (throwException ex-type (. m (getName))))))))
   1.243 +    
   1.244 +                                        ;finish class def
   1.245 +    (. cv (visitEnd))
   1.246 +    [cname (. cv toByteArray)]))
   1.247 +
   1.248 +(defn- get-super-and-interfaces [bases]
   1.249 +  (if (. ^Class (first bases) (isInterface))
   1.250 +    [Object bases]
   1.251 +    [(first bases) (next bases)]))
   1.252 +
   1.253 +(defn get-proxy-class 
   1.254 +  "Takes an optional single class followed by zero or more
   1.255 +  interfaces. If not supplied class defaults to Object.  Creates an
   1.256 +  returns an instance of a proxy class derived from the supplied
   1.257 +  classes. The resulting value is cached and used for any subsequent
   1.258 +  requests for the same class set. Returns a Class object."
   1.259 +  {:added "1.0"}
   1.260 +  [& bases]
   1.261 +    (let [[super interfaces] (get-super-and-interfaces bases)
   1.262 +          pname (proxy-name super interfaces)]
   1.263 +      (or (RT/loadClassForName pname)
   1.264 +          (let [[cname bytecode] (generate-proxy super interfaces)]
   1.265 +            (. ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) (defineClass pname bytecode [super interfaces]))))))
   1.266 +
   1.267 +(defn construct-proxy
   1.268 +  "Takes a proxy class and any arguments for its superclass ctor and
   1.269 +  creates and returns an instance of the proxy."
   1.270 +  {:added "1.0"}
   1.271 +  [c & ctor-args]
   1.272 +    (. Reflector (invokeConstructor c (to-array ctor-args))))
   1.273 +
   1.274 +(defn init-proxy
   1.275 +  "Takes a proxy instance and a map of strings (which must
   1.276 +  correspond to methods of the proxy superclass/superinterfaces) to
   1.277 +  fns (which must take arguments matching the corresponding method,
   1.278 +  plus an additional (explicit) first arg corresponding to this, and
   1.279 +  sets the proxy's fn map."
   1.280 +  {:added "1.0"}
   1.281 +  [^IProxy proxy mappings]
   1.282 +    (. proxy (__initClojureFnMappings mappings)))
   1.283 +
   1.284 +(defn update-proxy
   1.285 +  "Takes a proxy instance and a map of strings (which must
   1.286 +  correspond to methods of the proxy superclass/superinterfaces) to
   1.287 +  fns (which must take arguments matching the corresponding method,
   1.288 +  plus an additional (explicit) first arg corresponding to this, and
   1.289 +  updates (via assoc) the proxy's fn map. nil can be passed instead of
   1.290 +  a fn, in which case the corresponding method will revert to the
   1.291 +  default behavior. Note that this function can be used to update the
   1.292 +  behavior of an existing instance without changing its identity."
   1.293 +  {:added "1.0"}
   1.294 +  [^IProxy proxy mappings]
   1.295 +    (. proxy (__updateClojureFnMappings mappings)))
   1.296 +
   1.297 +(defn proxy-mappings
   1.298 +  "Takes a proxy instance and returns the proxy's fn map."
   1.299 +  {:added "1.0"}
   1.300 +  [^IProxy proxy]
   1.301 +    (. proxy (__getClojureFnMappings)))
   1.302 +
   1.303 +(defmacro proxy
   1.304 +  "class-and-interfaces - a vector of class names
   1.305 +
   1.306 +  args - a (possibly empty) vector of arguments to the superclass
   1.307 +  constructor.
   1.308 +
   1.309 +  f => (name [params*] body) or
   1.310 +  (name ([params*] body) ([params+] body) ...)
   1.311 +
   1.312 +  Expands to code which creates a instance of a proxy class that
   1.313 +  implements the named class/interface(s) by calling the supplied
   1.314 +  fns. A single class, if provided, must be first. If not provided it
   1.315 +  defaults to Object.
   1.316 +
   1.317 +  The interfaces names must be valid interface types. If a method fn
   1.318 +  is not provided for a class method, the superclass methd will be
   1.319 +  called. If a method fn is not provided for an interface method, an
   1.320 +  UnsupportedOperationException will be thrown should it be
   1.321 +  called. Method fns are closures and can capture the environment in
   1.322 +  which proxy is called. Each method fn takes an additional implicit
   1.323 +  first arg, which is bound to 'this. Note that while method fns can
   1.324 +  be provided to override protected methods, they have no other access
   1.325 +  to protected members, nor to super, as these capabilities cannot be
   1.326 +  proxied."
   1.327 +  {:added "1.0"}
   1.328 +  [class-and-interfaces args & fs]
   1.329 +   (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %)))) 
   1.330 +                    class-and-interfaces)
   1.331 +         [super interfaces] (get-super-and-interfaces bases)
   1.332 +         compile-effect (when *compile-files*
   1.333 +                          (let [[cname bytecode] (generate-proxy super interfaces)]
   1.334 +                            (clojure.lang.Compiler/writeClassFile cname bytecode)))
   1.335 +         pc-effect (apply get-proxy-class bases)
   1.336 +         pname (proxy-name super interfaces)]
   1.337 +     ;remember the class to prevent it from disappearing before use
   1.338 +     (intern *ns* (symbol pname) pc-effect)
   1.339 +     `(let [;pc# (get-proxy-class ~@class-and-interfaces)
   1.340 +            p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)]   
   1.341 +        (init-proxy p#
   1.342 +         ~(loop [fmap {} fs fs]
   1.343 +            (if fs
   1.344 +              (let [[sym & meths] (first fs)
   1.345 +                    meths (if (vector? (first meths))
   1.346 +                            (list meths)
   1.347 +                            meths)
   1.348 +                    meths (map (fn [[params & body]]
   1.349 +                                   (cons (apply vector 'this params) body))
   1.350 +                               meths)]
   1.351 +                (if-not (contains? fmap (name sym))		  
   1.352 +                (recur (assoc fmap (name sym) (cons `fn meths)) (next fs))
   1.353 +		           (throw (IllegalArgumentException.
   1.354 +			              (str "Method '" (name sym) "' redefined")))))
   1.355 +              fmap)))
   1.356 +        p#)))
   1.357 +
   1.358 +(defn proxy-call-with-super [call this meth]
   1.359 + (let [m (proxy-mappings this)]
   1.360 +    (update-proxy this (assoc m meth nil))
   1.361 +    (let [ret (call)]
   1.362 +      (update-proxy this m)
   1.363 +      ret)))
   1.364 +
   1.365 +(defmacro proxy-super 
   1.366 +  "Use to call a superclass method in the body of a proxy method. 
   1.367 +  Note, expansion captures 'this"
   1.368 +  {:added "1.0"}
   1.369 +  [meth & args]
   1.370 + `(proxy-call-with-super (fn [] (. ~'this ~meth ~@args))  ~'this ~(name meth)))
   1.371 +
   1.372 +(defn bean
   1.373 +  "Takes a Java object and returns a read-only implementation of the
   1.374 +  map abstraction based upon its JavaBean properties."
   1.375 +  {:added "1.0"}
   1.376 +  [^Object x]
   1.377 +  (let [c (. x (getClass))
   1.378 +	pmap (reduce (fn [m ^java.beans.PropertyDescriptor pd]
   1.379 +			 (let [name (. pd (getName))
   1.380 +			       method (. pd (getReadMethod))]
   1.381 +			   (if (and method (zero? (alength (. method (getParameterTypes)))))
   1.382 +			     (assoc m (keyword name) (fn [] (clojure.lang.Reflector/prepRet (. method (invoke x nil)))))
   1.383 +			     m)))
   1.384 +		     {}
   1.385 +		     (seq (.. java.beans.Introspector
   1.386 +			      (getBeanInfo c)
   1.387 +			      (getPropertyDescriptors))))
   1.388 +	v (fn [k] ((pmap k)))
   1.389 +        snapshot (fn []
   1.390 +                   (reduce (fn [m e]
   1.391 +                             (assoc m (key e) ((val e))))
   1.392 +                           {} (seq pmap)))]
   1.393 +    (proxy [clojure.lang.APersistentMap]
   1.394 +           []
   1.395 +      (containsKey [k] (contains? pmap k))
   1.396 +      (entryAt [k] (when (contains? pmap k) (new clojure.lang.MapEntry k (v k))))
   1.397 +      (valAt ([k] (v k))
   1.398 +	     ([k default] (if (contains? pmap k) (v k) default)))
   1.399 +      (cons [m] (conj (snapshot) m))
   1.400 +      (count [] (count pmap))
   1.401 +      (assoc [k v] (assoc (snapshot) k v))
   1.402 +      (without [k] (dissoc (snapshot) k))
   1.403 +      (seq [] ((fn thisfn [plseq]
   1.404 +		  (lazy-seq
   1.405 +                   (when-let [pseq (seq plseq)]
   1.406 +                     (cons (new clojure.lang.MapEntry (first pseq) (v (first pseq)))
   1.407 +                           (thisfn (rest pseq)))))) (keys pmap))))))
   1.408 +
   1.409 +
   1.410 +