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

; Merge: Backtrace printing improvements (Bug#6991)

Browse source
This commit is contained in:
Noam Postavsky 2017-06-29 19:42:32 -04:00
commit 169532b0eb
11 changed files with 161 additions and 188 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
doc/emacs/killing.texi
View file

@ -519,6 +519,10 @@ when exiting Emacs; if you wish to prevent Emacs from transferring
data to the clipboard manager, change the variable
@code{x-select-enable-clipboard-manager} to @code{nil}.
Since strings containing NUL bytes are usually truncated when passed
through the clipboard, Emacs replaces such characters with ``\0''
before transfering them to the system's clipboard.
@vindex select-enable-primary
@findex clipboard-kill-region
@findex clipboard-kill-ring-save

9
etc/NEWS
View file

@ -320,6 +320,15 @@ questions, with a handy way to display help texts.
all call stack frames in a Lisp backtrace buffer as lists. Both
debug.el and edebug.el have been updated to heed to this variable.
---
** Values in call stack frames are now displayed using 'cl-prin1'.
The old behaviour of using 'prin1' can be restored by customizing the
new option 'debugger-print-function'.
+++
** NUL bytes in strings copied to the system clipboard are now
replaced with "\0".
+++
** The new variable 'x-ctrl-keysym' has been added to the existing
roster of X keysyms. It can be used in combination with another

9
lisp/emacs-lisp/cl-print.el
View file

@ -105,10 +105,11 @@ into a button whose action shows the function's disassembly.")
(if args
(prin1 args stream)
(princ "()" stream)))
(let ((doc (documentation object 'raw)))
(when doc
(princ " " stream)
(prin1 doc stream)))
(pcase (help-split-fundoc (documentation object 'raw) object)
;; Drop args which `help-function-arglist' already printed.
(`(,_usage . ,(and doc (guard (stringp doc))))
(princ " " stream)
(prin1 doc stream)))
(let ((inter (interactive-form object)))
(when inter
(princ " " stream)

179
lisp/emacs-lisp/debug.el
View file

@ -49,6 +49,12 @@ the middle is discarded, and just the beginning and end are displayed."
:group 'debugger
:version "21.1")
(defcustom debugger-print-function #'cl-prin1
"Function used to print values in the debugger backtraces."
:type 'function
:options '(cl-prin1 prin1)
:version "26.1")
(defcustom debugger-bury-or-kill 'bury
"What to do with the debugger buffer when exiting `debug'.
The value affects the behavior of operations on any window
@ -264,6 +270,43 @@ first will be printed into the backtrace buffer."
(setq debug-on-next-call debugger-step-after-exit)
debugger-value)))
(defvar cl-print-compiled-button)
(defun debugger-insert-backtrace (frames do-xrefs)
"Format and insert the backtrace FRAMES at point.
Make functions into cross-reference buttons if DO-XREFS is non-nil."
(let ((standard-output (current-buffer))
(cl-print-compiled-button t)
(eval-buffers eval-buffer-list))
(require 'help-mode) ; Define `help-function-def' button type.
(pcase-dolist (`(,evald ,fun ,args ,flags) frames)
(insert (if (plist-get flags :debug-on-exit)
"* " " "))
(let ((fun-file (and do-xrefs (symbol-file fun 'defun)))
(fun-pt (point)))
(cond
((and evald (not debugger-stack-frame-as-list))
(funcall debugger-print-function fun)
(if args (funcall debugger-print-function args) (princ "()")))
(t
(funcall debugger-print-function (cons fun args))
(cl-incf fun-pt)))
(when fun-file
(make-text-button fun-pt (+ fun-pt (length (symbol-name fun)))
:type 'help-function-def
'help-args (list fun fun-file))))
;; After any frame that uses eval-buffer, insert a line that
;; states the buffer position it's reading at.
(when (and eval-buffers (memq fun '(eval-buffer eval-region)))
(insert (format " ; Reading at buffer position %d"
;; This will get the wrong result if there are
;; two nested eval-region calls for the same
;; buffer. That's not a very useful case.
(with-current-buffer (pop eval-buffers)
(point)))))
(insert "\n"))))
(defun debugger-setup-buffer (args)
"Initialize the `*Backtrace*' buffer for entry to the debugger.
That buffer should be current already."
@ -271,27 +314,20 @@ That buffer should be current already."
(erase-buffer)
(set-buffer-multibyte t) ;Why was it nil ? -stef
(setq buffer-undo-list t)
(let ((standard-output (current-buffer))
(print-escape-newlines t)
(print-level 8)
(print-length 50))
;; FIXME the debugger could pass a custom callback to mapbacktrace
;; instead of manipulating printed results.
(mapbacktrace #'backtrace--print-frame 'debug))
(goto-char (point-min))
(delete-region (point)
(progn
(forward-line (if (eq (car args) 'debug)
;; Remove debug--implement-debug-on-entry
;; and the advice's `apply' frame.
3
1))
(point)))
(insert "Debugger entered")
;; lambda is for debug-on-call when a function call is next.
;; debug is for debug-on-entry function called.
(let ((pos (point)))
(let ((frames (nthcdr
;; Remove debug--implement-debug-on-entry and the
;; advice's `apply' frame.
(if (eq (car args) 'debug) 3 1)
(backtrace-frames 'debug)))
(print-escape-newlines t)
(print-escape-control-characters t)
(print-level 8)
(print-length 50)
(pos (point)))
(pcase (car args)
;; lambda is for debug-on-call when a function call is next.
;; debug is for debug-on-entry function called.
((or `lambda `debug)
(insert "--entering a function:\n")
(setq pos (1- (point))))
@ -300,11 +336,9 @@ That buffer should be current already."
(insert "--returning value: ")
(setq pos (point))
(setq debugger-value (nth 1 args))
(prin1 debugger-value (current-buffer))
(insert ?\n)
(delete-char 1)
(insert ? )
(beginning-of-line))
(funcall debugger-print-function debugger-value (current-buffer))
(setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil)
(insert ?\n))
;; Watchpoint triggered.
((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args)))
(insert
@ -327,7 +361,7 @@ That buffer should be current already."
(`error
(insert "--Lisp error: ")
(setq pos (point))
(prin1 (nth 1 args) (current-buffer))
(funcall debugger-print-function (nth 1 args) (current-buffer))
(insert ?\n))
;; debug-on-call, when the next thing is an eval.
(`t
@ -337,98 +371,15 @@ That buffer should be current already."
(_
(insert ": ")
(setq pos (point))
(prin1 (if (eq (car args) 'nil)
(cdr args) args)
(current-buffer))
(funcall debugger-print-function
(if (eq (car args) 'nil)
(cdr args) args)
(current-buffer))
(insert ?\n)))
(debugger-insert-backtrace frames t)
;; Place point on "stack frame 0" (bug#15101).
(goto-char pos))
;; After any frame that uses eval-buffer,
;; insert a line that states the buffer position it's reading at.
(save-excursion
(let ((tem eval-buffer-list))
(while (and tem
(re-search-forward "^ eval-\\(buffer\\|region\\)(" nil t))
(end-of-line)
(insert (format " ; Reading at buffer position %d"
;; This will get the wrong result
;; if there are two nested eval-region calls
;; for the same buffer. That's not a very useful case.
(with-current-buffer (car tem)
(point))))
(pop tem))))
(debugger-make-xrefs))
(goto-char pos)))
(defun debugger-make-xrefs (&optional buffer)
"Attach cross-references to function names in the `*Backtrace*' buffer."
(interactive "b")
(with-current-buffer (or buffer (current-buffer))
(save-excursion
(setq buffer (current-buffer))
(let ((inhibit-read-only t)
(old-end (point-min)) (new-end (point-min)))
;; If we saved an old backtrace, find the common part
;; between the new and the old.
;; Compare line by line, starting from the end,
;; because that's the part that is likely to be unchanged.
(if debugger-previous-backtrace
(let (old-start new-start (all-match t))
(goto-char (point-max))
(with-temp-buffer
(insert debugger-previous-backtrace)
(while (and all-match (not (bobp)))
(setq old-end (point))
(forward-line -1)
(setq old-start (point))
(with-current-buffer buffer
(setq new-end (point))
(forward-line -1)
(setq new-start (point)))
(if (not (zerop
(let ((case-fold-search nil))
(compare-buffer-substrings
(current-buffer) old-start old-end
buffer new-start new-end))))
(setq all-match nil))))
;; Now new-end is the position of the start of the
;; unchanged part in the current buffer, and old-end is
;; the position of that same text in the saved old
;; backtrace. But we must subtract (point-min) since strings are
;; indexed in origin 0.
;; Replace the unchanged part of the backtrace
;; with the text from debugger-previous-backtrace,
;; since that already has the proper xrefs.
;; With this optimization, we only need to scan
;; the changed part of the backtrace.
(delete-region new-end (point-max))
(goto-char (point-max))
(insert (substring debugger-previous-backtrace
(- old-end (point-min))))
;; Make the unchanged part of the backtrace inaccessible
;; so it won't be scanned.
(narrow-to-region (point-min) new-end)))
;; Scan the new part of the backtrace, inserting xrefs.
(goto-char (point-min))
(while (progn
(goto-char (+ (point) 2))
(skip-syntax-forward "^w_")
(not (eobp)))
(let* ((beg (point))
(end (progn (skip-syntax-forward "w_") (point)))
(sym (intern-soft (buffer-substring-no-properties
beg end)))
(file (and sym (symbol-file sym 'defun))))
(when file
(goto-char beg)
;; help-xref-button needs to operate on something matched
;; by a regexp, so set that up for it.
(re-search-forward "\\(\\sw\\|\\s_\\)+")
(help-xref-button 0 'help-function-def sym file)))
(forward-line 1))
(widen))
(setq debugger-previous-backtrace (buffer-string)))))
(defun debugger-step-through ()
"Proceed, stepping through subexpressions of this expression.

85
lisp/emacs-lisp/ert.el
View file

@ -670,48 +670,12 @@ and is displayed in front of the value of MESSAGE-FORM."
(cl-defstruct (ert-test-aborted-with-non-local-exit
(:include ert-test-result)))
(defun ert--record-backtrace ()
"Record the current backtrace (as a list) and return it."
;; Since the backtrace is stored in the result object, result
;; objects must only be printed with appropriate limits
;; (`print-level' and `print-length') in place. For interactive
;; use, the cost of ensuring this possibly outweighs the advantage
;; of storing the backtrace for
;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
;; already have `ert-results-rerun-test-debugging-errors-at-point'.
;; For batch use, however, printing the backtrace may be useful.
(cl-loop
;; 6 is the number of frames our own debugger adds (when
;; compiled; more when interpreted). FIXME: Need to describe a
;; procedure for determining this constant.
for i from 6
for frame = (backtrace-frame i)
while frame
collect frame))
(defun ert--print-backtrace (backtrace)
(defun ert--print-backtrace (backtrace do-xrefs)
"Format the backtrace BACKTRACE to the current buffer."
;; This is essentially a reimplementation of Fbacktrace
;; (src/eval.c), but for a saved backtrace, not the current one.
(let ((print-escape-newlines t)
(print-level 8)
(print-length 50))
(dolist (frame backtrace)
(pcase-exhaustive frame
(`(nil ,special-operator . ,arg-forms)
;; Special operator.
(insert
(format " %S\n" (cons special-operator arg-forms))))
(`(t ,fn . ,args)
;; Function call.
(insert (format " %S(" fn))
(cl-loop for firstp = t then nil
for arg in args do
(unless firstp
(insert " "))
(insert (format "%S" arg)))
(insert ")\n"))))))
(debugger-insert-backtrace backtrace do-xrefs)))
;; A container for the state of the execution of a single test and
;; environment data needed during its execution.
@ -750,7 +714,19 @@ run. ARGS are the arguments to `debugger'."
((quit) 'quit)
((ert-test-skipped) 'skipped)
(otherwise 'failed)))
(backtrace (ert--record-backtrace))
;; We store the backtrace in the result object for
;; `ert-results-pop-to-backtrace-for-test-at-point'.
;; This means we have to limit `print-level' and
;; `print-length' when printing result objects. That
;; might not be worth while when we can also use
;; `ert-results-rerun-test-debugging-errors-at-point',
;; (i.e., when running interactively) but having the
;; backtrace ready for printing is important for batch
;; use.
;;
;; Grab the frames starting from `signal', frames below
;; that are all from the debugger.
(backtrace (backtrace-frames 'signal))
(infos (reverse ert--infos)))
(setf (ert--test-execution-info-result info)
(cl-ecase type
@ -1409,8 +1385,9 @@ Returns the stats object."
(ert-test-result-with-condition
(message "Test %S backtrace:" (ert-test-name test))
(with-temp-buffer
(ert--print-backtrace (ert-test-result-with-condition-backtrace
result))
(ert--print-backtrace
(ert-test-result-with-condition-backtrace result)
nil)
(goto-char (point-min))
(while (not (eobp))
(let ((start (point))
@ -1828,12 +1805,23 @@ EWOC and STATS are arguments for `ert--results-update-stats-display'."
BEGIN and END specify a region in the current buffer."
(save-excursion
(save-restriction
(narrow-to-region begin end)
;; Inhibit optimization in `debugger-make-xrefs' that would
;; sometimes insert unrelated backtrace info into our buffer.
(let ((debugger-previous-backtrace nil))
(debugger-make-xrefs)))))
(goto-char begin)
(while (progn
(goto-char (+ (point) 2))
(skip-syntax-forward "^w_")
(< (point) end))
(let* ((beg (point))
(end (progn (skip-syntax-forward "w_") (point)))
(sym (intern-soft (buffer-substring-no-properties
beg end)))
(file (and sym (symbol-file sym 'defun))))
(when file
(goto-char beg)
;; help-xref-button needs to operate on something matched
;; by a regexp, so set that up for it.
(re-search-forward "\\(\\sw\\|\\s_\\)+")
(help-xref-button 0 'help-function-def sym file)))
(forward-line 1))))
(defun ert--string-first-line (s)
"Return the first line of S, or S if it contains no newlines.
@ -2420,8 +2408,7 @@ To be used in the ERT results buffer."
;; Use unibyte because `debugger-setup-buffer' also does so.
(set-buffer-multibyte nil)
(setq truncate-lines t)
(ert--print-backtrace backtrace)
(debugger-make-xrefs)
(ert--print-backtrace backtrace t)
(goto-char (point-min))
(insert (substitute-command-keys "Backtrace for test `"))
(ert-insert-test-name-button (ert-test-name test))

3
lisp/select.el
View file

@ -475,6 +475,9 @@ two markers or an overlay. Otherwise, it is nil."
(t
(error "Unknown selection type: %S" type)))))
;; Most programs are unable to handle NUL bytes in strings.
(setq str (replace-regexp-in-string "\0" "\\0" str t t))
(setq next-selection-coding-system nil)
(cons type str))))

3
lisp/subr.el
View file

@ -4514,7 +4514,8 @@ EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'."
(defun backtrace ()
"Print a trace of Lisp function calls currently active.
Output stream used is value of `standard-output'."
(let ((print-level (or print-level 8)))
(let ((print-level (or print-level 8))
(print-escape-control-characters t))
(mapbacktrace #'backtrace--print-frame 'backtrace)))
(defun backtrace-frames (&optional base)

2
lisp/term/w32-win.el
View file

@ -396,7 +396,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
;;; Fix interface to (X-specific) mouse.el
(defun w32--set-selection (type value)
(if (eq type 'CLIPBOARD)
(w32-set-clipboard-data value)
(w32-set-clipboard-data (replace-regexp-in-string "\0" "\\0" value t t))
(put 'x-selections (or type 'PRIMARY) value)))
(defun w32--get-selection (&optional type data-type)

45
src/print.c
View file

@ -1870,21 +1870,36 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
}
else
{
bool still_need_nonhex = false;
/* If we just had a hex escape, and this character
could be taken as part of it,
output `\ ' to prevent that. */
if (need_nonhex && c_isxdigit (c))
print_c_string ("\\ ", printcharfun);
if (c == '\n' && print_escape_newlines
? (c = 'n', true)
: c == '\f' && print_escape_newlines
? (c = 'f', true)
: c == '\"' || c == '\\')
printchar ('\\', printcharfun);
printchar (c, printcharfun);
need_nonhex = false;
if (c_isxdigit (c))
{
if (need_nonhex)
print_c_string ("\\ ", printcharfun);
printchar (c, printcharfun);
}
else if (c == '\n' && print_escape_newlines
? (c = 'n', true)
: c == '\f' && print_escape_newlines
? (c = 'f', true)
: c == '\0' && print_escape_control_characters
? (c = '0', still_need_nonhex = true)
: c == '\"' || c == '\\')
{
printchar ('\\', printcharfun);
printchar (c, printcharfun);
}
else if (print_escape_control_characters && c_iscntrl (c))
{
char outbuf[1 + 3 + 1];
int len = sprintf (outbuf, "\\%03o", c + 0u);
strout (outbuf, len, len, printcharfun);
}
else
printchar (c, printcharfun);
need_nonhex = still_need_nonhex;
}
}
printchar ('\"', printcharfun);
@ -2329,6 +2344,11 @@ A value of nil means no limit. See also `eval-expression-print-level'. */);
Also print formfeeds as `\\f'. */);
print_escape_newlines = 0;
DEFVAR_BOOL ("print-escape-control-characters", print_escape_control_characters,
doc: /* Non-nil means print control characters in strings as `\\OOO'.
\(OOO is the octal representation of the character code.)*/);
print_escape_control_characters = 0;
DEFVAR_BOOL ("print-escape-nonascii", print_escape_nonascii,
doc: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO.
\(OOO is the octal representation of the character code.)
@ -2418,6 +2438,7 @@ priorities. */);
DEFSYM (Qprint_escape_newlines, "print-escape-newlines");
DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte");
DEFSYM (Qprint_escape_nonascii, "print-escape-nonascii");
DEFSYM (Qprint_escape_control_characters, "print-escape-control-characters");
print_prune_charset_plist = Qnil;
staticpro (&print_prune_charset_plist);

2
test/lisp/emacs-lisp/cl-print-tests.el
View file

@ -34,7 +34,7 @@
(let ((print-circle t))
(should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
"((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))")))
(should (string-match "\\`#f(compiled-function (x) .*\n\n.*)\\'"
(should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^\)]*)\\'"
(cl-prin1-to-string (symbol-function #'caar))))))
(ert-deftest cl-print-tests-2 ()

8
test/lisp/emacs-lisp/ert-tests.el
View file

@ -367,12 +367,8 @@ This macro is used to test if macroexpansion in `should' works."
(test (make-ert-test :body test-body))
(result (ert-run-test test)))
(should (ert-test-failed-p result))
(with-temp-buffer
(ert--print-backtrace (ert-test-failed-backtrace result))
(goto-char (point-min))
(end-of-line)
(let ((first-line (buffer-substring-no-properties (point-min) (point))))
(should (equal first-line (format " %S()" test-body)))))))
(should (eq (nth 1 (car (ert-test-failed-backtrace result)))
'signal))))
(ert-deftest ert-test-messages ()
:tags '(:causes-redisplay)