procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make called-interactively-p work for edebug or advised code.

Browse source 
* lisp/subr.el (called-interactively-p-functions): New var.
(internal--called-interactively-p--get-frame): New macro.
(called-interactively-p, interactive-p): Rewrite in Lisp.
* lisp/emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun.
(called-interactively-p-functions): Use it.
* lisp/emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun.
(called-interactively-p-functions): Use it.
* lisp/allout.el (allout-called-interactively-p): Don't assume
called-interactively-p is a subr.
* src/eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove.
(syms_of_eval): Remove corresponding defsubr.
* src/bytecode.c (exec_byte_code): `interactive-p' is now a Lisp function.
* test/automated/advice-tests.el (advice-tests--data): Remove.
(advice-tests): Move the tests directly here instead.
Add called-interactively-p tests.
This commit is contained in:
Stefan Monnier 2012-11-19 23:24:09 -05:00
parent b0636be7f9
commit 23ba2705e2
10 changed files with 336 additions and 186 deletions
Download patch file Download diff file Expand all files Collapse all files

12
lisp/ChangeLog
View file

@ -1,3 +1,15 @@
2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca>
* subr.el (called-interactively-p-functions): New var.
(internal--called-interactively-p--get-frame): New macro.
(called-interactively-p, interactive-p): Rewrite in Lisp.
* emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun.
(called-interactively-p-functions): Use it.
* emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun.
(called-interactively-p-functions): Use it.
* allout.el (allout-called-interactively-p): Don't assume
called-interactively-p is a subr.
2012-11-20 Glenn Morris <rgm@gnu.org> 2012-11-20 Glenn Morris <rgm@gnu.org>
* profiler.el (profiler-report-mode-map): Add a menu. * profiler.el (profiler-report-mode-map): Add a menu.

7
lisp/allout.el
View file

@ -1657,10 +1657,9 @@ and the place for the cursor after the decryption is done."
(defmacro allout-called-interactively-p () (defmacro allout-called-interactively-p ()
"A version of `called-interactively-p' independent of Emacs version." "A version of `called-interactively-p' independent of Emacs version."
;; ... to ease maintenance of allout without betraying deprecation. ;; ... to ease maintenance of allout without betraying deprecation.
(if (equal (subr-arity (symbol-function 'called-interactively-p)) (if (ignore-errors (called-interactively-p 'interactive) t)
'(0 . 0)) '(called-interactively-p 'interactive)
'(called-interactively-p) '(called-interactively-p)))
'(called-interactively-p 'interactive)))
;;;_ = allout-inhibit-aberrance-doublecheck nil ;;;_ = allout-inhibit-aberrance-doublecheck nil
;; In some exceptional moments, disparate topic depths need to be allowed ;; In some exceptional moments, disparate topic depths need to be allowed
;; momentarily, eg when one topic is being yanked into another and they're ;; momentarily, eg when one topic is being yanked into another and they're

15
lisp/emacs-lisp/edebug.el
View file

@ -4268,6 +4268,21 @@ With prefix argument, make it a temporary breakpoint."
;;; Finalize Loading ;;; Finalize Loading
;; When edebugging a function, some of the sub-expressions are
;; wrapped in (edebug-enter (lambda () ..)), so we need to teach
;; called-interactively-p that calls within the inner lambda should refer to
;; the outside function.
(add-hook 'called-interactively-p-functions
#'edebug--called-interactively-skip)
(defun edebug--called-interactively-skip (i frame1 frame2)
(when (and (eq (car-safe (nth 1 frame1)) 'lambda)
(eq (nth 1 (nth 1 frame1)) '())
(eq (nth 1 frame2) 'edebug-enter))
;; `edebug-enter' calls itself on its first invocation.
(if (eq (nth 1 (internal--called-interactively-p--get-frame i))
'edebug-enter)
2 1)))
;; Finally, hook edebug into the rest of Emacs. ;; Finally, hook edebug into the rest of Emacs.
;; There are probably some other things that could go here. ;; There are probably some other things that could go here.

50
lisp/emacs-lisp/nadvice.el
View file

@ -402,6 +402,56 @@ of the piece of advice."
(if (fboundp function-name) (if (fboundp function-name)
(symbol-function function-name)))))) (symbol-function function-name))))))
;; When code is advised, called-interactively-p needs to be taught to skip
;; the advising frames.
;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p
;; done from the advised function if the deepest advice is an around advice!
;; In other cases (calls from an advice or calls from the advised function when
;; the deepest advice is not an around advice), it should hopefully get
;; it right.
(add-hook 'called-interactively-p-functions
#'advice--called-interactively-skip)
(defun advice--called-interactively-skip (origi frame1 frame2)
(let* ((i origi)
(get-next-frame
(lambda ()
(setq frame1 frame2)
(setq frame2 (internal--called-interactively-p--get-frame i))
;; (message "Advice Frame %d = %S" i frame2)
(setq i (1+ i)))))
(when (and (eq (nth 1 frame2) 'apply)
(progn
(funcall get-next-frame)
(advice--p (indirect-function (nth 1 frame2)))))
(funcall get-next-frame)
;; If we now have the symbol, this was the head advice and
;; we're done.
(while (advice--p (nth 1 frame1))
;; This was an inner advice called from some earlier advice.
;; The stack frames look different depending on the particular
;; kind of the earlier advice.
(let ((inneradvice (nth 1 frame1)))
(if (and (eq (nth 1 frame2) 'apply)
(progn
(funcall get-next-frame)
(advice--p (indirect-function
(nth 1 frame2)))))
;; The earlier advice was something like a before/after
;; advice where the "next" code is called directly by the
;; advice--p object.
(funcall get-next-frame)
;; It's apparently an around advice, where the "next" is
;; called by the body of the advice in any way it sees fit,
;; so we need to skip the frames of that body.
(while
(progn
(funcall get-next-frame)
(not (and (eq (nth 1 frame2) 'apply)
(eq (nth 3 frame2) inneradvice)))))
(funcall get-next-frame)
(funcall get-next-frame))))
(- i origi 1))))
(provide 'nadvice) (provide 'nadvice)
;;; nadvice.el ends here ;;; nadvice.el ends here

148
lisp/subr.el
View file

@ -1191,8 +1191,6 @@ is converted into a string by expressing it in decimal."
(make-obsolete 'unfocus-frame "it does nothing." "22.1") (make-obsolete 'unfocus-frame "it does nothing." "22.1")
(make-obsolete 'make-variable-frame-local (make-obsolete 'make-variable-frame-local
"explicitly check for a frame-parameter instead." "22.2") "explicitly check for a frame-parameter instead." "22.2")
(make-obsolete 'interactive-p 'called-interactively-p "23.2")
(set-advertised-calling-convention 'called-interactively-p '(kind) "23.1")
(set-advertised-calling-convention (set-advertised-calling-convention
'all-completions '(string collection &optional predicate) "23.1") 'all-completions '(string collection &optional predicate) "23.1")
(set-advertised-calling-convention 'unintern '(name obarray) "23.3") (set-advertised-calling-convention 'unintern '(name obarray) "23.3")
@ -3963,6 +3961,152 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
(put symbol 'abortfunc (or abortfunc 'kill-buffer)) (put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook))) (put symbol 'hookvar (or hookvar 'mail-send-hook)))
(defvar called-interactively-p-functions nil
"Special hook called to skip special frames in `called-interactively-p'.
The functions are called with 3 arguments: (I FRAME1 FRAME2),
where FRAME1 is a \"current frame\", FRAME2 is the next frame,
I is the index of the frame after FRAME2. It should return nil
if those frames don't seem special and otherwise, it should return
the number of frames to skip (minus 1).")
(defmacro internal--called-interactively-p--get-frame (n)
;; `sym' will hold a global variable, which will be used kind of like C's
;; "static" variables.
(let ((sym (make-symbol "base-index")))
`(progn
(defvar ,sym
(let ((i 1))
(while (not (eq (nth 1 (backtrace-frame i))
'called-interactively-p))
(setq i (1+ i)))
i))
;; (unless (eq (nth 1 (backtrace-frame ,sym)) 'called-interactively-p)
;; (error "called-interactively-p: %s is out-of-sync!" ,sym))
(backtrace-frame (+ ,sym ,n)))))
(defun called-interactively-p (&optional kind)
"Return t if the containing function was called by `call-interactively'.
If KIND is `interactive', then only return t if the call was made
interactively by the user, i.e. not in `noninteractive' mode nor
when `executing-kbd-macro'.
If KIND is `any', on the other hand, it will return t for any kind of
interactive call, including being called as the binding of a key or
from a keyboard macro, even in `noninteractive' mode.
This function is very brittle, it may fail to return the intended result when
the code is debugged, advised, or instrumented in some form. Some macros and
special forms (such as `condition-case') may also sometimes wrap their bodies
in a `lambda', so any call to `called-interactively-p' from those bodies will
indicate whether that lambda (rather than the surrounding function) was called
interactively.
Instead of using this function, it is cleaner and more reliable to give your
function an extra optional argument whose `interactive' spec specifies
non-nil unconditionally (\"p\" is a good way to do this), or via
\(not (or executing-kbd-macro noninteractive)).
The only known proper use of `interactive' for KIND is in deciding
whether to display a helpful message, or how to display it. If you're
thinking of using it for any other purpose, it is quite likely that
you're making a mistake. Think: what do you want to do when the
command is called from a keyboard macro?"
(declare (advertised-calling-convention (kind) "23.1"))
(when (not (and (eq kind 'interactive)
(or executing-kbd-macro noninteractive)))
(let* ((i 1) ;; 0 is the called-interactively-p frame.
frame nextframe
(get-next-frame
(lambda ()
(setq frame nextframe)
(setq nextframe (internal--called-interactively-p--get-frame i))
;; (message "Frame %d = %S" i nextframe)
(setq i (1+ i)))))
(funcall get-next-frame) ;; Get the first frame.
(while
;; FIXME: The edebug and advice handling should be made modular and
;; provided directly by edebug.el and nadvice.el.
(progn
;; frame =(backtrace-frame i-2)
;; nextframe=(backtrace-frame i-1)
(funcall get-next-frame)
;; `pcase' would be a fairly good fit here, but it sometimes moves
;; branches within local functions, which then messes up the
;; `backtrace-frame' data we get,
(or
;; Skip special forms (from non-compiled code).
(and frame (null (car frame)))
;; Skip also `interactive-p' (because we don't want to know if
;; interactive-p was called interactively but if it's caller was)
;; and `byte-code' (idem; this appears in subexpressions of things
;; like condition-case, which are wrapped in a separate bytecode
;; chunk).
;; FIXME: For lexical-binding code, this is much worse,
;; because the frames look like "byte-code -> funcall -> #[...]",
;; which is not a reliable signature.
(memq (nth 1 frame) '(interactive-p 'byte-code))
;; Skip package-specific stack-frames.
(let ((skip (run-hook-with-args-until-success
'called-interactively-p-functions
i frame nextframe)))
(pcase skip
(`nil nil)
(`0 t)
(_ (setq i (+ i skip -1)) (funcall get-next-frame)))))))
;; Now `frame' should be "the function from which we were called".
(pcase (cons frame nextframe)
;; No subr calls `interactive-p', so we can rule that out.
(`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
;; Somehow, I sometimes got `command-execute' rather than
;; `call-interactively' on my stacktrace !?
;;(`(,_ . (t command-execute . ,_)) t)
(`(,_ . (t call-interactively . ,_)) t)))))
(defun interactive-p ()
"Return t if the containing function was run directly by user input.
This means that the function was called with `call-interactively'
\(which includes being called as the binding of a key)
and input is currently coming from the keyboard (not a keyboard macro),
and Emacs is not running in batch mode (`noninteractive' is nil).
The only known proper use of `interactive-p' is in deciding whether to
display a helpful message, or how to display it. If you're thinking
of using it for any other purpose, it is quite likely that you're
making a mistake. Think: what do you want to do when the command is
called from a keyboard macro or in batch mode?
To test whether your function was called with `call-interactively',
either (i) add an extra optional argument and give it an `interactive'
spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
use `called-interactively-p'."
(declare (obsolete called-interactively-p "23.2"))
(called-interactively-p 'interactive))
(defun function-arity (f &optional num)
"Return the (MIN . MAX) arity of F.
If the maximum arity is infinite, MAX is `many'.
F can be a function or a macro.
If NUM is non-nil, return non-nil iff F can be called with NUM args."
(if (symbolp f) (setq f (indirect-function f)))
(if (eq (car-safe f) 'macro) (setq f (cdr f)))
(let ((res
(if (subrp f)
(let ((x (subr-arity f)))
(if (eq (cdr x) 'unevalled) (cons (car x) 'many)))
(let* ((args (if (consp f) (cadr f) (aref f 0)))
(max (length args))
(opt (memq '&optional args))
(rest (memq '&rest args))
(min (- max (length opt))))
(if opt
(cons min (if rest 'many (1- max)))
(if rest
(cons (- max (length rest)) 'many)
(cons min max)))))))
(if (not num)
res
(and (>= num (car res))
(or (eq 'many (cdr res)) (<= num (cdr res)))))))
(defun set-temporary-overlay-map (map &optional keep-pred) (defun set-temporary-overlay-map (map &optional keep-pred)
"Set MAP as a temporary keymap taking precedence over most other keymaps. "Set MAP as a temporary keymap taking precedence over most other keymaps.
Note that this does NOT take precedence over the \"overriding\" maps Note that this does NOT take precedence over the \"overriding\" maps

18
src/ChangeLog
View file

@ -1,3 +1,9 @@
2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca>
* eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove.
(syms_of_eval): Remove corresponding defsubr.
* bytecode.c (exec_byte_code): `interactive-p' is now a Lisp function.
2012-11-19 Daniel Colascione <dancol@dancol.org> 2012-11-19 Daniel Colascione <dancol@dancol.org>
* w32fns.c (Fx_file_dialog): * w32fns.c (Fx_file_dialog):
@ -17,10 +23,10 @@
windows.h gets included before w32term.h uses some of its windows.h gets included before w32term.h uses some of its
features, see below. features, see below.
* w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]: New * w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]:
typedefs. New typedefs.
(EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]: New (EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]:
prototypes. New prototypes.
(EnumSystemLocales) [_MSC_VER]: Define if undefined. (Bug#12878) (EnumSystemLocales) [_MSC_VER]: Define if undefined. (Bug#12878)
2012-11-18 Jan Djärv <jan.h.d@swipnet.se> 2012-11-18 Jan Djärv <jan.h.d@swipnet.se>
@ -312,8 +318,8 @@
* xdisp.c (try_scrolling): Fix correction of aggressive-scroll * xdisp.c (try_scrolling): Fix correction of aggressive-scroll
amount when the scroll margins are too large. When scrolling amount when the scroll margins are too large. When scrolling
backwards in the buffer, give up if cannot reach point or the backwards in the buffer, give up if cannot reach point or the
scroll margin within a reasonable number of screen lines. Fixes scroll margin within a reasonable number of screen lines.
point position in window under scroll-up/down-aggressively when Fixes point position in window under scroll-up/down-aggressively when
point is positioned many lines beyond the window top/bottom. point is positioned many lines beyond the window top/bottom.
(Bug#12811) (Bug#12811)

4
src/bytecode.c
View file

@ -1579,7 +1579,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
NEXT; NEXT;
CASE (Binteractive_p): /* Obsolete since 24.1. */ CASE (Binteractive_p): /* Obsolete since 24.1. */
PUSH (Finteractive_p ()); BEFORE_POTENTIAL_GC ();
PUSH (call0 (intern ("interactive-p")));
AFTER_POTENTIAL_GC ();
NEXT; NEXT;
CASE (Bforward_char): CASE (Bforward_char):

105
src/eval.c
View file

@ -489,102 +489,6 @@ usage: (function ARG) */)
} }
DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
doc: /* Return t if the containing function was run directly by user input.
This means that the function was called with `call-interactively'
\(which includes being called as the binding of a key)
and input is currently coming from the keyboard (not a keyboard macro),
and Emacs is not running in batch mode (`noninteractive' is nil).
The only known proper use of `interactive-p' is in deciding whether to
display a helpful message, or how to display it. If you're thinking
of using it for any other purpose, it is quite likely that you're
making a mistake. Think: what do you want to do when the command is
called from a keyboard macro?
To test whether your function was called with `call-interactively',
either (i) add an extra optional argument and give it an `interactive'
spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
use `called-interactively-p'. */)
(void)
{
return (INTERACTIVE && interactive_p ()) ? Qt : Qnil;
}
DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 1, 0,
doc: /* Return t if the containing function was called by `call-interactively'.
If KIND is `interactive', then only return t if the call was made
interactively by the user, i.e. not in `noninteractive' mode nor
when `executing-kbd-macro'.
If KIND is `any', on the other hand, it will return t for any kind of
interactive call, including being called as the binding of a key, or
from a keyboard macro, or in `noninteractive' mode.
The only known proper use of `interactive' for KIND is in deciding
whether to display a helpful message, or how to display it. If you're
thinking of using it for any other purpose, it is quite likely that
you're making a mistake. Think: what do you want to do when the
command is called from a keyboard macro?
Instead of using this function, it is sometimes cleaner to give your
function an extra optional argument whose `interactive' spec specifies
non-nil unconditionally (\"p\" is a good way to do this), or via
\(not (or executing-kbd-macro noninteractive)). */)
(Lisp_Object kind)
{
return (((INTERACTIVE || !EQ (kind, intern ("interactive")))
&& interactive_p ())
? Qt : Qnil);
}
/* Return true if function in which this appears was called using
call-interactively and is not a built-in. */
static bool
interactive_p (void)
{
struct backtrace *btp;
Lisp_Object fun;
btp = backtrace_list;
/* If this isn't a byte-compiled function, there may be a frame at
the top for Finteractive_p. If so, skip it. */
fun = Findirect_function (btp->function, Qnil);
if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p
|| XSUBR (fun) == &Scalled_interactively_p))
btp = btp->next;
/* If we're running an Emacs 18-style byte-compiled function, there
may be a frame for Fbytecode at the top level. In any version of
Emacs there can be Fbytecode frames for subexpressions evaluated
inside catch and condition-case. Skip past them.
If this isn't a byte-compiled function, then we may now be
looking at several frames for special forms. Skip past them. */
while (btp
&& (EQ (btp->function, Qbytecode)
|| btp->nargs == UNEVALLED))
btp = btp->next;
/* `btp' now points at the frame of the innermost function that isn't
a special form, ignoring frames for Finteractive_p and/or
Fbytecode at the top. If this frame is for a built-in function
(such as load or eval-region) return false. */
fun = Findirect_function (btp->function, Qnil);
if (SUBRP (fun))
return 0;
/* `btp' points to the frame of a Lisp function that called interactive-p.
Return t if that function was called interactively. */
if (btp && btp->next && EQ (btp->next->function, Qcall_interactively))
return 1;
return 0;
}
DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE. doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
Aliased variables always have the same value; setting one sets the other. Aliased variables always have the same value; setting one sets the other.
@ -696,7 +600,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
if (EQ ((--pdl)->symbol, sym) && !pdl->func if (EQ ((--pdl)->symbol, sym) && !pdl->func
&& EQ (pdl->old_value, Qunbound)) && EQ (pdl->old_value, Qunbound))
{ {
message_with_string ("Warning: defvar ignored because %s is let-bound", message_with_string
("Warning: defvar ignored because %s is let-bound",
SYMBOL_NAME (sym), 1); SYMBOL_NAME (sym), 1);
break; break;
} }
@ -717,8 +622,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
/* A simple (defvar foo) with lexical scoping does "nothing" except /* A simple (defvar foo) with lexical scoping does "nothing" except
declare that var to be dynamically scoped *locally* (i.e. within declare that var to be dynamically scoped *locally* (i.e. within
the current file or let-block). */ the current file or let-block). */
Vinternal_interpreter_environment = Vinternal_interpreter_environment
Fcons (sym, Vinternal_interpreter_environment); = Fcons (sym, Vinternal_interpreter_environment);
else else
{ {
/* Simple (defvar <var>) should not count as a definition at all. /* Simple (defvar <var>) should not count as a definition at all.
@ -3551,8 +3456,6 @@ alist of active lexical bindings. */);
defsubr (&Sunwind_protect); defsubr (&Sunwind_protect);
defsubr (&Scondition_case); defsubr (&Scondition_case);
defsubr (&Ssignal); defsubr (&Ssignal);
defsubr (&Sinteractive_p);
defsubr (&Scalled_interactively_p);
defsubr (&Scommandp); defsubr (&Scommandp);
defsubr (&Sautoload); defsubr (&Sautoload);
defsubr (&Sautoload_do_load); defsubr (&Sautoload_do_load);

6
test/ChangeLog
View file

@ -1,3 +1,9 @@
2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/advice-tests.el (advice-tests--data): Remove.
(advice-tests): Move the tests directly here instead.
Add called-interactively-p tests.
2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> 2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/ert-x-tests.el: Use cl-lib. * automated/ert-x-tests.el: Use cl-lib.

155
test/automated/advice-tests.el
View file

@ -21,80 +21,93 @@
;;; Code: ;;; Code:
(defvar advice-tests--data
'(((defun sm-test1 (x) (+ x 4))
(sm-test1 6) 10)
((advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
(sm-test1 6) 50)
((defun sm-test1 (x) (+ x 14))
(sm-test1 6) 100)
((null (get 'sm-test1 'defalias-fset-function)) nil)
((advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
(sm-test1 6) 20)
((null (get 'sm-test1 'defalias-fset-function)) t)
((defun sm-test2 (x) (+ x 4))
(sm-test2 6) 10)
((defadvice sm-test2 (around sm-test activate)
ad-do-it (setq ad-return-value (* ad-return-value 5)))
(sm-test2 6) 50)
((ad-deactivate 'sm-test2)
(sm-test2 6) 10)
((ad-activate 'sm-test2)
(sm-test2 6) 50)
((defun sm-test2 (x) (+ x 14))
(sm-test2 6) 100)
((null (get 'sm-test2 'defalias-fset-function)) nil)
((ad-remove-advice 'sm-test2 'around 'sm-test)
(sm-test2 6) 100)
((ad-activate 'sm-test2)
(sm-test2 6) 20)
((null (get 'sm-test2 'defalias-fset-function)) t)
((advice-add 'sm-test3 :around
(lambda (f &rest args) `(toto ,(apply f args)))
'((name . wrap-with-toto)))
(defmacro sm-test3 (x) `(call-test3 ,x))
(macroexpand '(sm-test3 56)) (toto (call-test3 56)))
((defadvice sm-test4 (around wrap-with-toto activate)
ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
(defmacro sm-test4 (x) `(call-test4 ,x))
(macroexpand '(sm-test4 56)) (toto (call-test4 56)))
((defmacro sm-test4 (x) `(call-testq ,x))
(macroexpand '(sm-test4 56)) (toto (call-testq 56)))
;; Combining old style and new style advices.
((defun sm-test5 (x) (+ x 4))
(sm-test5 6) 10)
((advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
(sm-test5 6) 50)
((defadvice sm-test5 (around test activate)
ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
(sm-test5 5) 45.1)
((ad-deactivate 'sm-test5)
(sm-test5 6) 50)
((ad-activate 'sm-test5)
(sm-test5 6) 50.1)
((defun sm-test5 (x) (+ x 14))
(sm-test5 6) 100.1)
((advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
(sm-test5 6) 20.1)
;; This used to signal an error (bug#12858).
((autoload 'sm-test6 "foo")
(defadvice sm-test6 (around test activate)
ad-do-it)
t t)
))
(ert-deftest advice-tests () (ert-deftest advice-tests ()
"Test advice code." "Test advice code."
(with-temp-buffer (with-temp-buffer
(dolist (test advice-tests--data) (defun sm-test1 (x) (+ x 4))
(let ((res (eval `(progn ,@(butlast test))))) (should (equal (sm-test1 6) 10))
(should (equal (car (last test)) res)))))) (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
(should (equal (sm-test1 6) 50))
(defun sm-test1 (x) (+ x 14))
(should (equal (sm-test1 6) 100))
(should (equal (null (get 'sm-test1 'defalias-fset-function)) nil))
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
(should (equal (sm-test1 6) 20))
(should (equal (null (get 'sm-test1 'defalias-fset-function)) t))
(defun sm-test2 (x) (+ x 4))
(should (equal (sm-test2 6) 10))
(defadvice sm-test2 (around sm-test activate)
ad-do-it (setq ad-return-value (* ad-return-value 5)))
(should (equal (sm-test2 6) 50))
(ad-deactivate 'sm-test2)
(should (equal (sm-test2 6) 10))
(ad-activate 'sm-test2)
(should (equal (sm-test2 6) 50))
(defun sm-test2 (x) (+ x 14))
(should (equal (sm-test2 6) 100))
(should (equal (null (get 'sm-test2 'defalias-fset-function)) nil))
(ad-remove-advice 'sm-test2 'around 'sm-test)
(should (equal (sm-test2 6) 100))
(ad-activate 'sm-test2)
(should (equal (sm-test2 6) 20))
(should (equal (null (get 'sm-test2 'defalias-fset-function)) t))
(advice-add 'sm-test3 :around
(lambda (f &rest args) `(toto ,(apply f args)))
'((name . wrap-with-toto)))
(defmacro sm-test3 (x) `(call-test3 ,x))
(should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))
(defadvice sm-test4 (around wrap-with-toto activate)
ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
(defmacro sm-test4 (x) `(call-test4 ,x))
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56))))
(defmacro sm-test4 (x) `(call-testq ,x))
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56))))
;; Combining old style and new style advices.
(defun sm-test5 (x) (+ x 4))
(should (equal (sm-test5 6) 10))
(advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
(should (equal (sm-test5 6) 50))
(defadvice sm-test5 (around test activate)
ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
(should (equal (sm-test5 5) 45.1))
(ad-deactivate 'sm-test5)
(should (equal (sm-test5 6) 50))
(ad-activate 'sm-test5)
(should (equal (sm-test5 6) 50.1))
(defun sm-test5 (x) (+ x 14))
(should (equal (sm-test5 6) 100.1))
(advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
(should (equal (sm-test5 6) 20.1))
;; This used to signal an error (bug#12858).
(autoload 'sm-test6 "foo")
(defadvice sm-test6 (around test activate)
ad-do-it)
;; Check interaction between advice and called-interactively-p.
(defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
(advice-add 'sm-test7 :around
(lambda (f &rest args)
(list (cons 1 (called-interactively-p)) (apply f args))))
(should (equal (sm-test7) '((1 . nil) 11)))
(should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
(let ((smi 7))
(advice-add 'sm-test7 :before
(lambda (&rest args)
(setq smi (called-interactively-p))))
(should (equal (list (sm-test7) smi)
'(((1 . nil) 11) nil)))
(should (equal (list (call-interactively 'sm-test7) smi)
'(((1 . t) 11) t))))
(advice-add 'sm-test7 :around
(lambda (f &rest args)
(cons (cons 2 (called-interactively-p)) (apply f args))))
(should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))
))
;; Local Variables: ;; Local Variables:
;; no-byte-compile: t ;; no-byte-compile: t