rlm@10: ;   Copyright (c) Rich Hickey. All rights reserved.
rlm@10: ;   The use and distribution terms for this software are covered by the
rlm@10: ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
rlm@10: ;   which can be found in the file epl-v10.html at the root of this distribution.
rlm@10: ;   By using this software in any fashion, you are agreeing to be bound by
rlm@10: ;   the terms of this license.
rlm@10: ;   You must not remove this notice, or any other, from this software.
rlm@10: 
rlm@10: (in-ns 'clojure.core)
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;;;;;;;;;; proxy ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@10: 
rlm@10: (import
rlm@10:  '(clojure.asm ClassWriter ClassVisitor Opcodes Type) 
rlm@10:  '(java.lang.reflect Modifier Constructor)
rlm@10:  '(clojure.asm.commons Method GeneratorAdapter)
rlm@10:  '(clojure.lang IProxy Reflector DynamicClassLoader IPersistentMap PersistentHashMap RT))
rlm@10: 
rlm@10: (defn method-sig [^java.lang.reflect.Method meth]
rlm@10:   [(. meth (getName)) (seq (. meth (getParameterTypes))) (. meth getReturnType)])
rlm@10: 
rlm@10: (defn- most-specific [rtypes]
rlm@10:   (or (some (fn [t] (when (every? #(isa? t %) rtypes) t)) rtypes)
rlm@10:     (throw (Exception. "Incompatible return types"))))
rlm@10: 
rlm@10: (defn- group-by-sig [coll]
rlm@10:  "takes a collection of [msig meth] and returns a seq of maps from return-types to meths."
rlm@10:   (vals (reduce (fn [m [msig meth]]
rlm@10:                   (let [rtype (peek msig)
rlm@10:                         argsig (pop msig)]
rlm@10:                     (assoc m argsig (assoc (m argsig {}) rtype meth))))
rlm@10:           {} coll)))
rlm@10: 
rlm@10: (defn proxy-name
rlm@10:  {:tag String} 
rlm@10:  [^Class super interfaces]
rlm@10:   (let [inames (into (sorted-set) (map #(.getName ^Class %) interfaces))]
rlm@10:     (apply str (.replace (str *ns*) \- \_) ".proxy"
rlm@10:       (interleave (repeat "$")
rlm@10:         (concat
rlm@10:           [(.getName super)]
rlm@10:           (map #(subs % (inc (.lastIndexOf ^String % "."))) inames)
rlm@10:           [(Integer/toHexString (hash inames))])))))
rlm@10: 
rlm@10: (defn- generate-proxy [^Class super interfaces]
rlm@10:   (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
rlm@10:         cname (.replace (proxy-name super interfaces) \. \/) ;(str "clojure/lang/" (gensym "Proxy__"))
rlm@10:         ctype (. Type (getObjectType cname))
rlm@10:         iname (fn [^Class c] (.. Type (getType c) (getInternalName)))
rlm@10:         fmap "__clojureFnMap"
rlm@10:         totype (fn [^Class c] (. Type (getType c)))
rlm@10:         to-types (fn [cs] (if (pos? (count cs))
rlm@10:                             (into-array (map totype cs))
rlm@10:                             (make-array Type 0)))
rlm@10:         super-type ^Type (totype super)
rlm@10:         imap-type ^Type (totype IPersistentMap)
rlm@10:         ifn-type (totype clojure.lang.IFn)
rlm@10:         obj-type (totype Object)
rlm@10:         sym-type (totype clojure.lang.Symbol)
rlm@10:         rt-type  (totype clojure.lang.RT)
rlm@10:         ex-type  (totype java.lang.UnsupportedOperationException)
rlm@10:         gen-bridge 
rlm@10:         (fn [^java.lang.reflect.Method meth ^java.lang.reflect.Method dest]
rlm@10:             (let [pclasses (. meth (getParameterTypes))
rlm@10:                   ptypes (to-types pclasses)
rlm@10:                   rtype ^Type (totype (. meth (getReturnType)))
rlm@10:                   m (new Method (. meth (getName)) rtype ptypes)
rlm@10:                   dtype (totype (.getDeclaringClass dest))
rlm@10:                   dm (new Method (. dest (getName)) (totype (. dest (getReturnType))) (to-types (. dest (getParameterTypes))))
rlm@10:                   gen (new GeneratorAdapter (bit-or (. Opcodes ACC_PUBLIC) (. Opcodes ACC_BRIDGE)) m nil nil cv)]
rlm@10:               (. gen (visitCode))
rlm@10:               (. gen (loadThis))
rlm@10:               (dotimes [i (count ptypes)]
rlm@10:                   (. gen (loadArg i)))
rlm@10:               (if (-> dest .getDeclaringClass .isInterface)
rlm@10:                 (. gen (invokeInterface dtype dm))
rlm@10:                 (. gen (invokeVirtual dtype dm)))
rlm@10:               (. gen (returnValue))
rlm@10:               (. gen (endMethod))))
rlm@10:         gen-method
rlm@10:         (fn [^java.lang.reflect.Method meth else-gen]
rlm@10:             (let [pclasses (. meth (getParameterTypes))
rlm@10:                   ptypes (to-types pclasses)
rlm@10:                   rtype ^Type (totype (. meth (getReturnType)))
rlm@10:                   m (new Method (. meth (getName)) rtype ptypes)
rlm@10:                   gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
rlm@10:                   else-label (. gen (newLabel))
rlm@10:                   end-label (. gen (newLabel))
rlm@10:                   decl-type (. Type (getType (. meth (getDeclaringClass))))]
rlm@10:               (. gen (visitCode))
rlm@10:               (if (> (count pclasses) 18)
rlm@10:                 (else-gen gen m)
rlm@10:                 (do
rlm@10:                   (. gen (loadThis))
rlm@10:                   (. gen (getField ctype fmap imap-type))
rlm@10:                   
rlm@10:                   (. gen (push (. meth (getName))))
rlm@10:                                         ;lookup fn in map
rlm@10:                   (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)"))))
rlm@10:                   (. gen (dup))
rlm@10:                   (. gen (ifNull else-label))
rlm@10:                                         ;if found
rlm@10:                   (.checkCast gen ifn-type)
rlm@10:                   (. gen (loadThis))
rlm@10:                                         ;box args
rlm@10:                   (dotimes [i (count ptypes)]
rlm@10:                       (. gen (loadArg i))
rlm@10:                     (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
rlm@10:                                         ;call fn
rlm@10:                   (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 
rlm@10:                                                         (into-array (cons obj-type 
rlm@10:                                                                           (replicate (count ptypes) obj-type))))))
rlm@10:                                         ;unbox return
rlm@10:                   (. gen (unbox rtype))
rlm@10:                   (when (= (. rtype (getSort)) (. Type VOID))
rlm@10:                     (. gen (pop)))
rlm@10:                   (. gen (goTo end-label))
rlm@10:                   
rlm@10:                                         ;else call supplied alternative generator
rlm@10:                   (. gen (mark else-label))
rlm@10:                   (. gen (pop))
rlm@10:                   
rlm@10:                   (else-gen gen m)
rlm@10:                   
rlm@10:                   (. gen (mark end-label))))
rlm@10:               (. gen (returnValue))
rlm@10:               (. gen (endMethod))))]
rlm@10:     
rlm@10:                                         ;start class definition
rlm@10:     (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
rlm@10:                  cname nil (iname super) 
rlm@10:                  (into-array (map iname (cons IProxy interfaces)))))
rlm@10:                                         ;add field for fn mappings
rlm@10:     (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE))
rlm@10:                       fmap (. imap-type (getDescriptor)) nil nil))          
rlm@10:                                         ;add ctors matching/calling super's
rlm@10:     (doseq [^Constructor ctor (. super (getDeclaredConstructors))]
rlm@10:         (when-not (. Modifier (isPrivate (. ctor (getModifiers))))
rlm@10:           (let [ptypes (to-types (. ctor (getParameterTypes)))
rlm@10:                 m (new Method "<init>" (. Type VOID_TYPE) ptypes)
rlm@10:                 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
rlm@10:             (. gen (visitCode))
rlm@10:                                         ;call super ctor
rlm@10:             (. gen (loadThis))
rlm@10:             (. gen (dup))
rlm@10:             (. gen (loadArgs))
rlm@10:             (. gen (invokeConstructor super-type m))
rlm@10:             
rlm@10:             (. gen (returnValue))
rlm@10:             (. gen (endMethod)))))
rlm@10:                                         ;add IProxy methods
rlm@10:     (let [m (. Method (getMethod "void __initClojureFnMappings(clojure.lang.IPersistentMap)"))
rlm@10:           gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
rlm@10:       (. gen (visitCode))
rlm@10:       (. gen (loadThis))
rlm@10:       (. gen (loadArgs))
rlm@10:       (. gen (putField ctype fmap imap-type))
rlm@10:       
rlm@10:       (. gen (returnValue))
rlm@10:       (. gen (endMethod)))
rlm@10:     (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)"))
rlm@10:           gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
rlm@10:       (. gen (visitCode))
rlm@10:       (. gen (loadThis))
rlm@10:       (. gen (dup))
rlm@10:       (. gen (getField ctype fmap imap-type))
rlm@10:       (.checkCast gen (totype clojure.lang.IPersistentCollection))
rlm@10:       (. gen (loadArgs))
rlm@10:       (. gen (invokeInterface (totype clojure.lang.IPersistentCollection)
rlm@10:                               (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)"))))
rlm@10:       (. gen (checkCast imap-type))
rlm@10:       (. gen (putField ctype fmap imap-type))
rlm@10:       
rlm@10:       (. gen (returnValue))
rlm@10:       (. gen (endMethod)))
rlm@10:     (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()"))
rlm@10:           gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
rlm@10:       (. gen (visitCode))
rlm@10:       (. gen (loadThis))
rlm@10:       (. gen (getField ctype fmap imap-type))
rlm@10:       (. gen (returnValue))
rlm@10:       (. gen (endMethod)))
rlm@10:     
rlm@10:                                         ;calc set of supers' non-private instance methods
rlm@10:     (let [[mm considered]
rlm@10:             (loop [mm {} considered #{} c super]
rlm@10:               (if c
rlm@10:                 (let [[mm considered]
rlm@10:                       (loop [mm mm 
rlm@10:                              considered considered 
rlm@10:                              meths (concat 
rlm@10:                                     (seq (. c (getDeclaredMethods)))
rlm@10:                                     (seq (. c (getMethods))))]
rlm@10:                         (if (seq meths)
rlm@10:                           (let [^java.lang.reflect.Method meth (first meths)
rlm@10:                                 mods (. meth (getModifiers))
rlm@10:                                 mk (method-sig meth)]
rlm@10:                             (if (or (considered mk)
rlm@10:                                     (not (or (Modifier/isPublic mods) (Modifier/isProtected mods)))
rlm@10:                                     ;(. Modifier (isPrivate mods)) 
rlm@10:                                     (. Modifier (isStatic mods))
rlm@10:                                     (. Modifier (isFinal mods))
rlm@10:                                     (= "finalize" (.getName meth)))
rlm@10:                               (recur mm (conj considered mk) (next meths))
rlm@10:                               (recur (assoc mm mk meth) (conj considered mk) (next meths))))
rlm@10:                           [mm considered]))]
rlm@10:                   (recur mm considered (. c (getSuperclass))))
rlm@10:                 [mm considered]))
rlm@10:           ifaces-meths (into {} 
rlm@10:                          (for [^Class iface interfaces meth (. iface (getMethods))
rlm@10:                                :let [msig (method-sig meth)] :when (not (considered msig))]
rlm@10:                            {msig meth}))
rlm@10:           mgroups (group-by-sig (concat mm ifaces-meths))
rlm@10:           rtypes (map #(most-specific (keys %)) mgroups)
rlm@10:           mb (map #(vector (%1 %2) (vals (dissoc %1 %2))) mgroups rtypes)
rlm@10:           bridge? (reduce into #{} (map second mb))
rlm@10:           ifaces-meths (remove bridge? (vals ifaces-meths))
rlm@10:           mm (remove bridge? (vals mm))]
rlm@10:                                         ;add methods matching supers', if no mapping -> call super
rlm@10:       (doseq [[^java.lang.reflect.Method dest bridges] mb
rlm@10:               ^java.lang.reflect.Method meth bridges]
rlm@10:           (gen-bridge meth dest))
rlm@10:       (doseq [^java.lang.reflect.Method meth mm]
rlm@10:           (gen-method meth 
rlm@10:                       (fn [^GeneratorAdapter gen ^Method m]
rlm@10:                           (. gen (loadThis))
rlm@10:                                         ;push args
rlm@10:                         (. gen (loadArgs))
rlm@10:                                         ;call super
rlm@10:                         (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 
rlm@10:                                                 (. super-type (getInternalName))
rlm@10:                                                 (. m (getName))
rlm@10:                                                 (. m (getDescriptor)))))))
rlm@10:       
rlm@10:                                         ;add methods matching interfaces', if no mapping -> throw
rlm@10:       (doseq [^java.lang.reflect.Method meth ifaces-meths]
rlm@10:                 (gen-method meth 
rlm@10:                             (fn [^GeneratorAdapter gen ^Method m]
rlm@10:                                 (. gen (throwException ex-type (. m (getName))))))))
rlm@10:     
rlm@10:                                         ;finish class def
rlm@10:     (. cv (visitEnd))
rlm@10:     [cname (. cv toByteArray)]))
rlm@10: 
rlm@10: (defn- get-super-and-interfaces [bases]
rlm@10:   (if (. ^Class (first bases) (isInterface))
rlm@10:     [Object bases]
rlm@10:     [(first bases) (next bases)]))
rlm@10: 
rlm@10: (defn get-proxy-class 
rlm@10:   "Takes an optional single class followed by zero or more
rlm@10:   interfaces. If not supplied class defaults to Object.  Creates an
rlm@10:   returns an instance of a proxy class derived from the supplied
rlm@10:   classes. The resulting value is cached and used for any subsequent
rlm@10:   requests for the same class set. Returns a Class object."
rlm@10:   {:added "1.0"}
rlm@10:   [& bases]
rlm@10:     (let [[super interfaces] (get-super-and-interfaces bases)
rlm@10:           pname (proxy-name super interfaces)]
rlm@10:       (or (RT/loadClassForName pname)
rlm@10:           (let [[cname bytecode] (generate-proxy super interfaces)]
rlm@10:             (. ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) (defineClass pname bytecode [super interfaces]))))))
rlm@10: 
rlm@10: (defn construct-proxy
rlm@10:   "Takes a proxy class and any arguments for its superclass ctor and
rlm@10:   creates and returns an instance of the proxy."
rlm@10:   {:added "1.0"}
rlm@10:   [c & ctor-args]
rlm@10:     (. Reflector (invokeConstructor c (to-array ctor-args))))
rlm@10: 
rlm@10: (defn init-proxy
rlm@10:   "Takes a proxy instance and a map of strings (which must
rlm@10:   correspond to methods of the proxy superclass/superinterfaces) to
rlm@10:   fns (which must take arguments matching the corresponding method,
rlm@10:   plus an additional (explicit) first arg corresponding to this, and
rlm@10:   sets the proxy's fn map."
rlm@10:   {:added "1.0"}
rlm@10:   [^IProxy proxy mappings]
rlm@10:     (. proxy (__initClojureFnMappings mappings)))
rlm@10: 
rlm@10: (defn update-proxy
rlm@10:   "Takes a proxy instance and a map of strings (which must
rlm@10:   correspond to methods of the proxy superclass/superinterfaces) to
rlm@10:   fns (which must take arguments matching the corresponding method,
rlm@10:   plus an additional (explicit) first arg corresponding to this, and
rlm@10:   updates (via assoc) the proxy's fn map. nil can be passed instead of
rlm@10:   a fn, in which case the corresponding method will revert to the
rlm@10:   default behavior. Note that this function can be used to update the
rlm@10:   behavior of an existing instance without changing its identity."
rlm@10:   {:added "1.0"}
rlm@10:   [^IProxy proxy mappings]
rlm@10:     (. proxy (__updateClojureFnMappings mappings)))
rlm@10: 
rlm@10: (defn proxy-mappings
rlm@10:   "Takes a proxy instance and returns the proxy's fn map."
rlm@10:   {:added "1.0"}
rlm@10:   [^IProxy proxy]
rlm@10:     (. proxy (__getClojureFnMappings)))
rlm@10: 
rlm@10: (defmacro proxy
rlm@10:   "class-and-interfaces - a vector of class names
rlm@10: 
rlm@10:   args - a (possibly empty) vector of arguments to the superclass
rlm@10:   constructor.
rlm@10: 
rlm@10:   f => (name [params*] body) or
rlm@10:   (name ([params*] body) ([params+] body) ...)
rlm@10: 
rlm@10:   Expands to code which creates a instance of a proxy class that
rlm@10:   implements the named class/interface(s) by calling the supplied
rlm@10:   fns. A single class, if provided, must be first. If not provided it
rlm@10:   defaults to Object.
rlm@10: 
rlm@10:   The interfaces names must be valid interface types. If a method fn
rlm@10:   is not provided for a class method, the superclass methd will be
rlm@10:   called. If a method fn is not provided for an interface method, an
rlm@10:   UnsupportedOperationException will be thrown should it be
rlm@10:   called. Method fns are closures and can capture the environment in
rlm@10:   which proxy is called. Each method fn takes an additional implicit
rlm@10:   first arg, which is bound to 'this. Note that while method fns can
rlm@10:   be provided to override protected methods, they have no other access
rlm@10:   to protected members, nor to super, as these capabilities cannot be
rlm@10:   proxied."
rlm@10:   {:added "1.0"}
rlm@10:   [class-and-interfaces args & fs]
rlm@10:    (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %)))) 
rlm@10:                     class-and-interfaces)
rlm@10:          [super interfaces] (get-super-and-interfaces bases)
rlm@10:          compile-effect (when *compile-files*
rlm@10:                           (let [[cname bytecode] (generate-proxy super interfaces)]
rlm@10:                             (clojure.lang.Compiler/writeClassFile cname bytecode)))
rlm@10:          pc-effect (apply get-proxy-class bases)
rlm@10:          pname (proxy-name super interfaces)]
rlm@10:      ;remember the class to prevent it from disappearing before use
rlm@10:      (intern *ns* (symbol pname) pc-effect)
rlm@10:      `(let [;pc# (get-proxy-class ~@class-and-interfaces)
rlm@10:             p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)]   
rlm@10:         (init-proxy p#
rlm@10:          ~(loop [fmap {} fs fs]
rlm@10:             (if fs
rlm@10:               (let [[sym & meths] (first fs)
rlm@10:                     meths (if (vector? (first meths))
rlm@10:                             (list meths)
rlm@10:                             meths)
rlm@10:                     meths (map (fn [[params & body]]
rlm@10:                                    (cons (apply vector 'this params) body))
rlm@10:                                meths)]
rlm@10:                 (if-not (contains? fmap (name sym))		  
rlm@10:                 (recur (assoc fmap (name sym) (cons `fn meths)) (next fs))
rlm@10: 		           (throw (IllegalArgumentException.
rlm@10: 			              (str "Method '" (name sym) "' redefined")))))
rlm@10:               fmap)))
rlm@10:         p#)))
rlm@10: 
rlm@10: (defn proxy-call-with-super [call this meth]
rlm@10:  (let [m (proxy-mappings this)]
rlm@10:     (update-proxy this (assoc m meth nil))
rlm@10:     (let [ret (call)]
rlm@10:       (update-proxy this m)
rlm@10:       ret)))
rlm@10: 
rlm@10: (defmacro proxy-super 
rlm@10:   "Use to call a superclass method in the body of a proxy method. 
rlm@10:   Note, expansion captures 'this"
rlm@10:   {:added "1.0"}
rlm@10:   [meth & args]
rlm@10:  `(proxy-call-with-super (fn [] (. ~'this ~meth ~@args))  ~'this ~(name meth)))
rlm@10: 
rlm@10: (defn bean
rlm@10:   "Takes a Java object and returns a read-only implementation of the
rlm@10:   map abstraction based upon its JavaBean properties."
rlm@10:   {:added "1.0"}
rlm@10:   [^Object x]
rlm@10:   (let [c (. x (getClass))
rlm@10: 	pmap (reduce (fn [m ^java.beans.PropertyDescriptor pd]
rlm@10: 			 (let [name (. pd (getName))
rlm@10: 			       method (. pd (getReadMethod))]
rlm@10: 			   (if (and method (zero? (alength (. method (getParameterTypes)))))
rlm@10: 			     (assoc m (keyword name) (fn [] (clojure.lang.Reflector/prepRet (. method (invoke x nil)))))
rlm@10: 			     m)))
rlm@10: 		     {}
rlm@10: 		     (seq (.. java.beans.Introspector
rlm@10: 			      (getBeanInfo c)
rlm@10: 			      (getPropertyDescriptors))))
rlm@10: 	v (fn [k] ((pmap k)))
rlm@10:         snapshot (fn []
rlm@10:                    (reduce (fn [m e]
rlm@10:                              (assoc m (key e) ((val e))))
rlm@10:                            {} (seq pmap)))]
rlm@10:     (proxy [clojure.lang.APersistentMap]
rlm@10:            []
rlm@10:       (containsKey [k] (contains? pmap k))
rlm@10:       (entryAt [k] (when (contains? pmap k) (new clojure.lang.MapEntry k (v k))))
rlm@10:       (valAt ([k] (v k))
rlm@10: 	     ([k default] (if (contains? pmap k) (v k) default)))
rlm@10:       (cons [m] (conj (snapshot) m))
rlm@10:       (count [] (count pmap))
rlm@10:       (assoc [k v] (assoc (snapshot) k v))
rlm@10:       (without [k] (dissoc (snapshot) k))
rlm@10:       (seq [] ((fn thisfn [plseq]
rlm@10: 		  (lazy-seq
rlm@10:                    (when-let [pseq (seq plseq)]
rlm@10:                      (cons (new clojure.lang.MapEntry (first pseq) (v (first pseq)))
rlm@10:                            (thisfn (rest pseq)))))) (keys pmap))))))
rlm@10: 
rlm@10: 
rlm@10: