201 lines
8.5 KiB
Plaintext
201 lines
8.5 KiB
Plaintext
;; advice.gwm --- A general package for redefining functions
|
|
;;
|
|
;; Author: Anders Holst (aho@sans.kth.se)
|
|
;; Copyright (C) 1996 Anders Holst
|
|
;; Last change: 23/3 1996
|
|
;;
|
|
;; This file is copyrighted under the same terms as the rest of GWM
|
|
;; (see the X Inc license for details). There is no warranty that it
|
|
;; works.
|
|
;;
|
|
;; ---------------------------------------------------------------------
|
|
;;
|
|
;; This package implements a way to redefine functions in a controlled
|
|
;; and uniform way. It is modeled mainly after the "advice" package in
|
|
;; Emacs. If everyone uses this package when they redefine functions
|
|
;; in GWM, this will minimize the risk of collisions between different
|
|
;; packages redefining the same function. It will also prevent the
|
|
;; case that a function gets ruined because some file is (accidentally)
|
|
;; loaded twice, and then tries to redefine the same function twice.
|
|
;;
|
|
;; The main function 'advice' is used like this:
|
|
;; (advice <FUNCTION> <TAG> <TYPE> <BODY ...>)
|
|
;; The <TAG> is an atom which is used as a label for this piece of
|
|
;; advice. If the same function is adviced twice with the same label
|
|
;; (and with the same <TYPE>), the old advice will be replaced. Also it
|
|
;; makes it possible to remove a particular advice.
|
|
;; There are three possible values of <TYPE>: 'before', 'after', and
|
|
;; 'around', depending on whether the advice is to be run before, after,
|
|
;; or around the call to the original function.
|
|
;; <FUNCTION> can actually be either the function name, or a list with
|
|
;; the function name followed by formal arguments. These arguments will
|
|
;; then be bound to the corresponding actual arguments during execution
|
|
;; of the body. In both cases the symbol 'args' will be bound to the
|
|
;; whole argument list.
|
|
;; During execution of the body of an 'around' advice, the original
|
|
;; function name is temporarily rebound to the original function (or,
|
|
;; well, it's a little complicated, but something to that effect
|
|
;; anyway), so to mark where the original function should go you just
|
|
;; call the function again at that point. If you are not sure how many
|
|
;; arguments the function got, or don't want to use the optional
|
|
;; parameter list, you can always call the original function with the
|
|
;; construct '(apply <FUNCTION> args)'.
|
|
;; Note that if you advice a "macro" (ie defunq) its arguments is
|
|
;; unevaluated during the execution of the body, and still the "original"
|
|
;; function in an 'around' advice works like a macro, which means that
|
|
;; the arguments to the original call may be evaluated once too less if
|
|
;; you are not careful. In any case it should always work to call the
|
|
;; original function as '(apply <FUNCTION> args)'.
|
|
;;
|
|
;; There is also a function 'unadvice' which is used like this:
|
|
;; (unadvice <FUNCTION> [<TAG>])
|
|
;; It removes the advice with tag <TAG> from the function (or it
|
|
;; removes advices with that tag of all three advice types). If no
|
|
;; tag is given, all advices are removed, and the function is set to
|
|
;; its original again.
|
|
;;
|
|
;; If some package would like to be sure to use the original,
|
|
;; un-redefined version of some function by some reason, it can always
|
|
;; use '(advice-original <FUNCTION>)' to retrieve it. But NOTE, this
|
|
;; should *not* be used in the body of an 'around' advice, since this
|
|
;; would ruin other packages 'around' advices.
|
|
;;
|
|
|
|
(defun advice-embed-body (argl body)
|
|
(if (not argl)
|
|
(eval (+ '(lambda (args)) body))
|
|
(with (len (length argl)
|
|
ctx (list-make (* len 2))
|
|
i 0)
|
|
(while (< i len)
|
|
(## (* i 2) ctx (# i argl))
|
|
(## (+ (* i 2) 1) ctx (list '# i 'args))
|
|
(setq i (+ i 1)))
|
|
(eval (list 'lambda '(args) (+ (list 'with ctx) body))))))
|
|
|
|
(defun advice-construct-inner (hooks i symb origf)
|
|
(if (not hooks)
|
|
origf
|
|
(not (< i (length hooks)))
|
|
(if (member (type origf) '(fsubr fexpr))
|
|
(eval (` (lambdaq args
|
|
(with ((, symb)
|
|
(, (eval symb)))
|
|
(eval (+ (list (, origf)) args))))))
|
|
(eval (` (lambda args
|
|
(with ((, symb)
|
|
(, (eval symb)))
|
|
(eval (+ (list (, origf))
|
|
(mapfor ele args (list 'quote ele)))))))))
|
|
(if (member (type origf) '(fsubr fexpr))
|
|
(eval (` (lambdaq args
|
|
(with ((, symb)
|
|
(, (advice-construct-inner hooks (+ i 1) symb origf)))
|
|
((, (# i hooks)) args)))))
|
|
(eval (` (lambda args
|
|
(with ((, symb)
|
|
(, (advice-construct-inner hooks (+ i 1) symb origf)))
|
|
((, (# i hooks)) args))))))))
|
|
|
|
(defunq advice args
|
|
(with (func (if (= (type (# 0 args)) 'list)
|
|
(# 0 (# 0 args))
|
|
(# 0 args))
|
|
argl (if (= (type (# 0 args)) 'list)
|
|
(sublist 1 (length (# 0 args)) (# 0 args))
|
|
())
|
|
adtag (eval (# 1 args))
|
|
adtype (eval (# 2 args))
|
|
body (sublist 3 (length args) args)
|
|
origsymb (atom (+ "ad_" func "_orig"))
|
|
presymb (atom (+ "ad_" func "_pre"))
|
|
postsymb (atom (+ "ad_" func "_post"))
|
|
insymb (atom (+ "ad_" func "_in"))
|
|
hook () pos ())
|
|
(if (not (boundp origsymb))
|
|
(progn
|
|
(set origsymb (eval func))
|
|
(set presymb (copy '(() ())))
|
|
(set postsymb (copy '(() ())))
|
|
(set insymb (copy '(() () ())))
|
|
(set func (if (member (type (eval func)) '(fsubr fexpr))
|
|
(eval (` (lambdaq args
|
|
(with (ad_res ())
|
|
(for f (# 0 (, presymb)) (f args))
|
|
(setq ad_res
|
|
(eval (+ (list (# 2 (, insymb))) args)))
|
|
(for f (# 0 (, postsymb)) (f args))
|
|
ad_res))))
|
|
(eval (` (lambda args
|
|
(with (ad_res ())
|
|
(for f (# 0 (, presymb)) (f args))
|
|
(setq ad_res
|
|
(eval (+ (list (# 2 (, insymb)))
|
|
(mapfor e args (list 'quote e)))))
|
|
(for f (# 0 (, postsymb)) (f args))
|
|
ad_res))))))
|
|
(## 2 (eval insymb) (eval origsymb))))
|
|
(setq hook (if (= adtype 'before)
|
|
(eval presymb)
|
|
(= adtype 'after)
|
|
(eval postsymb)
|
|
(= adtype 'around)
|
|
(eval insymb)))
|
|
(setq pos (member adtag (# 1 hook)))
|
|
(if hook
|
|
(progn
|
|
(if pos
|
|
(## pos (# 0 hook) (advice-embed-body argl body))
|
|
(= adtype 'after)
|
|
(progn
|
|
(## 0 hook (+ (# 0 hook)
|
|
(list (advice-embed-body argl body))))
|
|
(## 1 hook (+ (# 1 hook) (list adtag))))
|
|
(progn
|
|
(## 0 hook (+ (list (advice-embed-body argl body))
|
|
(# 0 hook)))
|
|
(## 1 hook (+ (list adtag) (# 1 hook)))))
|
|
(if (= adtype 'around)
|
|
(## 2 hook (advice-construct-inner (# 0 hook) 0 func (eval origsymb))))
|
|
)
|
|
(? "Bad advice type: " adtype))
|
|
(if hook t ())))
|
|
|
|
(defunq unadvice args
|
|
(with (func (if (= (type (# 0 args)) 'list)
|
|
(# 0 (# 0 args))
|
|
(# 0 args))
|
|
adtag (eval (# 1 args))
|
|
origsymb (atom (+ "ad_" func "_orig"))
|
|
presymb (atom (+ "ad_" func "_pre"))
|
|
postsymb (atom (+ "ad_" func "_post"))
|
|
insymb (atom (+ "ad_" func "_in"))
|
|
hook () pos () ret ())
|
|
(if (boundp origsymb)
|
|
(if adtag
|
|
(progn
|
|
(for hook (list (eval presymb) (eval postsymb) (eval insymb))
|
|
(setq pos (member adtag (# 1 hook)))
|
|
(if pos
|
|
(progn
|
|
(setq ret t)
|
|
(delete-nth pos (# 0 hook))
|
|
(delete-nth pos (# 1 hook)))))
|
|
(if pos
|
|
(## 2 hook (advice-construct-inner (# 0 hook)
|
|
0 func (eval origsymb))))
|
|
ret)
|
|
(progn
|
|
(set func (eval origsymb))
|
|
(unbind presymb)
|
|
(unbind postsymb)
|
|
(unbind insymb)
|
|
(unbind origsymb)
|
|
t)))))
|
|
|
|
(defunq advice-original (func)
|
|
(with (origsymb (atom (+ "ad_" func "_orig")))
|
|
(if (boundp origsymb)
|
|
(eval origsymb)
|
|
(eval func))))
|