为Clojure中的对象的特定实例创建代理

Question

我正在尝试创建一个代理对象，该对象使用闭包（let / proxy）为对象的某些方法添加一些功能，但是我很乐意从原始对象重写所有方法，我得到一个UnsupportedOpretationException，这里是一个例子：真实的对象

(def realcon (java.sql.DriverManager/getConnection "jdbc:h2:tcp://localhost:9092/test"))


(def con 
    (let [msg "FG>"
          xcon rcon]
        (proxy [java.sql.Connection] []
            (createStatement []
                (println msg) ;; access to closure context !
                (.createStatement xcon)))))

(def stmt (.createStatement con))
;;output FG>

(def rs (.executeQuery stmt "select count(*) from serie_sat"))

如果我从java.sql.Connection调用任何其他方法，则会得到UnsupportedOperationException，我可以手工代理所有方法，但是可能存在更好的方法！

谢谢

Answer 1

这是一种替代使用reify，proxy因为根据docs，它“在其约束不是禁止的所有情况下都是可取的”。

(defmacro override-delegate
  [type delegate & body]
  (let [d (gensym)
        overrides (group-by first body)
        methods (for [m (.getMethods (resolve type))
                      :let [f (-> (.getName m)
                                symbol
                                (with-meta {:tag (-> m .getReturnType .getName)}))]
                      :when (not (overrides f))
                      :let [args (for [t (.getParameterTypes m)]
                                   (with-meta (gensym) {:tag (.getName t)}))]]
                  (list f (vec (conj args 'this))
                    `(. ~d ~f ~@(map #(with-meta % nil) args))))]
    `(let [~d ~delegate]
       (reify ~type ~@body ~@methods))))


;; Modifying your example slightly...
(def realcon (java.sql.DriverManager/getConnection "jdbc:h2:tcp://localhost:9092/test"))
(def con 
  (let [msg "FG>"]
    (override-delegate java.sql.Connection realcon
      (createStatement [this]
        (println msg)
        (.createStatement realcon)))))

该override-delegate宏期望正文包含reify您要覆盖的方法的规范。您不重写的任何内容都会在委托上调用。reify宏生成的所有规范都将包含每种方法的参数和返回值的类型提示。

有我的执行一个警告：它仅适用于方法检查名称中body，忽略参数参数数量/类型重载方法。因此，在上面的示例中，如果java.sql.Connection接口提供多个createStatement重载，则不会为定义任何接受参数的重载con。扩展宏以解决过载并不是很困难，但是当我需要这种行为时，通常无论如何我都必须重写它们。

Answer 2

我刚刚编写了我一生中最荒谬的宏来支持此功能。可能有一种更简单的方法——如果我能想到一个，我一定会发布它——但这给了我一种很酷、迷幻的感觉，而且似乎确实有效，所以……就这样吧。

编辑：这是一个更简单的方法；定义一个函数，返回一个委托所有方法的常规proxy函数​​（手动编写或自动创建它 - 的代码delegating-proxy包含执行此操作的方法），在单个实例上使用update-proxy来仅替换需要替换的方法。这显然不如疯狂的宏那么酷，因此后者应保持在下面。

这是新的简化方法（由于位置参数计数限制和可变参数的一些问题，仍然不是很清楚）：

;;; delegates all methods
(defmacro delegating-proxy [o class-and-ifaces ctor-args]
  (let [oname (gensym)
        impls (->> class-and-ifaces
                   (map resolve)
                   (mapcat #(.getDeclaredMethods ^Class %))
                   (group-by #(.getName ^java.lang.reflect.Method %))
                   (vals)
                   (map (fn delegating-impls [^java.lang.reflect.Method ms]
                          (let [mname (symbol (.getName ^java.lang.reflect.Method (first ms)))
                                arity-groups (partition-by #(count (.getParameterTypes ^java.lang.reflect.Method %)) ms)
                                max-arity (max-key #(count (.getParameterTypes ^java.lang.reflect.Method %)) ms)]
                            `(~mname
                              ~@(remove
                                 nil?
                                 (map (fn [agroup]
                                        (let [param-types (.getParameterTypes ^java.lang.reflect.Method (first agroup))
                                              vararg? (and (seq param-types) (or (.isArray ^Class (last param-types)) (<= 20 (count param-types))))
                                              arity  ((if vararg? dec identity) (count param-types))
                                              params (vec (repeatedly arity gensym))
                                              params (if vararg? (conj params '& (gensym)) params)]
                                          (when-not (and vararg? (not= arity max-arity))
                                            (list params `(. ~oname (~mname ~@params))))))
                                      arity-groups)))))))]
    `(let [~oname ~o]
       (proxy ~class-and-ifaces ~ctor-args ~@impls))))

演示：

user> (def p (delegating-proxy (fn [& args] :foo) [clojure.lang.IFn] []))
#'user/p
user> (update-proxy p {"applyTo" (fn [& args] :bar)})
#<Object$IFn$4c646ebb user.proxy$java.lang.Object$IFn$4c646ebb@1c445f88>
user> (p 1)
:foo
user> (apply p (seq [1]))
:bar

编辑：原始宏如下。

首先，一个演示：

user> (.invoke (delegating-proxy (fn [x y] (prn x y))
                 [clojure.lang.IFn] []
                 (invoke [x] :foo))
               :bar)
:foo
user> (.invoke (delegating-proxy (fn [x y] (prn x y))
                 [clojure.lang.IFn] []
                 (invoke [x] :foo))
               :bar :quux)
:bar :quux
nil

delegating-proxy接受一个对象，当调用该对象来执行未显式实现的方法（后跟常规proxy参数）时，该对象将委托给该对象。

第二，代码。我认为可以肯定地假设其中潜伏着各种缺陷。事实上，它的大致形状就在那里；没有潜伏。如果它对某人足够有用，那么它可能会被测试并改进到一定程度的有保证的稳健性。

Gist更容易阅读。

(defmacro delegating-proxy [o class-and-ifaces ctor-args & impls]
  (let [oname (gensym)]
    (letfn [(delegating-impls [^java.lang.reflect.Method ms]
              (let [mname (symbol (.getName ^java.lang.reflect.Method (first ms)))
                    arity-groups (partition-by #(count (.getParameterTypes ^java.lang.reflect.Method %)) ms)
                    max-arity (max-key #(count (.getParameterTypes ^java.lang.reflect.Method %)) ms)]
                `(~mname
                  ~@(remove
                     nil?
                     (map (fn [agroup]
                            (let [param-types (.getParameterTypes ^java.lang.reflect.Method (first agroup))
                                  vararg? (and (seq param-types) (or (.isArray ^Class (last param-types)) (<= 20 (count param-types))))
                                  arity  ((if vararg? dec identity) (count param-types))
                                  params (vec (repeatedly arity gensym))
                                  params (if vararg? (conj params '& (gensym)) params)]
                              (when-not (and vararg? (not= arity max-arity))
                                (list params `(. ~oname (~mname ~@params))))))
                          arity-groups)))))
            (combine-impls [eimpls dimpls]
              (map (fn [e d]
                     (let [e (if (vector? (second e))
                               (list (first e) (next e))
                               e)]
                       (list* (first e) (concat (next e) (next d)))))
                   eimpls
                   dimpls))]
      (let [klass   (resolve (first class-and-ifaces))
            methods (->> class-and-ifaces
                         (map resolve)
                         (mapcat #(.getDeclaredMethods ^Class %)))
            eimpl-specs (set (map (juxt first (comp count second)) impls))
            rm-fn   (fn rm-fn [^java.lang.reflect.Method m]
                      (contains? eimpl-specs [(symbol (.getName m)) (count (.getParameterTypes m))]))
            dimpls  (->> methods
                         (remove rm-fn)
                         (remove #(let [mods (.getModifiers ^java.lang.reflect.Method %)]
                                    (or (java.lang.reflect.Modifier/isPrivate mods)
                                        (java.lang.reflect.Modifier/isProtected mods))))
                         (sort-by #(.getName ^java.lang.reflect.Method %))
                         (partition-by #(.getName ^java.lang.reflect.Method %))
                         (map delegating-impls))
            dimpl-names (set (map first dimpls))
            eimpl-names (set (map first eimpl-specs))
            {eonly false eboth true} (group-by (comp boolean dimpl-names first) impls)
            {donly false dboth true} (group-by (comp boolean eimpl-names first) dimpls)
            all-impls (concat eonly donly (combine-impls eboth dboth))]
        `(let [~oname ~o]
           (proxy ~class-and-ifaces ~ctor-args
             ~@all-impls))))))