From: Ryan <rct@thompsonclan.org>
To: Stefan Monnier <monnier@iro.umontreal.ca>
Cc: 3984@debbugs.gnu.org
Subject: bug#3984: Fix case where call-interactively is advised
Date: Thu, 19 Sep 2013 21:58:29 -0700 [thread overview]
Message-ID: <523BD5F5.1020600@thompsonclan.org> (raw)
In-Reply-To: <523BCDBB.3000202@thompsonclan.org>
[-- Attachment #1: Type: text/plain, Size: 1105 bytes --]
Here is a patch that applies over my previous patch and fixes
"advice-test-called-interactively-p-4", which tests whether
called-interactively-p returns the correct result when
call-interactively is advised.
On 9/19/13 9:23 PM, Ryan wrote:
> After a little more consideration, I think I know what the bug is. The
> goal of "advice--called-interactively-skip" is to skip all the
> advice-related stack frames of the called function, not advice-related
> stack frames for advice on call-interactively.
>
> I also came up with an idea to address this issue: a second function
> added to called-interactively-p-functions that checks the current
> stack frame for equality to the unadvised form of call-interactively
> and if it finds it, skips past all the advice frames to the outermost
> call. This will make it so that advising call-interactively does not
> affect the return of called-interactively-p, but it will not fix the
> "innermost around advice" problem.
>
> I'm trying to code up a solution now. I'll eventually find my way
> through the twisty maze of fencepost errors.
>
> -Ryan
[-- Attachment #2: fix-advised-call-interactively.diff --]
[-- Type: text/plain, Size: 2809 bytes --]
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 8b149aa..2dab864 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -461,6 +461,36 @@ of the piece of advice."
(funcall get-next-frame))))
(- i origi 1))))
+(defun advice-unadvised-form (func)
+ "Return the definition of FUNC with all advice stripped.
+
+FUNC may be a function definition or a symbol naming a function."
+ (let ((func (indirect-function func)))
+ (while (advice--p func)
+ (setq func (advice--cdr func)))
+ func))
+
+;; When `call-interactively' is advised, called-interactively-p needs
+;; to be taught to skip the advising frames.
+(add-hook 'called-interactively-p-functions
+ #'advice--advised-called-interactively-skip)
+(defun advice--advised-called-interactively-skip (origi frame1 frame2)
+ (when (and frame2
+ (not (eq (nth 1 frame2) 'call-interactively))
+ (eq (advice-unadvised-form 'call-interactively)
+ (indirect-function (nth 1 frame2))))
+ ;; Skip until frame2 is a call to the symbol call-interactively.
+ (let* ((i origi)
+ (get-next-frame
+ (lambda ()
+ (setq frame1 frame2)
+ (setq frame2 (internal--called-interactively-p--get-frame i))
+ (setq i (1+ i)))))
+ (funcall get-next-frame)
+ (while (and frame2
+ (not (eq (nth 1 frame2) 'call-interactively)))
+ (funcall get-next-frame))
+ (- i origi 1))))
(provide 'nadvice)
;;; nadvice.el ends here
diff --git a/lisp/subr.el b/lisp/subr.el
index 75c6b3a..b5f682a 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4272,8 +4272,6 @@ command is called from a keyboard macro?"
(_ (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)
diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el
index c8f06e5..01be3ab 100644
--- a/test/automated/advice-tests.el
+++ b/test/automated/advice-tests.el
@@ -163,7 +163,6 @@ This tests the case of the innermost advice being before"
This tests the case where call-interactively itself is advised,
which is currently broken."
- :expected-result :failed
(defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p)))
(post-restore-func call-interactively
(advice-add 'call-interactively :before #'ignore)
next prev parent reply other threads:[~2013-09-20 4:58 UTC|newest]
Thread overview: 37+ messages / expand[flat|nested] mbox.gz Atom feed top
2009-07-30 22:37 bug#3984: 23.0.96; defadvice of call-interactively defeats interactive-p Drew Adams
2009-07-31 1:58 ` Stefan Monnier
2009-07-31 14:19 ` Drew Adams
2009-07-31 19:31 ` Stefan Monnier
2009-07-31 20:04 ` Drew Adams
2011-10-10 6:00 ` Kai Tetzlaff
2011-10-11 14:26 ` Drew Adams
2011-10-11 15:46 ` Stefan Monnier
2011-10-11 16:05 ` Drew Adams
2013-09-10 20:29 ` Christopher Wellons
2013-09-11 0:29 ` Stefan Monnier
2013-09-13 8:56 ` bug#3984: Fix for #3984 Ryan
2013-09-13 13:18 ` Stefan Monnier
2013-09-13 18:30 ` Ryan
2013-09-13 19:27 ` Ryan
2013-09-13 21:02 ` Stefan Monnier
2013-09-17 3:18 ` Ryan
2013-09-17 13:10 ` Stefan Monnier
2013-09-17 17:22 ` bug#3984: Ryan
2013-09-18 1:46 ` bug#3984: Stefan Monnier
2013-09-18 23:30 ` bug#3984: Ryan
2013-09-19 0:47 ` bug#3984: Ryan
2013-09-19 3:38 ` bug#3984: Stefan Monnier
2013-09-19 8:06 ` bug#3984: Ryan
2013-09-19 19:23 ` bug#3984: Ryan
2013-09-19 20:59 ` bug#3984: Stefan Monnier
2013-09-19 21:59 ` bug#3984: Ryan
2013-09-20 4:23 ` bug#3984: Ryan
2013-09-20 4:58 ` Ryan [this message]
2013-09-20 5:03 ` bug#3984: Ryan
2013-09-20 14:35 ` bug#3984: Stefan Monnier
2013-09-20 16:54 ` bug#3984: Ryan
2013-09-20 16:56 ` bug#3984: Ryan
2013-09-20 14:54 ` bug#3984: Stefan Monnier
2013-09-20 16:50 ` bug#3984: Ryan
2013-09-20 19:59 ` bug#3984: Stefan Monnier
2013-09-13 10:24 ` bug#3984: bug#123: Potential fix Ryan
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=523BD5F5.1020600@thompsonclan.org \
--to=rct@thompsonclan.org \
--cc=3984@debbugs.gnu.org \
--cc=monnier@iro.umontreal.ca \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.