lisp/emacs-lisp/trace.el

   1 ;;; trace.el --- tracing facility for Emacs Lisp functions  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 1993, 1998, 2000-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
   6 ;; Maintainer: FSF
   7 ;; Created: 15 Dec 1992
   8 ;; Keywords: tools, lisp
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;; LCD Archive Entry:
  26 ;; trace|Hans Chalupsky|hans@cs.buffalo.edu|
  27 ;; Tracing facility for Emacs Lisp functions|
  28 ;; 1993/05/18 00:41:16|2.0|~/packages/trace.el.Z|
  29
  30
  31 ;;; Commentary:
  32
  33 ;; Introduction:
  34 ;; =============
  35 ;; A simple trace package that utilizes advice.el. It generates trace
  36 ;; information in a Lisp-style fashion and inserts it into a trace output
  37 ;; buffer. Tracing can be done in the background (or silently) so that
  38 ;; generation of trace output won't interfere with what you are currently
  39 ;; doing.
  40
  41 ;; Restrictions:
  42 ;; =============
  43 ;; - Traced subrs when called interactively will always show nil as the
  44 ;;   value of their arguments.
  45 ;; - Only functions/macros/subrs that are called via their function cell will
  46 ;;   generate trace output, hence, you won't get trace output for:
  47 ;;   + Subrs called directly from other subrs/C-code
  48 ;;   + Compiled calls to subrs that have special byte-codes associated
  49 ;;     with them (e.g., car, cdr, ...)
  50 ;;   + Macros that were expanded during compilation
  51 ;; - All the restrictions that apply to advice.el
  52
  53 ;; Usage:
  54 ;; ======
  55 ;; - To trace a function say `M-x trace-function' which will ask you for the
  56 ;;   name of the function/subr/macro to trace, as well as for the buffer
  57 ;;   into which trace output should go.
  58 ;; - If you want to trace a function that switches buffers or does other
  59 ;;   display oriented stuff use `M-x trace-function-background' which will
  60 ;;   generate the trace output silently in the background without popping
  61 ;;   up windows and doing other irritating stuff.
  62 ;; - To untrace a function say `M-x untrace-function'.
  63 ;; - To untrace all currently traced functions say `M-x untrace-all'.
  64
  65 ;; Examples:
  66 ;; =========
  67 ;;
  68 ;;  (defun fact (n)
  69 ;;    (if (= n 0) 1
  70 ;;      (* n (fact (1- n)))))
  71 ;;  fact
  72 ;;
  73 ;;  (trace-function 'fact)
  74 ;;  fact
  75 ;;
  76 ;;  Now, evaluating this...
  77 ;;
  78 ;;  (fact 4)
  79 ;;  24
  80 ;;
  81 ;;  ...will generate the following in *trace-buffer*:
  82 ;;
  83 ;;  1 -> fact: n=4
  84 ;;  | 2 -> fact: n=3
  85 ;;  | | 3 -> fact: n=2
  86 ;;  | | | 4 -> fact: n=1
  87 ;;  | | | | 5 -> fact: n=0
  88 ;;  | | | | 5 <- fact: 1
  89 ;;  | | | 4 <- fact: 1
  90 ;;  | | 3 <- fact: 2
  91 ;;  | 2 <- fact: 6
  92 ;;  1 <- fact: 24
  93 ;;
  94 ;;
  95 ;;  (defun ack (x y z)
  96 ;;    (if (= x 0)
  97 ;;        (+ y z)
  98 ;;      (if (and (<= x 2) (= z 0))
  99 ;;          (1- x)
 100 ;;        (if (and (> x 2) (= z 0))
 101 ;;            y
 102 ;;          (ack (1- x) y (ack x y (1- z)))))))
 103 ;;  ack
 104 ;;
 105 ;;  (trace-function 'ack)
 106 ;;  ack
 107 ;;
 108 ;;  Try this for some interesting trace output:
 109 ;;
 110 ;;  (ack 3 3 1)
 111 ;;  27
 112 ;;
 113 ;;
 114 ;; The following does something similar to the functionality of the package
 115 ;; log-message.el by Robert Potter, which is giving you a chance to look at
 116 ;; messages that might have whizzed by too quickly (you won't see subr
 117 ;; generated messages though):
 118 ;;
 119 ;; (trace-function-background 'message "*Message Log*")
 120
 121
 122 ;;; Change Log:
 123
 124 ;; Revision 2.0 1993/05/18 00:41:16 hans
 125 ;;      * Adapted for advice.el 2.0; it now also works
 126 ;;        for GNU Emacs-19 and Lemacs
 127 ;;      * Separate function `trace-function-background'
 128 ;;      * Separate pieces of advice for foreground and background tracing
 129 ;;      * Less insane handling of interactive trace buffer specification
 130 ;;      * String arguments and values are now printed properly
 131 ;;
 132 ;; Revision 1.1 1992/12/15 22:45:15 hans
 133 ;;      * Created, first public release
 134
 135
 136 ;;; Code:
 137
 138 (defgroup trace nil
 139   "Tracing facility for Emacs Lisp functions."
 140   :prefix "trace-"
 141   :group 'lisp)
 142
 143 ;;;###autoload
 144 (defcustom trace-buffer "*trace-output*"
 145   "Trace output will by default go to that buffer."
 146   :type 'string)
 147
 148 ;; Current level of traced function invocation:
 149 (defvar trace-level 0)
 150
 151 ;; Semi-cryptic name used for a piece of trace advice:
 152 (defvar trace-advice-name 'trace-function\ )
 153
 154 ;; Used to separate new trace output from previous traced runs:
 155 (defvar trace-separator (format "%s\n" (make-string 70 ?=)))
 156
 157 (defvar inhibit-trace nil
 158   "If non-nil, all tracing is temporarily inhibited.")
 159
 160 ;;;###autoload
 161 (defun trace-values (&rest values)
 162   "Helper function to get internal values.
 163 You can call this function to add internal values in the trace buffer."
 164   (unless inhibit-trace
 165     (with-current-buffer trace-buffer
 166       (goto-char (point-max))
 167       (insert
 168        (trace-entry-message
 169         'trace-values trace-level values "")))))
 170
 171 (defun trace-entry-message (function level args context)
 172   "Generate a string that describes that FUNCTION has been entered.
 173 LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION,
 174 and CONTEXT is a string describing the dynamic context (e.g. values of
 175 some global variables)."
 176   (let ((print-circle t))
 177     (format "%s%s%d -> %S%s\n"
 178             (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
 179             (if (> level 1) " " "")
 180             level
 181             ;; FIXME: Make it so we can click the function name to jump to its
 182             ;; definition and/or untrace it.
 183             (cons function args)
 184             context)))
 185
 186 (defun trace-exit-message (function level value context)
 187   "Generate a string that describes that FUNCTION has exited.
 188 LEVEL is the trace level, VALUE value returned by FUNCTION,
 189 and CONTEXT is a string describing the dynamic context (e.g. values of
 190 some global variables)."
 191   (let ((print-circle t))
 192     (format "%s%s%d <- %s: %S%s\n"
 193             (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
 194             (if (> level 1) " " "")
 195             level
 196             function
 197             ;; Do this so we'll see strings:
 198             value
 199             context)))
 200
 201 (defvar trace--timer nil)
 202
 203 (defun trace--display-buffer (buf)
 204   (unless (or trace--timer
 205               (get-buffer-window buf 'visible))
 206     (setq trace--timer
 207           ;; Postpone the display to some later time, in case we
 208           ;; can't actually do it now.
 209           (run-with-timer 0 nil
 210                           (lambda ()
 211                             (setq trace--timer nil)
 212                             (display-buffer buf nil 0))))))
 213
 214
 215 (defun trace-make-advice (function buffer background context)
 216   "Build the piece of advice to be added to trace FUNCTION.
 217 FUNCTION is the name of the traced function.
 218 BUFFER is the buffer where the trace should be printed.
 219 BACKGROUND if nil means to display BUFFER.
 220 CONTEXT if non-nil should be a function that returns extra info that should
 221 be printed along with the arguments in the trace."
 222   (lambda (body &rest args)
 223     (let ((trace-level (1+ trace-level))
 224           (trace-buffer (get-buffer-create buffer))
 225           (deactivate-mark nil)         ;Protect deactivate-mark.
 226           (ctx (funcall context)))
 227       (unless inhibit-trace
 228         (with-current-buffer trace-buffer
 229           (set (make-local-variable 'window-point-insertion-type) t)
 230           (unless background (trace--display-buffer trace-buffer))
 231           (goto-char (point-max))
 232           ;; Insert a separator from previous trace output:
 233           (if (= trace-level 1) (insert trace-separator))
 234           (insert
 235            (trace-entry-message
 236             function trace-level args ctx))))
 237       (let ((result))
 238         (unwind-protect
 239             (setq result (list (apply body args)))
 240           (unless inhibit-trace
 241             (let ((ctx (funcall context)))
 242               (with-current-buffer trace-buffer
 243                 (unless background (trace--display-buffer trace-buffer))
 244                 (goto-char (point-max))
 245                 (insert
 246                  (trace-exit-message
 247                   function
 248                   trace-level
 249                   (if result (car result) '\!non-local\ exit\!)
 250                   ctx))))))
 251         (car result)))))
 252
 253 (defun trace-function-internal (function buffer background context)
 254   "Add trace advice for FUNCTION."
 255   (advice-add
 256    function :around
 257    (trace-make-advice function (or buffer trace-buffer) background
 258                       (or context (lambda () "")))
 259    `((name . ,trace-advice-name) (depth . -100))))
 260
 261 (defun trace-is-traced (function)
 262   (advice-member-p trace-advice-name function))
 263
 264 (defun trace--read-args (prompt)
 265   (cons
 266    (let ((default (function-called-at-point))
 267          (beg (string-match ":[ \t]*\\'" prompt)))
 268      (intern (completing-read (if default
 269                                   (format
 270                                    "%s (default %s)%s"
 271                                    (substring prompt 0 beg)
 272                                    default
 273                                    (if beg (substring prompt beg) ": "))
 274                                 prompt)
 275                               obarray 'fboundp t nil nil
 276                               (if default (symbol-name default)))))
 277    (when current-prefix-arg
 278      (list
 279       (read-buffer "Output to buffer: " trace-buffer)
 280       (let ((exp
 281              (let ((minibuffer-completing-symbol t))
 282                (read-from-minibuffer "Context expression: "
 283                                      nil read-expression-map t
 284                                      'read-expression-history))))
 285         (lambda ()
 286           (let ((print-circle t))
 287             (concat " [" (prin1-to-string (eval exp t)) "]"))))))))
 288
 289 ;;;###autoload
 290 (defun trace-function-foreground (function &optional buffer context)
 291   "Traces FUNCTION with trace output going to BUFFER.
 292 For every call of FUNCTION Lisp-style trace messages that display argument
 293 and return values will be inserted into BUFFER.  This function generates the
 294 trace advice for FUNCTION and activates it together with any other advice
 295 there might be!!  The trace BUFFER will popup whenever FUNCTION is called.
 296 Do not use this to trace functions that switch buffers or do any other
 297 display oriented stuff, use `trace-function-background' instead.
 298
 299 To untrace a function, use `untrace-function' or `untrace-all'."
 300   (interactive (trace--read-args "Trace function: "))
 301   (trace-function-internal function buffer nil context))
 302
 303 ;;;###autoload
 304 (defun trace-function-background (function &optional buffer context)
 305   "Traces FUNCTION with trace output going quietly to BUFFER.
 306 Like `trace-function-foreground' but without popping up the trace BUFFER or
 307 changing the window configuration."
 308   (interactive (trace--read-args "Trace function in background: "))
 309   (trace-function-internal function buffer t context))
 310
 311 ;;;###autoload
 312 (defalias 'trace-function 'trace-function-foreground)
 313
 314 (defun untrace-function (function)
 315   "Untraces FUNCTION and possibly activates all remaining advice.
 316 Activation is performed with `ad-update', hence remaining advice will get
 317 activated only if the advice of FUNCTION is currently active.  If FUNCTION
 318 was not traced this is a noop."
 319   (interactive
 320    (list (intern (completing-read "Untrace function: "
 321                                   obarray #'trace-is-traced t))))
 322   (advice-remove function trace-advice-name))
 323
 324 (defun untrace-all ()
 325   "Untraces all currently traced functions."
 326   (interactive)
 327   (mapatoms #'untrace-function))
 328
 329 (provide 'trace)
 330
 331 ;;; trace.el ends here