Improve Tramp traces

* lisp/net/tramp-cmds.el (tramp-list-tramp-buffers):
List also trace buffers.

* lisp/net/tramp.el (tramp-buffer-name):
Add `tramp-suppress-trace' property.
(tramp-get-debug-file-name): Fix docstring.
(tramp-trace-buffer-name): New defun.
(tramp-trace-functions): New defvar.
(tramp-debug-message): Obey also `tramp-trace-functions'.

* test/lisp/net/tramp-tests.el (tramp--test-instrument-test-case):
Handle trace buffer accordingly.
This commit is contained in:
Michael Albinus 2021-05-13 16:46:17 +02:00
parent 5be26b43f4
commit c9773379c1
3 changed files with 30 additions and 14 deletions

View file

@ -57,7 +57,9 @@ SYNTAX can be one of the symbols `default' (default),
(all-completions
"*tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))
(all-completions
"*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))))
"*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))
(all-completions
"*trace tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))))
(defun tramp-list-remote-buffers ()
"Return a list of all buffers with remote `default-directory'."

View file

@ -1665,6 +1665,8 @@ See `tramp-dissect-file-name' for details."
(format "*tramp/%s %s@%s*" method user-domain host-port)
(format "*tramp/%s %s*" method host-port))))
(put #'tramp-buffer-name 'tramp-suppress-trace t)
(defun tramp-make-tramp-file-name (&rest args)
"Construct a Tramp file name from ARGS.
@ -1889,13 +1891,22 @@ The outline level is equal to the verbosity of the Tramp message."
(put #'tramp-get-debug-buffer 'tramp-suppress-trace t)
(defun tramp-get-debug-file-name (vec)
"Get the debug buffer for VEC."
"Get the debug file name for VEC."
(expand-file-name
(tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec))
(tramp-compat-temporary-file-directory)))
(put #'tramp-get-debug-file-name 'tramp-suppress-trace t)
(defun tramp-trace-buffer-name (vec)
"A name for the trace buffer for VEC."
(tramp-compat-string-replace "debug" "trace" (tramp-debug-buffer-name vec)))
(put #'tramp-trace-buffer-name 'tramp-suppress-trace t)
(defvar tramp-trace-functions nil
"A list of non-Tramp functions to be trace with tramp-verbose > 10.")
(defun tramp-debug-message (vec fmt-string &rest arguments)
"Append message to debug buffer of VEC.
Message is formatted with FMT-STRING as control string and the remaining
@ -1922,10 +1933,13 @@ ARGUMENTS to actually emit the message (if applicable)."
(or tramp-repository-version "")))))
;; Traces.
(when (>= tramp-verbose 11)
(dolist (elt (all-completions "tramp-" obarray 'functionp))
(let ((fn (intern elt)))
(unless (get fn 'tramp-suppress-trace)
(trace-function-background fn)))))
(dolist
(elt
(append
(mapcar #'intern (all-completions "tramp-" obarray 'functionp))
tramp-trace-functions))
(unless (get elt 'tramp-suppress-trace)
(trace-function-background elt))))
;; Delete debug file.
(when (and tramp-debug-to-file (tramp-get-debug-file-name vec))
(ignore-errors (delete-file (tramp-get-debug-file-name vec)))))

View file

@ -179,6 +179,11 @@ The temporary file is not created."
"Whether `tramp--test-instrument-test-case' run.
This shall used dynamically bound only.")
;; When `tramp-verbose' is greater than 10, and you want to trace
;; other functions as well, do something like
;; (let ((tramp-trace-functions '(file-name-non-special)))
;; (tramp--test-instrument-test-case 11
;; ...))
(defmacro tramp--test-instrument-test-case (verbose &rest body)
"Run BODY with `tramp-verbose' equal VERBOSE.
Print the content of the Tramp connection and debug buffers, if
@ -187,8 +192,7 @@ is greater than 10.
`should-error' is not handled properly. BODY shall not contain a timeout."
(declare (indent 1) (debug (natnump body)))
`(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0)))
(trace-buffer
(when (> tramp-verbose 10) (generate-new-buffer " *temp*")))
(trace-buffer (tramp-trace-buffer-name tramp-test-vec))
(debug-ignored-errors
(append
'("^make-symbolic-link not supported$"
@ -198,13 +202,9 @@ is greater than 10.
(unwind-protect
(let ((tramp--test-instrument-test-case-p t)) ,@body)
;; Unwind forms.
(when trace-buffer
(untrace-all))
(when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3))
(dolist
(buf (append
(tramp-list-tramp-buffers)
(and trace-buffer (list (get-buffer trace-buffer)))))
(untrace-all)
(dolist (buf (tramp-list-tramp-buffers))
(with-current-buffer buf
(message ";; %s\n%s" buf (buffer-string)))
(kill-buffer buf))))))