bug#3984: Fix case where call-interactively is advised

[Ryan <rct@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)