comparison lisp/emacs-lisp/trace.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

;;; trace.el --- tracing facility for Emacs Lisp functions

;; Copyright (C) 1993 Free Software Foundation, Inc.

;; Author: Hans Chalupsky <[e-mail]>
;; Maintainer: FSF
;; Created: 15 Dec 1992
;; Keywords: tools, lisp

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;; LCD Archive Entry:
;; trace|Hans Chalupsky|[e-mail]|
;; Tracing facility for Emacs Lisp functions|
;; 1993/05/18 00:41:16|2.0|~/packages/trace.el.Z|

;;; Code:

(require 'advice)

(defgroup trace nil
  "Tracing facility for Emacs Lisp functions"
  :prefix "trace-"
  :group 'lisp)

;;;###autoload
(defcustom trace-buffer "*trace-output*"

;; Semi-cryptic name used for a piece of trace advice:
(defvar trace-advice-name 'trace-function\ )

;; Used to separate new trace output from previous traced runs:
(defvar trace-separator (format "%s\n" (make-string 70 ?=)))

(defun trace-entry-message (function level argument-bindings)
  ;; Generates a string that describes that FUNCTION has been entered at
  ;; trace LEVEL with ARGUMENT-BINDINGS.
  (format "%s%s%d -> %s: %s\n"
	  (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
	  (if (> level 1) " " "")
	  level
	  function
	  (mapconcat (function
		      (lambda (binding)
			(concat
			 (symbol-name (ad-arg-binding-field binding 'name))
			 "="
			 ;; do this so we'll see strings:
			 (prin1-to-string
			  (ad-arg-binding-field binding 'value)))))
		     argument-bindings
		     " ")))

(defun trace-exit-message (function level value)
  ;; Generates a string that describes that FUNCTION has been exited at

  ;; Builds the piece of advice to be added to FUNCTION's advice info
  ;; so that it will generate the proper trace output in BUFFER
  ;; (quietly if BACKGROUND is t).
  (ad-make-advice
   trace-advice-name nil t
   (cond (background
	  `(advice
	   lambda ()
	   (let ((trace-level (1+ trace-level))
		 (trace-buffer (get-buffer-create ,buffer)))
	     (save-excursion
	       (set-buffer trace-buffer)
	       (goto-char (point-max))
	       ;; Insert a separator from previous trace output:
	       (if (= trace-level 1) (insert trace-separator))
	       (insert
		(trace-entry-message
		 ',function trace-level ad-arg-bindings)))
	     ad-do-it
	     (save-excursion
	       (set-buffer trace-buffer)
	       (goto-char (point-max))
	       (insert
		(trace-exit-message
		 ',function trace-level ad-return-value))))))
	 (t `(advice
	     lambda ()
	     (let ((trace-level (1+ trace-level))
		   (trace-buffer (get-buffer-create ,buffer)))
	       (pop-to-buffer trace-buffer)
	       (goto-char (point-max))
	       ;; Insert a separator from previous trace output:
	       (if (= trace-level 1) (insert trace-separator))
	       (insert
		(trace-entry-message
		 ',function trace-level ad-arg-bindings))
	       ad-do-it
	       (pop-to-buffer trace-buffer)
	       (goto-char (point-max))
	       (insert
		(trace-exit-message
		 ',function trace-level ad-return-value))))))))

(defun trace-function-internal (function buffer background)
  ;; Adds trace advice for FUNCTION and activates it.
  (ad-add-advice
   function

Activation is performed with `ad-update', hence remaining advice will get
activated only if the advice of FUNCTION is currently active.  If FUNCTION
was not traced this is a noop."
  (interactive
   (list (ad-read-advised-function "Untrace function: " 'trace-is-traced)))
  (cond ((trace-is-traced function)
	 (ad-remove-advice function 'around trace-advice-name)
	 (ad-update function))))

(defun untrace-all ()
  "Untraces all currently traced functions."
  (interactive)
  (ad-do-advised-functions (function)
    (untrace-function function)))

(provide 'trace)

;;; trace.el ends here

88155:d7ddb3e565de

;;; trace.el --- tracing facility for Emacs Lisp functions

;; Copyright (C) 1993, 1998, 2000, 2002, 2003, 2004,
;;   2005 Free Software Foundation, Inc.

;; Author: Hans Chalupsky <[e-mail]>
;; Maintainer: FSF
;; Created: 15 Dec 1992
;; Keywords: tools, lisp

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;; LCD Archive Entry:
;; trace|Hans Chalupsky|[e-mail]|
;; Tracing facility for Emacs Lisp functions|
;; 1993/05/18 00:41:16|2.0|~/packages/trace.el.Z|

;;; Code:

(require 'advice)

(defgroup trace nil
  "Tracing facility for Emacs Lisp functions."
  :prefix "trace-"
  :group 'lisp)

;;;###autoload
(defcustom trace-buffer "*trace-output*"

;; Semi-cryptic name used for a piece of trace advice:
(defvar trace-advice-name 'trace-function\ )

;; Used to separate new trace output from previous traced runs:
(defvar trace-separator (format "%s\n" (make-string 70 ?=)))

(defvar inhibit-trace nil
  "If non-nil, all tracing is temporarily inhibited.")

(defun trace-entry-message (function level argument-bindings)
  ;; Generates a string that describes that FUNCTION has been entered at
  ;; trace LEVEL with ARGUMENT-BINDINGS.
  (format "%s%s%d -> %s: %s\n"
	  (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
	  (if (> level 1) " " "")
	  level
	  function
	  (mapconcat (lambda (binding)
		       (concat
			(symbol-name (ad-arg-binding-field binding 'name))
			"="
			;; do this so we'll see strings:
			(prin1-to-string
			 (ad-arg-binding-field binding 'value))))
		     argument-bindings
		     " ")))

(defun trace-exit-message (function level value)
  ;; Generates a string that describes that FUNCTION has been exited at

  ;; Builds the piece of advice to be added to FUNCTION's advice info
  ;; so that it will generate the proper trace output in BUFFER
  ;; (quietly if BACKGROUND is t).
  (ad-make-advice
   trace-advice-name nil t
   `(advice
     lambda ()
     (let ((trace-level (1+ trace-level))
	   (trace-buffer (get-buffer-create ,buffer)))
       (unless inhibit-trace
	 (with-current-buffer trace-buffer
	   ,(unless background '(pop-to-buffer trace-buffer))
	   (goto-char (point-max))
	   ;; Insert a separator from previous trace output:
	   (if (= trace-level 1) (insert trace-separator))
	   (insert
	    (trace-entry-message
	     ',function trace-level ad-arg-bindings))))
       ad-do-it
       (unless inhibit-trace
	 (with-current-buffer trace-buffer
	   ,(unless background '(pop-to-buffer trace-buffer))
	   (goto-char (point-max))
	   (insert
	    (trace-exit-message
	     ',function trace-level ad-return-value))))))))

(defun trace-function-internal (function buffer background)
  ;; Adds trace advice for FUNCTION and activates it.
  (ad-add-advice
   function

Activation is performed with `ad-update', hence remaining advice will get
activated only if the advice of FUNCTION is currently active.  If FUNCTION
was not traced this is a noop."
  (interactive
   (list (ad-read-advised-function "Untrace function: " 'trace-is-traced)))
  (when (trace-is-traced function)
    (ad-remove-advice function 'around trace-advice-name)
    (ad-update function)))

(defun untrace-all ()
  "Untraces all currently traced functions."
  (interactive)
  (ad-do-advised-functions (function)
    (untrace-function function)))

(provide 'trace)

;; arch-tag: cfd170a7-4932-4331-8c8b-b7151942e5a1
;;; trace.el ends here