From: Michael Albinus Date: Sat, 29 Jul 2023 11:11:01 +0000 (+0200) Subject: Reorganize Tramp's messages X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=14ab840c9f9592261737ce04f09bd9e1a872b723;p=emacs.git Reorganize Tramp's messages * doc/misc/tramp.texi (Traces and Profiles): Use proper buffer names. Add tramp-debug-command-messages. * lisp/net/tramp-adb.el (tramp-adb-file-name-handler): * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler): * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler): * lisp/net/tramp-sh.el (tramp-sh-file-name-handler): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler): * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler): Set `tramp-debug-message-fnh-function'. * lisp/net/tramp.el (tramp-file-name-handler): * lisp/net/tramp-adb.el (tramp-adb-maybe-open-connection): * lisp/net/tramp-crypt.el (tramp-crypt-maybe-open-connection): * lisp/net/tramp-gvfs.el (tramp-gvfs-maybe-open-connection): * lisp/net/tramp-rclone.el (tramp-rclone-maybe-open-connection): * lisp/net/tramp-sh.el (tramp-maybe-open-connection): * lisp/net/tramp-smb.el (tramp-smb-maybe-open-connection): * lisp/net/tramp-sshfs.el (tramp-sshfs-maybe-open-connection): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-maybe-open-connection): Wrap code `with-tramp-debug-message'. * lisp/net/tramp-message.el: New file. * lisp/net/tramp.el (tramp-message): Require. (tramp-verbose, tramp-debug-to-file, tramp-debug-buffer-name) (tramp-debug-outline-regexp, tramp-debug-font-lock-keywords) (tramp-debug-outline-level) (tramp-debug-buffer-command-completion-p) (tramp-setup-debug-buffer, tramp-get-debug-buffer) (tramp-get-debug-file-name, tramp-trace-buffer-name) (tramp-trace-functions, tramp-debug-message, tramp-message) (tramp-backtrace, tramp-error, tramp-error-show-message-timeout) (tramp-error-with-buffer, tramp-user-error) (tramp-with-demoted-errors): Move to tramp-message.el. (tramp-current-connection, tramp-file-name-user-domain) (tramp-file-name-host-port): Add ;;;###tramp-autoload cookie. (tramp-inhibit-progress-reporter): Move down. (tramp-post-process-creation): Write debug message only when there is a command. * lisp/net/trampver.el (tramp-repository-branch) (tramp-repository-version): Add ;;;###tramp-autoload cookie. * test/lisp/net/tramp-tests.el (tramp--test-instrument-test-case): Don't bind `trace-buffer'. --- diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 1d8e0095328..e518330c9b0 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -6054,6 +6054,7 @@ wrapping the timer function body as follows: @chapter How to Customize Traces @vindex tramp-verbose @vindex tramp-debug-to-file +@vindex tramp-debug-command-messages @value{tramp} messages are raised with verbosity levels ranging from 0 to 10. @value{tramp} does not display all messages; only those with a @@ -6075,9 +6076,10 @@ The verbosity levels are @*@indent @w{11} call traces (maintainer only) With @code{tramp-verbose} greater than or equal to 4, messages are -also written to a @value{tramp} debug buffer. Such debug buffers are -essential to bug and problem analyzes. For @value{tramp} bug reports, -set the @code{tramp-verbose} level to 6 (@pxref{Bug Reports}). +also written to the @value{tramp} debug buffer @file{*debug +tramp/foo*}. Such debug buffers are essential to bug and problem +analyzes. For @value{tramp} bug reports, set the @code{tramp-verbose} +level to 6 (@pxref{Bug Reports}). The debug buffer is in @ifinfo @@ -6121,7 +6123,14 @@ directory}. Use this option with care, because it could decrease the performance of @value{tramp} actions. If @code{tramp-verbose} is greater than or equal to 11, @value{tramp} -function call traces are written to the buffer @file{*trace-output*}. +function call traces are written to the buffer @file{*trace tramp/foo*}. + +When @code{tramp-debug-command-messages} is non-@code{nil} and +@code{tramp-verbose} is greater than or equal to 6, the debug buffer +contains all messages with verbosity level 6 (sent and received +strings), and the entry and exit messages for the function +@code{tramp-file-name-handler}. This is intended for @value{tramp} +maintainers, analyzing the remote commands for performance analysis. @node GNU Free Documentation License diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 2b5369ea3b5..3d4dacb393c 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -209,8 +209,10 @@ It is used for TCP/IP devices." First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (if-let ((fn (assoc operation tramp-adb-file-name-handler-alist))) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (tramp--with-startup @@ -273,7 +275,7 @@ arguments to pass to the OPERATION." (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) (let (file-properties) - (while (re-search-forward tramp-adb-ls-toolbox-regexp nil t) + (while (search-forward-regexp tramp-adb-ls-toolbox-regexp nil t) (let* ((mod-string (match-string 1)) (is-dir (eq ?d (aref mod-string 0))) (is-symlink (eq ?l (aref mod-string 0))) @@ -319,7 +321,7 @@ arguments to pass to the OPERATION." (tramp-shell-quote-argument localname))) ;; We insert also filename/. and filename/.., because "ls" ;; doesn't on some file systems, like "sdcard". - (unless (re-search-backward (rx "." eol) nil t) + (unless (search-backward-regexp (rx "." eol) nil t) (narrow-to-region (point-max) (point-max)) (tramp-adb-send-command v (format "%s -d -a -l %s %s | cat" @@ -1142,7 +1144,7 @@ error and non-nil on success." ;; There must be a better solution by setting the correct coding ;; system, but this requires changes in core Tramp. (goto-char (point-min)) - (while (re-search-forward (rx (+ "\r") eol) nil t) + (while (search-forward-regexp (rx (+ "\r") eol) nil t) (replace-match "" nil nil))))))) (defun tramp-adb-send-command-and-check (vec command &optional exit-status) @@ -1186,12 +1188,12 @@ FMT and ARGS are passed to `error'." (let ((inhibit-read-only t)) (goto-char (point-min)) ;; ADB terminal sends "^H" sequences. - (when (re-search-forward (rx "<" (+ "\b")) (line-end-position) t) + (when (search-forward-regexp (rx "<" (+ "\b")) (line-end-position) t) (forward-line 1) (delete-region (point-min) (point))) ;; Delete the prompt. (goto-char (point-min)) - (when (re-search-forward prompt (line-end-position) t) + (when (search-forward-regexp prompt (line-end-position) t) (forward-line 1) (delete-region (point-min) (point))) (when (tramp-search-regexp prompt) @@ -1211,102 +1213,106 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - (let* ((buf (tramp-get-connection-buffer vec)) - (p (get-buffer-process buf)) - (host (tramp-file-name-host vec)) - (user (tramp-file-name-user vec)) - (device (tramp-adb-get-device vec))) - - ;; Maybe we know already that "su" is not supported. We cannot - ;; use a connection property, because we have not checked yet - ;; whether it is still the same device. - (when (and user (not (tramp-get-file-property vec "/" "su-command-p" t))) - (tramp-error vec 'file-error "Cannot switch to user `%s'" user)) - - (unless (process-live-p p) - (save-match-data - (when (and p (processp p)) (delete-process p)) - (if (tramp-string-empty-or-nil-p device) - (tramp-error vec 'file-error "Device %s not connected" host)) - (with-tramp-progress-reporter vec 3 "Opening adb shell connection" - (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct? - (process-connection-type tramp-process-connection-type) - (args (tramp-expand-args - vec 'tramp-login-args ?d (or device ""))) - (p (let ((default-directory - tramp-compat-temporary-file-directory)) - (apply #'start-process (tramp-get-connection-name vec) buf - tramp-adb-program args))) - (prompt (md5 (concat (prin1-to-string process-environment) - (current-time-string))))) - ;; Wait for initial prompt. On some devices, it needs an - ;; initial RET, in order to get it. - (sleep-for 0.1) - (tramp-send-string vec tramp-rsh-end-of-line) - (tramp-adb-wait-for-output p 30) - (unless (process-live-p p) - (tramp-error vec 'file-error "Terminated!")) - - ;; Set sentinel. Initialize variables. - (set-process-sentinel p #'tramp-process-sentinel) - (tramp-post-process-creation p vec) - - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec) - - ;; Change prompt. - (tramp-set-connection-property - p "prompt" (rx "///" (literal prompt) "#$")) - (tramp-adb-send-command - vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) - - ;; Disable line editing. - (tramp-adb-send-command - vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs") - - ;; Dump option settings in the traces. - (when (>= tramp-verbose 9) - (tramp-adb-send-command vec "set -o")) - - ;; Check whether the properties have been changed. If - ;; yes, this is a strong indication that we must expire all - ;; connection properties. We start again. - (tramp-message vec 5 "Checking system information") - (tramp-adb-send-command - vec - (concat - "echo \\\"`getprop ro.product.model` " - "`getprop ro.product.version` " - "`getprop ro.build.version.release`\\\"")) - (let ((old-getprop (tramp-get-connection-property vec "getprop")) - (new-getprop - (tramp-set-connection-property - vec "getprop" - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer)))))) - (when (and (stringp old-getprop) - (not (string-equal old-getprop new-getprop))) - (tramp-message - vec 3 - "Connection reset, because remote host changed from `%s' to `%s'" - old-getprop new-getprop) - (tramp-cleanup-connection vec t) - (tramp-adb-maybe-open-connection vec))) - - ;; Change user if indicated. - (when user - (tramp-adb-send-command vec (format "su %s" user)) - (unless (tramp-adb-send-command-and-check vec nil) - (delete-process p) - ;; Do not flush, we need the nil value. - (tramp-set-file-property vec "/" "su-command-p" nil) - (tramp-error - vec 'file-error "Cannot switch to user `%s'" user))) - - ;; Mark it as connected. - (tramp-set-connection-property p "connected" t))))))) + (with-tramp-debug-message vec "Opening connection" + (let* ((buf (tramp-get-connection-buffer vec)) + (p (get-buffer-process buf)) + (host (tramp-file-name-host vec)) + (user (tramp-file-name-user vec)) + (device (tramp-adb-get-device vec))) + + ;; Maybe we know already that "su" is not supported. We cannot + ;; use a connection property, because we have not checked yet + ;; whether it is still the same device. + (when (and user (not (tramp-get-file-property vec "/" "su-command-p" t))) + (tramp-error vec 'file-error "Cannot switch to user `%s'" user)) + + (unless (process-live-p p) + (save-match-data + (when (and p (processp p)) (delete-process p)) + (if (tramp-string-empty-or-nil-p device) + (tramp-error vec 'file-error "Device %s not connected" host)) + (with-tramp-progress-reporter vec 3 "Opening adb shell connection" + (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct? + (process-connection-type tramp-process-connection-type) + (args (tramp-expand-args + vec 'tramp-login-args ?d (or device ""))) + (p (let ((default-directory + tramp-compat-temporary-file-directory)) + (apply + #'start-process (tramp-get-connection-name vec) buf + tramp-adb-program args))) + (prompt (md5 (concat (prin1-to-string process-environment) + (current-time-string))))) + ;; Wait for initial prompt. On some devices, it needs + ;; an initial RET, in order to get it. + (sleep-for 0.1) + (tramp-send-string vec tramp-rsh-end-of-line) + (tramp-adb-wait-for-output p 30) + (unless (process-live-p p) + (tramp-error vec 'file-error "Terminated!")) + + ;; Set sentinel. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (tramp-post-process-creation p vec) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec) + + ;; Change prompt. + (tramp-set-connection-property + p "prompt" (rx "///" (literal prompt) "#$")) + (tramp-adb-send-command + vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) + + ;; Disable line editing. + (tramp-adb-send-command + vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs") + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-adb-send-command vec "set -o")) + + ;; Check whether the properties have been changed. If + ;; yes, this is a strong indication that we must expire + ;; all connection properties. We start again. + (tramp-message vec 5 "Checking system information") + (tramp-adb-send-command + vec + (concat + "echo \\\"`getprop ro.product.model` " + "`getprop ro.product.version` " + "`getprop ro.build.version.release`\\\"")) + (let ((old-getprop (tramp-get-connection-property vec "getprop")) + (new-getprop + (tramp-set-connection-property + vec "getprop" + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer)))))) + (when (and (stringp old-getprop) + (not (string-equal old-getprop new-getprop))) + (tramp-message + vec 3 + (concat + "Connection reset, because remote host changed " + "from `%s' to `%s'") + old-getprop new-getprop) + (tramp-cleanup-connection vec t) + (tramp-adb-maybe-open-connection vec))) + + ;; Change user if indicated. + (when user + (tramp-adb-send-command vec (format "su %s" user)) + (unless (tramp-adb-send-command-and-check vec nil) + (delete-process p) + ;; Do not flush, we need the nil value. + (tramp-set-file-property vec "/" "su-command-p" nil) + (tramp-error + vec 'file-error "Cannot switch to user `%s'" user))) + + ;; Mark it as connected. + (tramp-set-connection-property p "connected" t)))))))) ;;; Default connection-local variables for Tramp. diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 07f449a3a2e..3c9b9e984e6 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -738,7 +738,7 @@ buffer in your bug report. ;; Beautify encoded values. (goto-char (point-min)) - (while (re-search-forward + (while (search-forward-regexp (rx "'" (group "(decode-coding-string")) nil 'noerror) (replace-match "\\1")) (goto-char (point-max)) @@ -766,7 +766,7 @@ buffer in your bug report. (setq buffer-read-only nil) (goto-char (point-min)) (while (not (eobp)) - (if (re-search-forward tramp-buf-regexp (line-end-position) t) + (if (search-forward-regexp tramp-buf-regexp (line-end-position) t) (forward-line 1) (forward-line 0) (let ((start (point))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index bb7b266dd35..61359562ee3 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -202,7 +202,7 @@ Add the extension of F, if existing." (let ((matches 0) (case-fold-search nil)) (goto-char start) - (while (re-search-forward regexp end t) + (while (search-forward-regexp regexp end t) (replace-match replacement t) (setq matches (1+ matches))) (and (not (zerop matches)) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 9d52966b817..c85f566c4d5 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -279,8 +279,10 @@ arguments to pass to the OPERATION." (apply #'tramp-crypt-file-name-for-operation operation args)) (fn (and (tramp-crypt-file-name-p filename) (assoc operation tramp-crypt-file-name-handler-alist)))) - (save-match-data (apply (cdr fn) args)) - (tramp-crypt-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (progn (defun tramp-register-crypt-file-name-handler () @@ -312,73 +314,75 @@ connection if a previous connection has died for some reason." ;; For password handling, we need a process bound to the connection ;; buffer. Therefore, we create a dummy process. Maybe there is a ;; better solution? - (unless (get-buffer-process (tramp-get-connection-buffer vec)) - (let ((p (make-network-process - :name (tramp-get-connection-name vec) - :buffer (tramp-get-connection-buffer vec) - :server t :host 'local :service t :noquery t))) - (tramp-post-process-creation p vec))) - - ;; The following operations must be performed without - ;; `tramp-crypt-file-name-handler'. - (let* (tramp-crypt-enabled - ;; Don't check for a proper method. - (non-essential t) - (remote-config - (expand-file-name - tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) - (local-config (tramp-crypt-config-file-name vec))) - ;; There is no local encfs6 config file. - (unless (file-exists-p local-config) - (if (and tramp-crypt-save-encfs-config-remote - (file-exists-p remote-config)) - ;; Copy remote encfs6 config file if possible. - (copy-file remote-config local-config 'ok 'keep) - - ;; Create local encfs6 config file otherwise. - (let* ((default-directory tramp-compat-temporary-file-directory) - (tmpdir1 (file-name-as-directory - (tramp-compat-make-temp-file " .crypt" 'dir-flag))) - (tmpdir2 (file-name-as-directory - (tramp-compat-make-temp-file " .nocrypt" 'dir-flag)))) - ;; Enable `auth-source', unless "emacs -Q" has been called. - (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) - (with-temp-buffer - (insert - (tramp-read-passwd - (tramp-get-connection-process vec) - (format - "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) - (when - (zerop - (tramp-call-process-region - vec (point-min) (point-max) - tramp-crypt-encfs-program nil (tramp-get-connection-buffer vec) - nil tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2)) - ;; Save the password. - (ignore-errors - (and (functionp tramp-password-save-function) - (funcall tramp-password-save-function))))) - - ;; Write local config file. Suppress file name IV chaining mode. - (with-temp-file local-config - (insert-file-contents - (expand-file-name tramp-crypt-encfs-config tmpdir1)) - (when (search-forward - "1" nil 'noerror) - (replace-match "0"))) - - ;; Unmount encfs. Delete temporary directories. - (tramp-call-process - vec tramp-crypt-encfs-program nil nil nil - "--unmount" tmpdir1 tmpdir2) - (delete-directory tmpdir1 'recursive) - (delete-directory tmpdir2) - - ;; Copy local encfs6 config file to remote. - (when tramp-crypt-save-encfs-config-remote - (copy-file local-config remote-config 'ok 'keep))))))) + (with-tramp-debug-message vec "Opening connection" + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (tramp-post-process-creation p vec))) + + ;; The following operations must be performed without + ;; `tramp-crypt-file-name-handler'. + (let* (tramp-crypt-enabled + ;; Don't check for a proper method. + (non-essential t) + (remote-config + (expand-file-name + tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) + (local-config (tramp-crypt-config-file-name vec))) + ;; There is no local encfs6 config file. + (unless (file-exists-p local-config) + (if (and tramp-crypt-save-encfs-config-remote + (file-exists-p remote-config)) + ;; Copy remote encfs6 config file if possible. + (copy-file remote-config local-config 'ok 'keep) + + ;; Create local encfs6 config file otherwise. + (let* ((default-directory tramp-compat-temporary-file-directory) + (tmpdir1 (file-name-as-directory + (tramp-compat-make-temp-file " .crypt" 'dir-flag))) + (tmpdir2 (file-name-as-directory + (tramp-compat-make-temp-file " .nocrypt" 'dir-flag)))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (with-temp-buffer + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format + "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when + (zerop + (tramp-call-process-region + vec (point-min) (point-max) + tramp-crypt-encfs-program nil + (tramp-get-connection-buffer vec) nil + tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2)) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))))) + + ;; Write local config file. Suppress file name IV chaining mode. + (with-temp-file local-config + (insert-file-contents + (expand-file-name tramp-crypt-encfs-config tmpdir1)) + (when (search-forward + "1" nil 'noerror) + (replace-match "0"))) + + ;; Unmount encfs. Delete temporary directories. + (tramp-call-process + vec tramp-crypt-encfs-program nil nil nil + "--unmount" tmpdir1 tmpdir2) + (delete-directory tmpdir1 'recursive) + (delete-directory tmpdir2) + + ;; Copy local encfs6 config file to remote. + (when tramp-crypt-save-encfs-config-remote + (copy-file local-config remote-config 'ok 'keep)))))))) (defun tramp-crypt-send-command (vec &rest args) "Send encfsctl command to connection VEC. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 27dbf324924..72cf4a6a4b3 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -895,8 +895,10 @@ arguments to pass to the OPERATION." (and (tramp-tramp-file-p filename) (tramp-dissect-file-name filename))) (fn (assoc operation tramp-gvfs-file-name-handler-alist))) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (when (featurep 'dbusbind) @@ -1308,7 +1310,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; Parse output. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) - (while (re-search-forward + (while (search-forward-regexp (if file-system tramp-gvfs-file-system-attributes-regexp tramp-gvfs-file-attributes-with-gvfs-info-regexp) @@ -2182,137 +2184,139 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - ;; Sanity check. - (let ((method (tramp-file-name-method vec))) - (unless (member - (or (assoc-default - method '(("smb" . "smb-share") - ("davs" . "dav") - ("nextcloud" . "dav") - ("afp". "afp-volume") - ("gdrive" . "google-drive"))) - method) - tramp-gvfs-mounttypes) - (tramp-error vec 'file-error "Method `%s' not supported by GVFS" method))) - - ;; For password handling, we need a process bound to the connection - ;; buffer. Therefore, we create a dummy process. Maybe there is a - ;; better solution? - (unless (get-buffer-process (tramp-get-connection-buffer vec)) - (let ((p (make-network-process - :name (tramp-get-connection-name vec) - :buffer (tramp-get-connection-buffer vec) - :server t :host 'local :service t :noquery t))) - (tramp-post-process-creation p vec) - - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec))) - - (unless (tramp-gvfs-connection-mounted-p vec) - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (host (tramp-file-name-host vec)) - (localname (tramp-file-name-unquote-localname vec)) - (object-path - (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc)))) - - (when (and (string-equal method "afp") - (string-equal localname "/")) - (tramp-user-error vec "Filename must contain an AFP volume")) - - (when (and (string-match-p (rx "dav" (? "s")) method) - (string-equal localname "/")) - (tramp-user-error vec "Filename must contain a WebDAV share")) - - (when (and (string-equal method "smb") - (string-equal localname "/")) - (tramp-user-error vec "Filename must contain a Windows share")) - - (when (member method tramp-goa-methods) - ;; Ensure that GNOME Online Accounts are cached. - (tramp-get-goa-accounts vec) - (when (tramp-get-connection-property - (tramp-get-goa-account vec) "FilesDisabled" t) - (tramp-user-error - vec "There is no Online Account `%s'" - (tramp-make-tramp-file-name vec 'noloc)))) - - (with-tramp-progress-reporter - vec 3 - (if (tramp-string-empty-or-nil-p user) - (format "Opening connection for %s using %s" host method) - (format "Opening connection for %s@%s using %s" user host method)) - - ;; Enable `auth-source'. - (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) - - ;; There will be a callback of "askPassword" when a password is needed. - (dbus-register-method - :session dbus-service-emacs object-path - tramp-gvfs-interface-mountoperation "askPassword" - #'tramp-gvfs-handler-askpassword) - (dbus-register-method - :session dbus-service-emacs object-path - tramp-gvfs-interface-mountoperation "AskPassword" - #'tramp-gvfs-handler-askpassword) - - ;; There could be a callback of "askQuestion" when adding - ;; fingerprints or checking certificates. - (dbus-register-method - :session dbus-service-emacs object-path - tramp-gvfs-interface-mountoperation "askQuestion" - #'tramp-gvfs-handler-askquestion) - (dbus-register-method - :session dbus-service-emacs object-path - tramp-gvfs-interface-mountoperation "AskQuestion" - #'tramp-gvfs-handler-askquestion) - - ;; The call must be asynchronously, because of the "askPassword" - ;; or "askQuestion" callbacks. - (if (string-match-p (rx "(so)" eol) tramp-gvfs-mountlocation-signature) + (with-tramp-debug-message vec "Opening connection" + ;; Sanity check. + (let ((method (tramp-file-name-method vec))) + (unless (member + (or (assoc-default + method '(("smb" . "smb-share") + ("davs" . "dav") + ("nextcloud" . "dav") + ("afp". "afp-volume") + ("gdrive" . "google-drive"))) + method) + tramp-gvfs-mounttypes) + (tramp-error + vec 'file-error "Method `%s' not supported by GVFS" method))) + + ;; For password handling, we need a process bound to the + ;; connection buffer. Therefore, we create a dummy process. + ;; Maybe there is a better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (tramp-post-process-creation p vec) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec))) + + (unless (tramp-gvfs-connection-mounted-p vec) + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-host vec)) + (localname (tramp-file-name-unquote-localname vec)) + (object-path + (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc)))) + + (when (and (string-equal method "afp") + (string-equal localname "/")) + (tramp-user-error vec "Filename must contain an AFP volume")) + + (when (and (string-match-p (rx "dav" (? "s")) method) + (string-equal localname "/")) + (tramp-user-error vec "Filename must contain a WebDAV share")) + + (when (and (string-equal method "smb") + (string-equal localname "/")) + (tramp-user-error vec "Filename must contain a Windows share")) + + (when (member method tramp-goa-methods) + ;; Ensure that GNOME Online Accounts are cached. + (tramp-get-goa-accounts vec) + (when (tramp-get-connection-property + (tramp-get-goa-account vec) "FilesDisabled" t) + (tramp-user-error + vec "There is no Online Account `%s'" + (tramp-make-tramp-file-name vec 'noloc)))) + + (with-tramp-progress-reporter + vec 3 + (if (tramp-string-empty-or-nil-p user) + (format "Opening connection for %s using %s" host method) + (format "Opening connection for %s@%s using %s" user host method)) + + ;; Enable `auth-source'. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + + ;; There will be a callback of "askPassword" when a password is needed. + (dbus-register-method + :session dbus-service-emacs object-path + tramp-gvfs-interface-mountoperation "askPassword" + #'tramp-gvfs-handler-askpassword) + (dbus-register-method + :session dbus-service-emacs object-path + tramp-gvfs-interface-mountoperation "AskPassword" + #'tramp-gvfs-handler-askpassword) + + ;; There could be a callback of "askQuestion" when adding + ;; fingerprints or checking certificates. + (dbus-register-method + :session dbus-service-emacs object-path + tramp-gvfs-interface-mountoperation "askQuestion" + #'tramp-gvfs-handler-askquestion) + (dbus-register-method + :session dbus-service-emacs object-path + tramp-gvfs-interface-mountoperation "AskQuestion" + #'tramp-gvfs-handler-askquestion) + + ;; The call must be asynchronously, because of the + ;; "askPassword" or "askQuestion" callbacks. + (if (string-match-p (rx "(so)" eol) tramp-gvfs-mountlocation-signature) + (with-tramp-dbus-call-method vec nil + :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker + tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation + (tramp-gvfs-mount-spec vec) + `(:struct :string ,(dbus-get-unique-name :session) + :object-path ,object-path)) (with-tramp-dbus-call-method vec nil :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation (tramp-gvfs-mount-spec vec) - `(:struct :string ,(dbus-get-unique-name :session) - :object-path ,object-path)) - (with-tramp-dbus-call-method vec nil - :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker - tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation - (tramp-gvfs-mount-spec vec) - :string (dbus-get-unique-name :session) :object-path object-path)) - - ;; We must wait, until the mount is applied. This will be - ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint" - ;; file property. - (with-timeout - ((or (tramp-get-method-parameter vec 'tramp-connection-timeout) - tramp-connection-timeout) - (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) + :string (dbus-get-unique-name :session) :object-path object-path)) + + ;; We must wait, until the mount is applied. This will be + ;; indicated by the "mounted" signal, i.e. the + ;; "fuse-mountpoint" file property. + (with-timeout + ((or (tramp-get-method-parameter vec 'tramp-connection-timeout) + tramp-connection-timeout) + (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) + (tramp-error + vec 'file-error + "Timeout reached mounting %s using %s" host method) (tramp-error vec 'file-error - "Timeout reached mounting %s using %s" host method) - (tramp-error - vec 'file-error - "Timeout reached mounting %s@%s using %s" user host method))) - (while (not (tramp-get-file-property vec "/" "fuse-mountpoint")) - (read-event nil nil 0.1))) - - ;; If `tramp-gvfs-handler-askquestion' has returned "No", it - ;; is marked with the fuse-mountpoint "/". We shall react. - (when (string-equal - (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") - (tramp-error vec 'file-error "FUSE mount denied")) - - ;; Save the password. - (ignore-errors - (and (functionp tramp-password-save-function) - (funcall tramp-password-save-function))) - - ;; Mark it as connected. - (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t))))) + "Timeout reached mounting %s@%s using %s" user host method))) + (while (not (tramp-get-file-property vec "/" "fuse-mountpoint")) + (read-event nil nil 0.1))) + + ;; If `tramp-gvfs-handler-askquestion' has returned "No", it + ;; is marked with the fuse-mountpoint "/". We shall react. + (when (string-equal + (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") + (tramp-error vec 'file-error "FUSE mount denied")) + + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))) + + ;; Mark it as connected. + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t)))))) (defun tramp-gvfs-gio-tool-p (vec) "Check, whether the gio tool is available." diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el new file mode 100644 index 00000000000..bfefd95096d --- /dev/null +++ b/lisp/net/tramp-message.el @@ -0,0 +1,572 @@ +;;; tramp-message.el --- Tramp messages -*- lexical-binding:t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Michael Albinus +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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. If not, see . + +;;; Commentary: + +;; This package collects all Tramp functions to trace. This is driven +;; by the user option `tramp-verbose'. The following buffers are +;; created: +;; +;; - *debug tramp/method user@host* +;; +;; This buffer is created when `tramp-verbose' is greater than or +;; equal 4. It contains all messages with a level up to `tramp-verbose'. +;; +;; When `tramp-debug-command-messages' is non-nil and +;; `tramp-verbose' is greater than or equal 6, the buffer contains +;; all messages with level 6 and the entry/exit messages of +;; `tramp-file-name-handler'. This is intended to analyze which +;; remote commands are sent for a given file name operation. +;; +;; - *trace tramp/method user@host* +;; +;; This buffer is created by the trace.el package when +;; `tramp-verbose' is is greater than or equal 11. It traces all +;; functions with suffix "tramp-" except those function with the +;; property `tramp-suppress-trace'. + +;;; Code: + +(require 'tramp-loaddefs) +(require 'help-mode) + +(declare-function tramp-compat-string-replace "tramp-compat") +(declare-function tramp-file-name-equal-p "tramp") +(declare-function tramp-get-default-directory "tramp") +(defvar tramp-compat-temporary-file-directory) + +;;;###tramp-autoload +(defcustom tramp-verbose 3 + "Verbosity level for Tramp messages. +Any level x includes messages for all levels 1 .. x-1. The levels are + + 0 silent (no tramp messages at all) + 1 errors + 2 warnings + 3 connection to remote hosts (default level) + 4 activities + 5 internal + 6 sent and received strings + 7 connection properties + 8 file caching + 9 test commands +10 traces (huge) +11 call traces (maintainer only)." + :group 'tramp + :type 'integer) + +(defcustom tramp-debug-to-file nil + "Whether Tramp debug messages shall be saved to file. +The debug file has the same name as the debug buffer, written to +`tramp-compat-temporary-file-directory'." + :group 'tramp + :version "28.1" + :type 'boolean) + +(defcustom tramp-debug-command-messages nil + "Whether to write only command messages to the debug buffer. +This has only effect if `tramp-verbose' is greater than or equal 6." + :group 'tramp + :version "30.1" + :type 'boolean) + +(defconst tramp-debug-outline-regexp + (rx ;; Timestamp. + (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) blank + ;; Thread. + (? (group "#") blank) + ;; Function name, verbosity. + (group (+ (any "-" alnum))) " (" (group (+ digit)) ") #") + "Used for highlighting Tramp debug buffers in `outline-mode'. +When it is used for regexp matching, the regexp groups are + + 1 for the thread name (optional) + 2 for the function name + 3 for the verbosity level.") + +(defconst tramp-debug-font-lock-keywords + ;; FIXME: Make it a function instead of an ELisp expression, so you + ;; can evaluate it with `funcall' rather than `eval'! + ;; Also, in `font-lock-defaults' you can specify a function name for + ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords! + '(list + (rx bol (regexp tramp-debug-outline-regexp) (+ nonl)) + '(1 font-lock-warning-face t t) + '(0 (outline-font-lock-face) keep t)) + "Used for highlighting Tramp debug buffers in `outline-mode'.") + +(defun tramp-debug-outline-level () + "Return the depth to which a statement is nested in the outline. +Point must be at the beginning of a header line. + +The outline level is equal to the verbosity of the Tramp message." + (1+ (string-to-number (match-string 3)))) + +(put #'tramp-debug-outline-level 'tramp-suppress-trace t) + +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-debug-buffer-command-completion-p (_symbol buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only in Tramp debug buffers." + (with-current-buffer buffer + (string-equal + (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) + ";; Emacs:"))) + +(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) + +(defun tramp-setup-debug-buffer () + "Function to setup debug buffers." + ;; (declare (completion tramp-debug-buffer-command-completion-p)) + (interactive) + (set-buffer-file-coding-system 'utf-8) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes die. + ;; Yes: I've seen `flyspell-mode', which starts "ispell". + ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises + ;; on error in `(outline-mode)', we don't want to see it in the + ;; traces. + (let ((default-directory tramp-compat-temporary-file-directory)) + (outline-mode)) + (setq-local outline-level 'tramp-debug-outline-level) + (setq-local font-lock-keywords + ;; FIXME: This `(t FOO . BAR)' representation in + ;; `font-lock-keywords' is supposed to be an internal + ;; implementation "detail". Don't abuse it here! + `(t (eval ,tramp-debug-font-lock-keywords t) + ,(eval tramp-debug-font-lock-keywords t))) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map) + (set-buffer-modified-p nil) + ;; For debugging purposes. + (local-set-key "\M-n" 'clone-buffer) + (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) + +(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) + +(function-put + #'tramp-setup-debug-buffer 'completion-predicate + #'tramp-debug-buffer-command-completion-p) + +(defun tramp-debug-buffer-name (vec) + "A name for the debug buffer of VEC." + (let ((method (tramp-file-name-method vec)) + (user-domain (tramp-file-name-user-domain vec)) + (host-port (tramp-file-name-host-port vec))) + (if (or (null user-domain) (string-empty-p user-domain)) + (format "*debug tramp/%s %s*" method host-port) + (format "*debug tramp/%s %s@%s*" method user-domain host-port)))) + +(put #'tramp-debug-buffer-name 'tramp-suppress-trace t) + +(defun tramp-get-debug-buffer (vec) + "Get the debug buffer of VEC." + (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) + (when (bobp) + (tramp-setup-debug-buffer)) + (current-buffer))) + +(put #'tramp-get-debug-buffer 'tramp-suppress-trace t) + +(defun tramp-get-debug-file-name (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 traced 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 +ARGUMENTS to actually emit the message (if applicable)." + (let ((inhibit-message t) + create-lockfiles file-name-handler-alist message-log-max + signal-hook-function) + (with-current-buffer (tramp-get-debug-buffer vec) + (goto-char (point-max)) + (let ((point (point))) + (when (bobp) + ;; Headline. + (insert + (format + ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-" + emacs-version tramp-version)) + (when (>= tramp-verbose 10) + (let ((tramp-verbose 0)) + (insert + (format + "\n;; Location: %s Git: %s/%s" + (locate-library "tramp") + (or tramp-repository-branch "") + (or tramp-repository-version ""))))) + ;; Traces. + (when (>= tramp-verbose 11) + (dolist + (elt + (append + (mapcar + #'intern (all-completions "tramp-" obarray #'functionp)) + tramp-trace-functions)) + (unless (get elt 'tramp-suppress-trace) + (trace-function-background elt (tramp-trace-buffer-name vec))))) + ;; 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))))) + (unless (bolp) + (insert "\n")) + ;; Timestamp. + (insert (format-time-string "%T.%6N ")) + ;; Threads. `current-thread' might not exist when Emacs is + ;; configured --without-threads. + ;; (unless (eq (tramp-compat-funcall 'current-thread) main-thread) + ;; (insert (format "%s " (tramp-compat-funcall 'current-thread)))) + ;; Calling Tramp function. We suppress compat and trace + ;; functions from being displayed. + (let ((frames (backtrace-frames)) + btf fn) + (while (not fn) + (setq btf (cadadr frames)) + (if (not btf) + (setq fn "") + (and (symbolp btf) (setq fn (symbol-name btf)) + (or (not (string-prefix-p "tramp" fn)) + (get btf 'tramp-suppress-trace)) + (setq fn nil)) + (setq frames (cdr frames)))) + ;; The following code inserts filename and line number. + ;; Should be inactive by default, because it is time consuming. + ;; (let ((ffn (find-function-noselect (intern fn)))) + ;; (insert + ;; (format + ;; "%s:%d: " + ;; (file-name-nondirectory (buffer-file-name (car ffn))) + ;; (with-current-buffer (car ffn) + ;; (1+ (count-lines (point-min) (cdr ffn))))))) + (insert (format "%s " fn))) + ;; The message. + (insert (apply #'format-message fmt-string arguments)) + (if tramp-debug-command-messages + ;; Add help function. + (tramp-debug-message-buttonize point) + ;; Write message to debug file. + (when tramp-debug-to-file + (ignore-errors + (write-region + point (point-max) (tramp-get-debug-file-name vec) 'append)))))))) + +(put #'tramp-debug-message 'tramp-suppress-trace t) + +;;;###tramp-autoload +(defun tramp-message (vec-or-proc level fmt-string &rest arguments) + "Emit a message depending on verbosity level. +VEC-OR-PROC identifies the Tramp buffer to use. It can be either a +vector or a process. LEVEL says to be quiet if `tramp-verbose' is +less than LEVEL. The message is emitted only if `tramp-verbose' is +greater than or equal to LEVEL. + +The message is also logged into the debug buffer when `tramp-verbose' +is greater than or equal 4. + +Calls functions `message' and `tramp-debug-message' with FMT-STRING as +control string and the remaining ARGUMENTS to actually emit the message (if +applicable)." + (ignore-errors + (when (<= level tramp-verbose) + ;; Display only when there is a minimum level, and the progress + ;; reporter doesn't suppress further messages. + (when (and (<= level 3) (null tramp-inhibit-progress-reporter)) + (apply #'message + (concat + (cond + ((= level 0) "") + ((= level 1) "") + ((= level 2) "Warning: ") + (t "Tramp: ")) + fmt-string) + arguments)) + ;; Log only when there is a minimum level. + (when (>= tramp-verbose 4) + (let ((tramp-verbose 0)) + ;; Append connection buffer for error messages, if exists. + (when (= level 1) + (ignore-errors + (setq fmt-string (concat fmt-string "\n%s") + arguments + (append + arguments + `(,(tramp-get-buffer-string + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer + vec-or-proc 'dont-create)))))))) + ;; Translate proc to vec. + (when (processp vec-or-proc) + (setq vec-or-proc (process-get vec-or-proc 'tramp-vector)))) + ;; Do it. + (when (and (tramp-file-name-p vec-or-proc) + (or (null tramp-debug-command-messages) (= level 6))) + (apply #'tramp-debug-message + vec-or-proc + (concat (format "(%d) # " level) fmt-string) + arguments)))))) + +(defsubst tramp-backtrace (&optional vec-or-proc force) + "Dump a backtrace into the debug buffer. +If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE +forces the backtrace even if `tramp-verbose' is less than 10. +This function is meant for debugging purposes." + (let ((tramp-verbose (if force 10 tramp-verbose))) + (when (>= tramp-verbose 10) + (if vec-or-proc + (tramp-message + vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) + (with-output-to-temp-buffer "*debug tramp*" (backtrace)))))) + +(defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) + "Emit an error. +VEC-OR-PROC identifies the connection to use, SIGNAL is the +signal identifier to be raised, remaining arguments passed to +`tramp-message'. Finally, signal SIGNAL is raised with +FMT-STRING and ARGUMENTS." + (let (signal-hook-function) + (tramp-backtrace vec-or-proc) + (unless arguments + ;; FMT-STRING could be just a file name, as in + ;; `file-already-exists' errors. It could contain the ?\% + ;; character, as in smb domain spec. + (setq arguments (list fmt-string) + fmt-string "%s")) + (when vec-or-proc + (tramp-message + vec-or-proc 1 "%s" + (error-message-string + (list signal + (get signal 'error-message) + (apply #'format-message fmt-string arguments))))) + (signal signal (list (substring-no-properties + (apply #'format-message fmt-string arguments)))))) + +(defvar tramp-error-show-message-timeout 30 + "Time to show the Tramp buffer in case of an error. +If it is bound to nil, the buffer is not shown. This is used in +tramp-tests.el.") + +(defsubst tramp-error-with-buffer + (buf vec-or-proc signal fmt-string &rest arguments) + "Emit an error, and show BUF. +If BUF is nil, show the connection buf. Wait for 30\", or until +an input event arrives. The other arguments are passed to `tramp-error'." + (save-window-excursion + (let* ((buf (or (and (bufferp buf) buf) + (and (processp vec-or-proc) (process-buffer vec-or-proc)) + (and (tramp-file-name-p vec-or-proc) + (tramp-get-connection-buffer vec-or-proc)))) + (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc) + (and buf (tramp-dissect-file-name + (tramp-get-default-directory buf)))))) + (unwind-protect + (apply #'tramp-error vec-or-proc signal fmt-string arguments) + ;; Save exit. + (when (and buf + (natnump tramp-error-show-message-timeout) + (not (zerop tramp-verbose)) + ;; Do not show when flagged from outside. + (not non-essential) + ;; Show only when Emacs has started already. + (current-message)) + (let ((enable-recursive-minibuffers t) + inhibit-message) + ;; `tramp-error' does not show messages. So we must do it + ;; ourselves. + (apply #'message fmt-string arguments) + ;; Show buffer. + (pop-to-buffer buf) + (discard-input) + (sit-for tramp-error-show-message-timeout))) + ;; Reset timestamp. It would be wrong after waiting for a while. + (when (tramp-file-name-equal-p vec (car tramp-current-connection)) + (setcdr tramp-current-connection (current-time))))))) + +(defsubst tramp-user-error (vec-or-proc fmt-string &rest arguments) + "Signal a user error (or \"pilot error\")." + (unwind-protect + (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) + ;; Save exit. + (when (and (natnump tramp-error-show-message-timeout) + (not (zerop tramp-verbose)) + ;; Do not show when flagged from outside. + (not non-essential) + ;; Show only when Emacs has started already. + (current-message)) + (let ((enable-recursive-minibuffers t) + inhibit-message) + ;; `tramp-error' does not show messages. So we must do it ourselves. + (apply #'message fmt-string arguments) + (discard-input) + (sit-for tramp-error-show-message-timeout) + ;; Reset timestamp. It would be wrong after waiting for a while. + (when + (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) + (setcdr tramp-current-connection (current-time))))))) + +(defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) + "Execute BODY while redirecting the error message to `tramp-message'. +BODY is executed like wrapped by `with-demoted-errors'. FORMAT +is a format-string containing a %-sequence meaning to substitute +the resulting error message." + (declare (indent 2) (debug (symbolp form body))) + (let ((err (make-symbol "err"))) + `(condition-case-unless-debug ,err + (progn ,@body) + (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) + +(defun tramp-debug-button-action (button) + "Goto the linked message in debug buffer at place." + (when (mouse-event-p last-input-event) (mouse-set-point last-input-event)) + (when-let ((point (button-get button 'position))) + (goto-char point))) + +(put #'tramp-debug-button-action 'tramp-suppress-trace t) + +(define-button-type 'tramp-debug-button-type + 'follow-link t + 'mouse-face 'highlight + 'action #'tramp-debug-button-action) + +(defun tramp-debug-link-messages (pos1 pos2) + "Set links for two messages in current buffer. +The link buttons are in the verbositiy level substrings." + (save-excursion + (let (beg1 end1 beg2 end2) + (goto-char pos1) + ;; Find positions. + (while (not (search-forward-regexp + tramp-debug-outline-regexp (line-end-position) t)) + (forward-line)) + (setq beg1 (1- (match-beginning 3)) end1 (1+ (match-end 3))) + (goto-char pos2) + (while (not (search-forward-regexp + tramp-debug-outline-regexp (line-end-position) t)) + (forward-line)) + (setq beg2 (1- (match-beginning 3)) end2 (1+ (match-end 3))) + ;; Create text buttons. + (make-text-button + beg1 end1 :type 'tramp-debug-button-type + 'position (set-marker (make-marker) beg2) + 'help-echo "mouse-2, RET: goto exit message") + (make-text-button + beg2 end2 :type 'tramp-debug-button-type + 'position (set-marker (make-marker) beg1) + 'help-echo "mouse-2, RET: goto entry message")))) + +(put #'tramp-debug-link-messages 'tramp-suppress-trace t) + +(defvar tramp-debug-nesting "" + "Indicator for debug messages nested level. +This shouldn't be changed globally, but let-bind where needed.") + +(defvar tramp-debug-message-fnh-function nil + "The used file name handler operation. +Bound in `tramp-*-file-name-handler' functions.") + +(defun tramp-debug-message-buttonize (position) + "Buttonize function in current buffer, at next line starting after POSTION." + (save-excursion + (goto-char position) + (while (not (search-forward-regexp + tramp-debug-outline-regexp (line-end-position) t)) + (forward-line)) + (let ((fun (intern (match-string 2)))) + (make-text-button + (match-beginning 2) (match-end 2) + :type 'help-function-def + 'help-args (list fun (symbol-file fun)))))) + +(put #'tramp-debug-message-buttonize 'tramp-suppress-trace t) + +;; This is used in `tramp-file-name-handler' and `tramp-*-maybe-open-connection'. +(defmacro with-tramp-debug-message (vec message &rest body) + "Execute BODY, embedded with MESSAGE in the debug buffer of VEC. +If BODY does not raise a debug message, MESSAGE is ignored." + (declare (indent 2) (debug t)) + (let ((result (make-symbol "result"))) + `(if (and tramp-debug-command-messages (>= tramp-verbose 6)) + (save-match-data + (let ((tramp-debug-nesting + (concat tramp-debug-nesting "#")) + (buf (tramp-get-debug-buffer ,vec)) + beg end ,result) + ;; Insert entry message. + (with-current-buffer buf + (setq beg (point)) + (tramp-debug-message + ,vec "(4) %s %s ..." tramp-debug-nesting ,message) + (setq end (point))) + (unwind-protect + ;; Run BODY. + (setq tramp-debug-message-fnh-function nil + ,result (progn ,@body)) + (with-current-buffer buf + (if (= end (point-max)) + (progn + (delete-region beg end) + (when (bobp) (kill-buffer))) + ;; Insert exit message. + (tramp-debug-message + ,vec "(5) %s %s ... %s" tramp-debug-nesting ,message ,result) + ;; Adapt file name handler function. + (dolist (pos (list (point-max) end)) + (goto-char pos) + (when (and tramp-debug-message-fnh-function + (search-backward + "tramp-file-name-handler" + (line-beginning-position) t)) + (replace-match + (symbol-name tramp-debug-message-fnh-function)) + (tramp-debug-message-buttonize + (line-beginning-position)))) + ;; Link related messages. + (goto-char (point-max)) + (tramp-debug-link-messages beg (line-beginning-position))))))) + + ;; No special messages. + ,@body))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-message 'force))) + +(provide 'tramp-message) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index df46bd5e20e..c2b84845f68 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -175,8 +175,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (tramp--with-startup @@ -377,53 +379,55 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - (let ((host (tramp-file-name-host vec))) - (when (rassoc `(,host) (tramp-rclone-parse-device-names nil)) - (if (tramp-string-empty-or-nil-p host) - (tramp-error vec 'file-error "Storage %s not connected" host)) - ;; We need a process bound to the connection buffer. Therefore, - ;; we create a dummy process. Maybe there is a better solution? - (unless (get-buffer-process (tramp-get-connection-buffer vec)) - (let ((p (make-network-process - :name (tramp-get-connection-name vec) - :buffer (tramp-get-connection-buffer vec) - :server t :host 'local :service t :noquery t))) - (tramp-post-process-creation p vec) - - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec))) - - ;; Create directory. - (unless (file-directory-p (tramp-fuse-mount-point vec)) - (make-directory (tramp-fuse-mount-point vec) 'parents)) - - ;; Mount. This command does not return, so we use 0 as - ;; DESTINATION of `tramp-call-process'. - (unless (tramp-fuse-mounted-p vec) - (apply - #'tramp-call-process - vec tramp-rclone-program nil 0 nil - "mount" (tramp-fuse-mount-spec vec) - (tramp-fuse-mount-point vec) - (tramp-get-method-parameter vec 'tramp-mount-args)) - (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) - (tramp-cleanup-connection vec 'keep-debug 'keep-password)) - - ;; Mark it as connected. - (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec)) - (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t)))) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (with-tramp-connection-property - vec "uid-integer" (tramp-get-local-uid 'integer)) - (with-tramp-connection-property - vec "gid-integer" (tramp-get-local-gid 'integer)) - (with-tramp-connection-property - vec "uid-string" (tramp-get-local-uid 'string)) - (with-tramp-connection-property - vec "gid-string" (tramp-get-local-gid 'string))) + (with-tramp-debug-message vec "Opening connection" + (let ((host (tramp-file-name-host vec))) + (when (rassoc `(,host) (tramp-rclone-parse-device-names nil)) + (if (tramp-string-empty-or-nil-p host) + (tramp-error vec 'file-error "Storage %s not connected" host)) + ;; We need a process bound to the connection buffer. + ;; Therefore, we create a dummy process. Maybe there is a + ;; better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (tramp-post-process-creation p vec) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec))) + + ;; Create directory. + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) + + ;; Mount. This command does not return, so we use 0 as + ;; DESTINATION of `tramp-call-process'. + (unless (tramp-fuse-mounted-p vec) + (apply + #'tramp-call-process + vec tramp-rclone-program nil 0 nil + "mount" (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-get-method-parameter vec 'tramp-mount-args)) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) + + ;; Mark it as connected. + (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec)) + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t)))) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string)))) (defun tramp-rclone-send-command (vec &rest args) "Send a command to connection VEC. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 0cb953e2d80..e889cb2e86f 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1571,7 +1571,7 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-shell-quote-argument localname)))) (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) - (when (re-search-forward regexp (line-end-position) t) + (when (search-forward-regexp regexp (line-end-position) t) (setq context (list (match-string 1) (match-string 2) (match-string 3) (match-string 4)))))) ;; Return the context. @@ -2152,7 +2152,7 @@ the uid and gid from FILENAME." (or (and keep-date ;; Mask cp -f error. - (re-search-forward + (search-forward-regexp tramp-operation-not-permitted-regexp nil t)) cmd-result) (tramp-error-with-buffer @@ -2612,7 +2612,7 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Check for "--dired" output. - (when (re-search-backward + (when (search-backward-regexp (rx bol "//DIRED//" (+ blank) (group (+ nonl)) eol) nil 'noerror) (let ((beg (match-beginning 1)) @@ -2627,7 +2627,7 @@ The method used must be an out-of-band method." (put-text-property start end 'dired-filename t)))))) ;; Remove trailing lines. (goto-char (point-max)) - (while (re-search-backward (rx bol "//") nil 'noerror) + (while (search-backward-regexp (rx bol "//") nil 'noerror) (forward-line 1) (delete-region (match-beginning 0) (point)))) ;; Reset multibyte if needed. @@ -2639,7 +2639,7 @@ The method used must be an out-of-band method." (unless (tramp-compat-string-search "color" (tramp-get-connection-property v "ls" "")) (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp ansi-color-control-seq-regexp nil t) (replace-match ""))) ;; Now decode what read if necessary. Stolen from `insert-directory'. @@ -2686,7 +2686,8 @@ The method used must be an out-of-band method." ;; Try to insert the amount of free space. (goto-char (point-min)) ;; First find the line to put it on. - (when (and (re-search-forward (rx bol (group (* blank) "total")) nil t) + (when (and (search-forward-regexp + (rx bol (group (* blank) "total")) nil t) ;; Emacs 29.1 or later. (not (fboundp 'dired--insert-disk-space))) (when-let ((available (get-free-disk-space "."))) @@ -3639,8 +3640,10 @@ implementation will be used." "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist))) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (defun tramp-sh-file-name-handler-p (vec) @@ -5038,235 +5041,240 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name")) - (process-environment (copy-sequence process-environment)) - (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) - - ;; If Tramp opens the same connection within a short time frame, - ;; there is a problem. We shall signal this. - (unless (or (process-live-p p) - (and (processp p) (not non-essential)) - (not (tramp-file-name-equal-p - vec (car tramp-current-connection))) - (time-less-p - (time-since (cdr tramp-current-connection)) - (or tramp-connection-min-time-diff 0))) - (throw 'suppress 'suppress)) - - ;; If too much time has passed since last command was sent, look - ;; whether process is still alive. If it isn't, kill it. When - ;; using ssh, it can sometimes happen that the remote end has hung - ;; up but the local ssh client doesn't recognize this until it - ;; tries to send some data to the remote end. So that's why we - ;; try to send a command from time to time, then look again - ;; whether the process is really alive. - (condition-case nil - (when (and (time-less-p - 60 (time-since - (tramp-get-connection-property p "last-cmd-time" 0))) - (process-live-p p)) - (tramp-send-command vec "echo are you awake" t t) - (unless (and (process-live-p p) - (tramp-wait-for-output p 10)) - ;; The error will be caught locally. - (tramp-error vec 'file-error "Awake did fail"))) - (file-error - (tramp-cleanup-connection vec t) - (setq p nil))) - - ;; New connection must be opened. - (condition-case err - (unless (process-live-p p) - (with-tramp-progress-reporter - vec 3 - (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) - (format "Opening connection %s for %s using %s" + (with-tramp-debug-message vec "Opening connection" + (let ((p (tramp-get-connection-process vec)) + (process-name (tramp-get-connection-property vec "process-name")) + (process-environment (copy-sequence process-environment)) + (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) + + ;; If Tramp opens the same connection within a short time frame, + ;; there is a problem. We shall signal this. + (unless (or (process-live-p p) + (and (processp p) (not non-essential)) + (not (tramp-file-name-equal-p + vec (car tramp-current-connection))) + (time-less-p + (time-since (cdr tramp-current-connection)) + (or tramp-connection-min-time-diff 0))) + (throw 'suppress 'suppress)) + + ;; If too much time has passed since last command was sent, look + ;; whether process is still alive. If it isn't, kill it. When + ;; using ssh, it can sometimes happen that the remote end has + ;; hung up but the local ssh client doesn't recognize this until + ;; it tries to send some data to the remote end. So that's why + ;; we try to send a command from time to time, then look again + ;; whether the process is really alive. + (condition-case nil + (when (and (time-less-p + 60 (time-since + (tramp-get-connection-property p "last-cmd-time" 0))) + (process-live-p p)) + (tramp-send-command vec "echo are you awake" t t) + (unless (and (process-live-p p) + (tramp-wait-for-output p 10)) + ;; The error will be caught locally. + (tramp-error vec 'file-error "Awake did fail"))) + (file-error + (tramp-cleanup-connection vec t) + (setq p nil))) + + ;; New connection must be opened. + (condition-case err + (unless (process-live-p p) + (with-tramp-progress-reporter + vec 3 + (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) + (format "Opening connection %s for %s using %s" + process-name + (tramp-file-name-host vec) + (tramp-file-name-method vec)) + (format "Opening connection %s for %s@%s using %s" process-name + (tramp-file-name-user vec) (tramp-file-name-host vec) - (tramp-file-name-method vec)) - (format "Opening connection %s for %s@%s using %s" - process-name - (tramp-file-name-user vec) - (tramp-file-name-host vec) - (tramp-file-name-method vec))) - - (catch 'uname-changed - ;; Start new process. - (when (and p (processp p)) - (delete-process p)) - (setenv "TERM" tramp-terminal-type) - (setenv "LC_ALL" (tramp-get-local-locale vec)) - (if (stringp tramp-histfile-override) - (setenv "HISTFILE" tramp-histfile-override) - (if tramp-histfile-override - (progn - (setenv "HISTFILE") - (setenv "HISTFILESIZE" "0") - (setenv "HISTSIZE" "0")))) - (setenv "PROMPT_COMMAND") - (setenv "PS1" tramp-initial-end-of-output) - (unless (stringp tramp-encoding-shell) - (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) - (let* ((current-host tramp-system-name) - (target-alist (tramp-compute-multi-hops vec)) - (previous-hop tramp-null-hop) - ;; We will apply `tramp-ssh-controlmaster-options' - ;; only for the first hop. - (options (tramp-ssh-controlmaster-options vec)) - (process-connection-type tramp-process-connection-type) - (process-adaptive-read-buffering nil) - ;; There are unfortunate settings for "cmdproxy" on - ;; W32 systems. - (process-coding-system-alist nil) - (coding-system-for-read nil) - (extra-args (tramp-get-sh-extra-args tramp-encoding-shell)) - ;; This must be done in order to avoid our file - ;; name handler. - (p (let ((default-directory - tramp-compat-temporary-file-directory)) - (apply - #'start-process - (tramp-get-connection-name vec) - (tramp-get-connection-buffer vec) - (append - (list tramp-encoding-shell) - (and extra-args (split-string extra-args)) - (and tramp-encoding-command-interactive - (list tramp-encoding-command-interactive))))))) - - ;; This is neded for ssh or PuTTY based processes, and - ;; only if the respective options are set. Perhaps, - ;; the setting could be more fine-grained. - ;; (process-put p 'tramp-shared-socket t) - ;; Set sentinel. Initialize variables. - (set-process-sentinel p #'tramp-process-sentinel) - (tramp-post-process-creation p vec) - (setq tramp-current-connection (cons vec (current-time))) - - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec) - - ;; Check whether process is alive. - (tramp-barf-if-no-shell-prompt - p 10 - "Couldn't find local shell prompt for %s" tramp-encoding-shell) - - ;; Now do all the connections as specified. - (while target-alist - (let* ((hop (car target-alist)) - (l-method (tramp-file-name-method hop)) - (l-user (tramp-file-name-user hop)) - (l-domain (tramp-file-name-domain hop)) - (l-host (tramp-file-name-host hop)) - (l-port (tramp-file-name-port hop)) - (remote-shell - (tramp-get-method-parameter hop 'tramp-remote-shell)) - (extra-args (tramp-get-sh-extra-args remote-shell)) - (async-args - (flatten-tree - (tramp-get-method-parameter hop 'tramp-async-args))) - (connection-timeout - (tramp-get-method-parameter - hop 'tramp-connection-timeout)) - (command - (tramp-get-method-parameter hop 'tramp-login-program)) - ;; We don't create the temporary file. In - ;; fact, it is just a prefix for the - ;; ControlPath option of ssh; the real - ;; temporary file has another name, and it is - ;; created and protected by ssh. It is also - ;; removed by ssh when the connection is - ;; closed. The temporary file name is cached - ;; in the main connection process, therefore - ;; we cannot use `tramp-get-connection-process'. - (tmpfile - (with-tramp-connection-property - (tramp-get-process vec) "temp-file" - (tramp-compat-make-temp-name))) - r-shell) - - ;; Check, whether there is a restricted shell. - (dolist (elt tramp-restricted-shell-hosts-alist) - (when (string-match-p elt current-host) - (setq r-shell t))) - (setq current-host l-host) - - ;; Set password prompt vector. - (tramp-set-connection-property - p "password-vector" - (if (tramp-get-method-parameter - hop 'tramp-password-previous-hop) - (let ((pv (copy-tramp-file-name previous-hop))) - (setf (tramp-file-name-method pv) l-method) - pv) - (make-tramp-file-name - :method l-method :user l-user :domain l-domain - :host l-host :port l-port))) - - ;; Set session timeout. - (when (tramp-get-method-parameter - hop 'tramp-session-timeout) + (tramp-file-name-method vec))) + + (catch 'uname-changed + ;; Start new process. + (when (and p (processp p)) + (delete-process p)) + (setenv "TERM" tramp-terminal-type) + (setenv "LC_ALL" (tramp-get-local-locale vec)) + (if (stringp tramp-histfile-override) + (setenv "HISTFILE" tramp-histfile-override) + (if tramp-histfile-override + (progn + (setenv "HISTFILE") + (setenv "HISTFILESIZE" "0") + (setenv "HISTSIZE" "0")))) + (setenv "PROMPT_COMMAND") + (setenv "PS1" tramp-initial-end-of-output) + (unless (stringp tramp-encoding-shell) + (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) + (let* ((current-host tramp-system-name) + (target-alist (tramp-compute-multi-hops vec)) + (previous-hop tramp-null-hop) + ;; We will apply `tramp-ssh-controlmaster-options' + ;; only for the first hop. + (options (tramp-ssh-controlmaster-options vec)) + (process-connection-type tramp-process-connection-type) + (process-adaptive-read-buffering nil) + ;; There are unfortunate settings for + ;; "cmdproxy" on W32 systems. + (process-coding-system-alist nil) + (coding-system-for-read nil) + (extra-args + (tramp-get-sh-extra-args tramp-encoding-shell)) + ;; This must be done in order to avoid our file + ;; name handler. + (p (let ((default-directory + tramp-compat-temporary-file-directory)) + (apply + #'start-process + (tramp-get-connection-name vec) + (tramp-get-connection-buffer vec) + (append + `(,tramp-encoding-shell) + (and extra-args (split-string extra-args)) + (and tramp-encoding-command-interactive + `(,tramp-encoding-command-interactive))))))) + + ;; This is neded for ssh or PuTTY based processes, + ;; and only if the respective options are set. + ;; Perhaps, the setting could be more fine-grained. + ;; (process-put p 'tramp-shared-socket t) + ;; Set sentinel. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (tramp-post-process-creation p vec) + (setq tramp-current-connection (cons vec (current-time))) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec) + + ;; Check whether process is alive. + (tramp-barf-if-no-shell-prompt + p 10 + "Couldn't find local shell prompt for %s" + tramp-encoding-shell) + + ;; Now do all the connections as specified. + (while target-alist + (let* ((hop (car target-alist)) + (l-method (tramp-file-name-method hop)) + (l-user (tramp-file-name-user hop)) + (l-domain (tramp-file-name-domain hop)) + (l-host (tramp-file-name-host hop)) + (l-port (tramp-file-name-port hop)) + (remote-shell + (tramp-get-method-parameter hop 'tramp-remote-shell)) + (extra-args (tramp-get-sh-extra-args remote-shell)) + (async-args + (flatten-tree + (tramp-get-method-parameter hop 'tramp-async-args))) + (connection-timeout + (tramp-get-method-parameter + hop 'tramp-connection-timeout)) + (command + (tramp-get-method-parameter + hop 'tramp-login-program)) + ;; We don't create the temporary file. In + ;; fact, it is just a prefix for the + ;; ControlPath option of ssh; the real + ;; temporary file has another name, and it + ;; is created and protected by ssh. It is + ;; also removed by ssh when the connection + ;; is closed. The temporary file name is + ;; cached in the main connection process, + ;; therefore we cannot use + ;; `tramp-get-connection-process'. + (tmpfile + (with-tramp-connection-property + (tramp-get-process vec) "temp-file" + (tramp-compat-make-temp-name))) + r-shell) + + ;; Check, whether there is a restricted shell. + (dolist (elt tramp-restricted-shell-hosts-alist) + (when (string-match-p elt current-host) + (setq r-shell t))) + (setq current-host l-host) + + ;; Set password prompt vector. (tramp-set-connection-property - p "session-timeout" - (tramp-get-method-parameter - hop 'tramp-session-timeout))) - - ;; Replace `login-args' place holders. - (setq - command - (string-join - (append - ;; We do not want to see the trailing local - ;; prompt in `start-file-process'. - (unless r-shell '("exec")) - `(,command) - ;; Add arguments for asynchronous processes. - (when process-name async-args) - (tramp-expand-args - hop 'tramp-login-args - ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") - ?c (format-spec options (format-spec-make ?t tmpfile)) - ?n (concat - "2>" (tramp-get-remote-null-device previous-hop)) - ?l (concat remote-shell " " extra-args " -i")) - ;; A restricted shell does not allow "exec". - (when r-shell '("&&" "exit" "||" "exit"))) - " ")) - - ;; Send the command. - (tramp-message vec 3 "Sending command `%s'" command) - (tramp-send-command vec command t t) - (tramp-process-actions - p vec - (min - pos (with-current-buffer (process-buffer p) (point-max))) - tramp-actions-before-shell - (or connection-timeout tramp-connection-timeout)) - (tramp-message - vec 3 "Found remote shell prompt on `%s'" l-host) - - ;; Next hop. - (setq options "" - target-alist (cdr target-alist) - previous-hop hop))) - - ;; Activate session timeout. - (when (tramp-get-connection-property p "session-timeout") - (run-at-time - (tramp-get-connection-property p "session-timeout") nil - #'tramp-timeout-session vec)) - - ;; Make initial shell settings. - (tramp-open-connection-setup-interactive-shell p vec) - - ;; Mark it as connected. - (tramp-set-connection-property p "connected" t))))) - - ;; Cleanup, and propagate the signal. - ((error quit) - (tramp-cleanup-connection vec t) - (signal (car err) (cdr err)))))) + p "password-vector" + (if (tramp-get-method-parameter + hop 'tramp-password-previous-hop) + (let ((pv (copy-tramp-file-name previous-hop))) + (setf (tramp-file-name-method pv) l-method) + pv) + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port))) + + ;; Set session timeout. + (when (tramp-get-method-parameter + hop 'tramp-session-timeout) + (tramp-set-connection-property + p "session-timeout" + (tramp-get-method-parameter + hop 'tramp-session-timeout))) + + ;; Replace `login-args' place holders. + (setq + command + (string-join + (append + ;; We do not want to see the trailing local + ;; prompt in `start-file-process'. + (unless r-shell '("exec")) + `(,command) + ;; Add arguments for asynchronous processes. + (when process-name async-args) + (tramp-expand-args + hop 'tramp-login-args + ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") + ?c (format-spec options (format-spec-make ?t tmpfile)) + ?n (concat + "2>" (tramp-get-remote-null-device previous-hop)) + ?l (concat remote-shell " " extra-args " -i")) + ;; A restricted shell does not allow "exec". + (when r-shell '("&&" "exit" "||" "exit"))) + " ")) + + ;; Send the command. + (tramp-message vec 3 "Sending command `%s'" command) + (tramp-send-command vec command t t) + (tramp-process-actions + p vec + (min + pos (with-current-buffer (process-buffer p) (point-max))) + tramp-actions-before-shell + (or connection-timeout tramp-connection-timeout)) + (tramp-message + vec 3 "Found remote shell prompt on `%s'" l-host) + + ;; Next hop. + (setq options "" + target-alist (cdr target-alist) + previous-hop hop))) + + ;; Activate session timeout. + (when (tramp-get-connection-property p "session-timeout") + (run-at-time + (tramp-get-connection-property p "session-timeout") nil + #'tramp-timeout-session vec)) + + ;; Make initial shell settings. + (tramp-open-connection-setup-interactive-shell p vec) + + ;; Mark it as connected. + (tramp-set-connection-property p "connected" t))))) + + ;; Cleanup, and propagate the signal. + ((error quit) + (tramp-cleanup-connection vec t) + (signal (car err) (cdr err))))))) (defun tramp-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC. @@ -5322,7 +5330,7 @@ function waits for output unless NOOUTPUT is set." ;; A simple-minded busybox has sent " ^H" sequences. ;; Delete them. (goto-char (point-min)) - (when (re-search-forward + (when (search-forward-regexp (rx bol (+ nonl "\b") eol) (line-end-position) t) (forward-line 1) (delete-region (point-min) (point))) @@ -5404,7 +5412,7 @@ raises an error." ;; Read the marker. (when (stringp marker) (condition-case nil - (re-search-forward marker) + (search-forward-regexp marker) (error (unless noerror (tramp-error vec 'file-error @@ -5417,7 +5425,7 @@ raises an error." (unless noerror signal-hook-function))) (read (current-buffer))) ;; Error handling. - (when (re-search-forward (rx (not blank)) (line-end-position) t) + (when (search-forward-regexp (rx (not blank)) (line-end-position) t) (error nil))) (error (unless noerror (tramp-error diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index dab85c5160e..60d40fef147 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -68,8 +68,8 @@ (defcustom tramp-smb-acl-program "smbcacls" "Name of SMB acls to run." :group 'tramp - :type 'string - :version "24.4") + :version "24.4" + :type 'string) (defcustom tramp-smb-conf null-device "Path of the \"smb.conf\" file. @@ -85,8 +85,8 @@ They are added to the `tramp-smb-program' call via \"--option '...'\". For example, if the deprecated SMB1 protocol shall be used, add to this variable \"client min protocol=NT1\"." :group 'tramp - :type '(repeat string) - :version "28.1") + :version "28.1" + :type '(repeat string)) (defvar tramp-smb-version nil "Version string of the SMB client.") @@ -318,22 +318,22 @@ Operations not mentioned here will be handled by the default Emacs primitives.") If it isn't found in the local $PATH, the absolute path of winexe shall be given. This is needed for remote processes." :group 'tramp - :type 'string - :version "24.3") + :version "24.3" + :type 'string) (defcustom tramp-smb-winexe-shell-command "powershell.exe" "Shell to be used for processes on remote machines. This must be Powershell V2 compatible." :group 'tramp - :type 'string - :version "24.3") + :version "24.3" + :type 'string) (defcustom tramp-smb-winexe-shell-command-switch "-file -" "Command switch used together with `tramp-smb-winexe-shell-command'. This can be used to disable echo etc." :group 'tramp - :type 'string - :version "24.3") + :version "24.3" + :type 'string) ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. @@ -349,8 +349,10 @@ This can be used to disable echo etc." First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist))) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) @@ -867,7 +869,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Loop the listing. (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (unless (re-search-forward tramp-smb-errors nil t) + (unless (search-forward-regexp tramp-smb-errors nil t) (while (not (eobp)) (cond ((looking-at @@ -1618,7 +1620,7 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." ;; Loop the listing. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) - (if (re-search-forward tramp-smb-errors nil t) + (if (search-forward-regexp tramp-smb-errors nil t) (tramp-error v 'file-error "%s `%s'" (match-string 0) directory) (while (not (eobp)) (setq entry (tramp-smb-read-file-entry share)) @@ -1809,8 +1811,8 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (when (tramp-smb-send-command vec "posix") (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (when - (re-search-forward "Server supports CIFS capabilities" nil t) + (when (search-forward-regexp + "Server supports CIFS capabilities" nil t) (member "pathnames" (split-string @@ -1846,153 +1848,152 @@ If ARGUMENT is non-nil, use it as argument for (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - (let* ((share (tramp-smb-get-share vec)) - (buf (tramp-get-connection-buffer vec)) - (p (get-buffer-process buf))) + (with-tramp-debug-message vec "Opening connection" + (let* ((share (tramp-smb-get-share vec)) + (buf (tramp-get-connection-buffer vec)) + (p (get-buffer-process buf))) + + ;; Check whether we still have the same smbclient version. + ;; Otherwise, we must delete the connection cache, because + ;; capabilities might have changed. + (unless (or argument (processp p)) + (let ((default-directory tramp-compat-temporary-file-directory) + (command (concat tramp-smb-program " -V"))) + + (unless tramp-smb-version + (unless (executable-find tramp-smb-program) + (tramp-error + vec 'file-error + "Cannot find command %s in %s" tramp-smb-program exec-path)) + (setq tramp-smb-version (shell-command-to-string command)) + (tramp-message vec 6 command) + (tramp-message vec 6 "\n%s" tramp-smb-version) + (if (string-match (rx (+ (any " \t\r\n")) eos) tramp-smb-version) + (setq tramp-smb-version + (replace-match "" nil nil tramp-smb-version)))) + + (unless (string-equal + tramp-smb-version + (tramp-get-connection-property + vec "smbclient-version" tramp-smb-version)) + (tramp-flush-directory-properties vec "/") + (tramp-flush-connection-properties vec)) + + (tramp-set-connection-property + vec "smbclient-version" tramp-smb-version))) + + ;; If too much time has passed since last command was sent, look + ;; whether there has been an error message; maybe due to + ;; connection timeout. + (with-current-buffer buf + (goto-char (point-min)) + (when (and (time-less-p + 60 (time-since + (tramp-get-connection-property p "last-cmd-time" 0))) + (process-live-p p) + (search-forward-regexp tramp-smb-errors nil t)) + (delete-process p) + (setq p nil))) + + ;; Check whether it is still the same share. + (unless (and (process-live-p p) + (or argument + (string-equal + share + (tramp-get-connection-property p "smb-share" "")))) + (save-match-data + ;; There might be unread output from checking for share names. + (when buf (with-current-buffer buf (erase-buffer))) + (when (and p (processp p)) (delete-process p)) - ;; Check whether we still have the same smbclient version. - ;; Otherwise, we must delete the connection cache, because - ;; capabilities might have changed. - (unless (or argument (processp p)) - (let ((default-directory tramp-compat-temporary-file-directory) - (command (concat tramp-smb-program " -V"))) + (let* ((user (tramp-file-name-user vec)) + (host (tramp-file-name-host vec)) + (domain (tramp-file-name-domain vec)) + (port (tramp-file-name-port vec)) + (options tramp-smb-options) + args) - (unless tramp-smb-version - (unless (executable-find tramp-smb-program) - (tramp-error - vec 'file-error - "Cannot find command %s in %s" tramp-smb-program exec-path)) - (setq tramp-smb-version (shell-command-to-string command)) - (tramp-message vec 6 command) - (tramp-message vec 6 "\n%s" tramp-smb-version) - (if (string-match (rx (+ (any " \t\r\n")) eos) tramp-smb-version) - (setq tramp-smb-version - (replace-match "" nil nil tramp-smb-version)))) - - (unless (string-equal - tramp-smb-version - (tramp-get-connection-property - vec "smbclient-version" tramp-smb-version)) - (tramp-flush-directory-properties vec "/") - (tramp-flush-connection-properties vec)) - - (tramp-set-connection-property - vec "smbclient-version" tramp-smb-version))) - - ;; If too much time has passed since last command was sent, look - ;; whether there has been an error message; maybe due to - ;; connection timeout. - (with-current-buffer buf - (goto-char (point-min)) - (when (and (time-less-p - 60 (time-since - (tramp-get-connection-property p "last-cmd-time" 0))) - (process-live-p p) - (re-search-forward tramp-smb-errors nil t)) - (delete-process p) - (setq p nil))) - - ;; Check whether it is still the same share. - (unless (and (process-live-p p) - (or argument - (string-equal - share - (tramp-get-connection-property p "smb-share" "")))) - (save-match-data - ;; There might be unread output from checking for share names. - (when buf (with-current-buffer buf (erase-buffer))) - (when (and p (processp p)) (delete-process p)) - - (let* ((user (tramp-file-name-user vec)) - (host (tramp-file-name-host vec)) - (domain (tramp-file-name-domain vec)) - (port (tramp-file-name-port vec)) - (options tramp-smb-options) - args) - - (cond - (argument - (setq args (list (concat "//" host)))) - (share - (setq args (list (concat "//" host "/" share)))) - (t - (setq args (list "-g" "-L" host )))) + (cond + (argument (setq args (list (concat "//" host)))) + (share (setq args (list (concat "//" host "/" share)))) + (t (setq args (list "-g" "-L" host )))) - (if (tramp-string-empty-or-nil-p user) - (setq args (append args (list "-N"))) - (setq args (append args (list "-U" user)))) + (if (tramp-string-empty-or-nil-p user) + (setq args (append args (list "-N"))) + (setq args (append args (list "-U" user)))) - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (dolist (option options) - (setq args (append args (list "--option" option)))) - (when argument - (setq args (append args (list argument)))) - - ;; OK, let's go. - (with-tramp-progress-reporter - vec 3 - (format "Opening connection for //%s%s/%s" - (if (tramp-string-empty-or-nil-p user) - "" (concat user "@")) - host (or share "")) - - (let* (coding-system-for-read - (process-connection-type tramp-process-connection-type) - (p (let ((default-directory - tramp-compat-temporary-file-directory) - (process-environment - (cons (concat "TERM=" tramp-terminal-type) - process-environment))) - (apply #'start-process - (tramp-get-connection-name vec) - (tramp-get-connection-buffer vec) - (if argument - tramp-smb-winexe-program tramp-smb-program) - args)))) - (tramp-post-process-creation p vec) - - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec) - - (condition-case err - (let ((inhibit-message t)) - ;; Play login scenario. - (tramp-process-actions - p vec nil - (if (or argument share) - tramp-smb-actions-with-share - tramp-smb-actions-without-share)) - - ;; Set chunksize to 1. smbclient reads its input - ;; character by character; if we send the string - ;; at once, it is read painfully slow. - (tramp-set-connection-property p "smb-share" share) - (tramp-set-connection-property p "chunksize" 1) - - ;; Mark it as connected. - (tramp-set-connection-property p "connected" t)) - - ;; Check for the error reason. If it was due to wrong - ;; password, reestablish the connection. We cannot - ;; handle this in `tramp-process-actions', because - ;; smbclient does not ask for the password, again. - (error - (with-current-buffer (tramp-get-connection-buffer vec) - (goto-char (point-min)) - (if (and (bound-and-true-p auth-sources) - (search-forward-regexp - tramp-smb-wrong-passwd-regexp nil t)) - ;; Disable `auth-source' and `password-cache'. - (let (auth-sources) - (tramp-message - vec 3 "Retry connection with new password") - (tramp-cleanup-connection vec t) - (tramp-smb-maybe-open-connection vec argument)) - ;; Propagate the error. - (signal (car err) (cdr err))))))))))))) + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (dolist (option options) + (setq args (append args (list "--option" option)))) + (when argument + (setq args (append args (list argument)))) + + ;; OK, let's go. + (with-tramp-progress-reporter + vec 3 + (format "Opening connection for //%s%s/%s" + (if (tramp-string-empty-or-nil-p user) + "" (concat user "@")) + host (or share "")) + + (let* (coding-system-for-read + (process-connection-type tramp-process-connection-type) + (p (let ((default-directory + tramp-compat-temporary-file-directory) + (process-environment + (cons (concat "TERM=" tramp-terminal-type) + process-environment))) + (apply #'start-process + (tramp-get-connection-name vec) + (tramp-get-connection-buffer vec) + (if argument + tramp-smb-winexe-program tramp-smb-program) + args)))) + (tramp-post-process-creation p vec) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec) + + (condition-case err + (let ((inhibit-message t)) + ;; Play login scenario. + (tramp-process-actions + p vec nil + (if (or argument share) + tramp-smb-actions-with-share + tramp-smb-actions-without-share)) + + ;; Set chunksize to 1. smbclient reads its + ;; input character by character; if we send the + ;; string at once, it is read painfully slow. + (tramp-set-connection-property p "smb-share" share) + (tramp-set-connection-property p "chunksize" 1) + + ;; Mark it as connected. + (tramp-set-connection-property p "connected" t)) + + ;; Check for the error reason. If it was due to + ;; wrong password, reestablish the connection. We + ;; cannot handle this in `tramp-process-actions', + ;; because smbclient does not ask for the password, + ;; again. + (error + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-min)) + (if (and (bound-and-true-p auth-sources) + (search-forward-regexp + tramp-smb-wrong-passwd-regexp nil t)) + ;; Disable `auth-source' and `password-cache'. + (let (auth-sources) + (tramp-message + vec 3 "Retry connection with new password") + (tramp-cleanup-connection vec t) + (tramp-smb-maybe-open-connection vec argument)) + ;; Propagate the error. + (signal (car err) (cdr err)))))))))))))) ;; We don't use timeouts. If needed, the caller shall wrap around. (defun tramp-smb-wait-for-output (vec) @@ -2003,21 +2004,21 @@ Removes smb prompt. Returns nil if an error message has appeared." (inhibit-read-only t)) ;; Read pending output. - (while (not (re-search-forward tramp-smb-prompt nil t)) + (while (not (search-forward-regexp tramp-smb-prompt nil t)) (while (tramp-accept-process-output p)) (goto-char (point-min))) (tramp-message vec 6 "\n%s" (buffer-string)) ;; Remove prompt. (goto-char (point-min)) - (when (re-search-forward tramp-smb-prompt nil t) + (when (search-forward-regexp tramp-smb-prompt nil t) (goto-char (point-max)) - (re-search-backward tramp-smb-prompt nil t) + (search-backward-regexp tramp-smb-prompt nil t) (delete-region (point) (point-max))) ;; Return value is whether no error message has appeared. (goto-char (point-min)) - (not (re-search-forward tramp-smb-errors nil t))))) + (not (search-forward-regexp tramp-smb-errors nil t))))) (defun tramp-smb-kill-winexe-function () "Send SIGKILL to the winexe process." diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index e3c9e0b53b2..86cf63507c6 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -181,8 +181,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist))) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (tramp--with-startup @@ -393,52 +395,53 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - ;; We need a process bound to the connection buffer. Therefore, we - ;; create a dummy process. Maybe there is a better solution? - (unless (get-buffer-process (tramp-get-connection-buffer vec)) - (let ((p (make-network-process - :name (tramp-get-connection-name vec) - :buffer (tramp-get-connection-buffer vec) - :server t :host 'local :service t :noquery t))) - (tramp-post-process-creation p vec) - - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec))) - - ;; Create directory. - (unless (file-directory-p (tramp-fuse-mount-point vec)) - (make-directory (tramp-fuse-mount-point vec) 'parents)) - - (unless - (or (tramp-fuse-mounted-p vec) - (with-temp-buffer - (zerop - (apply - #'tramp-call-process - vec tramp-sshfs-program nil t nil - (tramp-fuse-mount-spec vec) - (tramp-fuse-mount-point vec) - (tramp-expand-args - vec 'tramp-mount-args - ?p (or (tramp-file-name-port vec) "")))))) - (tramp-error - vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))) - - ;; Mark it as connected. - (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec)) - (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (with-tramp-connection-property - vec "uid-integer" (tramp-get-local-uid 'integer)) - (with-tramp-connection-property - vec "gid-integer" (tramp-get-local-gid 'integer)) - (with-tramp-connection-property - vec "uid-string" (tramp-get-local-uid 'string)) - (with-tramp-connection-property - vec "gid-string" (tramp-get-local-gid 'string))) + (with-tramp-debug-message vec "Opening connection" + ;; We need a process bound to the connection buffer. Therefore, + ;; we create a dummy process. Maybe there is a better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (tramp-post-process-creation p vec) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec))) + + ;; Create directory. + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) + + (unless + (or (tramp-fuse-mounted-p vec) + (with-temp-buffer + (zerop + (apply + #'tramp-call-process + vec tramp-sshfs-program nil t nil + (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-expand-args + vec 'tramp-mount-args + ?p (or (tramp-file-name-port vec) "")))))) + (tramp-error + vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))) + + ;; Mark it as connected. + (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec)) + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string)))) ;; `shell-mode' tries to open remote files like "/sshfs:user@host:~/.history". ;; This fails, because the tilde cannot be expanded. Tell diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index e41a4a590e2..2bbe0945330 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -170,8 +170,10 @@ See `tramp-actions-before-shell' for more info.") First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) ;;;###tramp-autoload (tramp--with-startup @@ -524,7 +526,7 @@ the result will be a local, non-Tramp, file name." v "ls" "-d" "-Z" (file-name-unquote localname))) (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) - (when (re-search-forward regexp (line-end-position) t) + (when (search-forward-regexp regexp (line-end-position) t) (setq context (list (match-string 1) (match-string 2) (match-string 3) (match-string 4)))))) ;; Return the context. @@ -714,20 +716,21 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - ;; We need a process bound to the connection buffer. Therefore, we - ;; create a dummy process. Maybe there is a better solution? - (unless (tramp-get-connection-process vec) - (let ((p (make-network-process - :name (tramp-get-connection-name vec) - :buffer (tramp-get-connection-buffer vec) - :server t :host 'local :service t :noquery t))) - (tramp-post-process-creation p vec) + (with-tramp-debug-message vec "Opening connection" + ;; We need a process bound to the connection buffer. Therefore, + ;; we create a dummy process. Maybe there is a better solution? + (unless (tramp-get-connection-process vec) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (tramp-post-process-creation p vec) - ;; Set connection-local variables. - (tramp-set-connection-local-variables vec) + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec) - ;; Mark it as connected. - (tramp-set-connection-property p "connected" t)))) + ;; Mark it as connected. + (tramp-set-connection-property p "connected" t))))) (defun tramp-sudoedit-send-command (vec &rest args) "Send commands ARGS to connection VEC. @@ -785,7 +788,7 @@ In case there is no valid Lisp expression, it raises an error." (condition-case nil (prog1 (read (current-buffer)) ;; Error handling. - (when (re-search-forward (rx (not blank)) (line-end-position) t) + (when (search-forward-regexp (rx (not blank)) (line-end-position) t) (error nil))) (error (tramp-error vec 'file-error diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 8b574c4ce93..1de0e84c3db 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -55,6 +55,7 @@ ;;; Code: (require 'tramp-compat) +(require 'tramp-message) (require 'tramp-integration) (require 'trampver) @@ -92,8 +93,8 @@ "Edit remote files with a combination of ssh, scp, etc." :group 'files :group 'comm - :link '(custom-manual "(tramp)Top") - :version "22.1") + :version "22.1" + :link '(custom-manual "(tramp)Top")) ;;;###tramp-autoload (progn @@ -115,32 +116,6 @@ If it is set to nil, all remote file names are used literally." :type 'boolean) -;;;###tramp-autoload -(defcustom tramp-verbose 3 - "Verbosity level for Tramp messages. -Any level x includes messages for all levels 1 .. x-1. The levels are - - 0 silent (no tramp messages at all) - 1 errors - 2 warnings - 3 connection to remote hosts (default level) - 4 activities - 5 internal - 6 sent and received strings - 7 connection properties - 8 file caching - 9 test commands -10 traces (huge) -11 call traces (maintainer only)." - :type 'integer) - -(defcustom tramp-debug-to-file nil - "Whether Tramp debug messages shall be saved to file. -The debug file has the same name as the debug buffer, written to -`tramp-compat-temporary-file-directory'." - :version "28.1" - :type 'boolean) - (defcustom tramp-backup-directory-alist nil "Alist of filename patterns and backup directory names. Each element looks like (REGEXP . DIRECTORY), with the same meaning like @@ -1267,7 +1242,7 @@ checked via the following code: (process-send-eof proc) (process-send-eof proc)) (while (not (progn (goto-char (point-min)) - (re-search-forward \"\\\\w+\" (point-max) t))) + (search-forward-regexp \"\\\\w+\" (point-max) t))) (accept-process-output proc 1)) (when (process-live-p proc) (setq received (string-to-number (match-string 0))) @@ -1397,12 +1372,12 @@ The TERM environment variable should be set via `tramp-terminal-type'. The INSIDE_EMACS environment variable will automatically be set based on the Tramp and Emacs versions, and should not be set here." - :group 'tramp :version "26.1" :type '(repeat string)) ;;; Internal Variables: +;;;###tramp-autoload (defvar tramp-current-connection nil "Last connection timestamp. It is a cons cell of the actual `tramp-file-name-structure', and @@ -1473,6 +1448,7 @@ calling HANDLER.") (make-tramp-file-name :user (user-login-name) :host tramp-system-name) "Connection hop which identifies the virtual hop before the first one.") +;;;###tramp-autoload (defun tramp-file-name-user-domain (vec) "Return user and domain components of VEC." (when (or (tramp-file-name-user vec) (tramp-file-name-domain vec)) @@ -1483,6 +1459,7 @@ calling HANDLER.") (put #'tramp-file-name-user-domain 'tramp-suppress-trace t) +;;;###tramp-autoload (defun tramp-file-name-host-port (vec) "Return host and port components of VEC." (when (or (tramp-file-name-host vec) (tramp-file-name-port vec)) @@ -1955,371 +1932,6 @@ of `current-buffer'." buffer (current-buffer)) (substring-no-properties (buffer-string)))) -(defun tramp-debug-buffer-name (vec) - "A name for the debug buffer for VEC." - (let ((method (tramp-file-name-method vec)) - (user-domain (tramp-file-name-user-domain vec)) - (host-port (tramp-file-name-host-port vec))) - (if (tramp-string-empty-or-nil-p user-domain) - (format "*debug tramp/%s %s*" method host-port) - (format "*debug tramp/%s %s@%s*" method user-domain host-port)))) - -(put #'tramp-debug-buffer-name 'tramp-suppress-trace t) - -(defconst tramp-debug-outline-regexp - (rx ;; Timestamp. - (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) blank - ;; Thread. - (? (group "#") blank) - ;; Function name, verbosity. - (+ (any "-" alnum)) " (" (group (+ digit)) ") #") - "Used for highlighting Tramp debug buffers in `outline-mode'.") - -(defconst tramp-debug-font-lock-keywords - ;; FIXME: Make it a function instead of an ELisp expression, so you - ;; can evaluate it with `funcall' rather than `eval'! - ;; Also, in `font-lock-defaults' you can specify a function name for - ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords! - '(list - (rx bol (regexp tramp-debug-outline-regexp) (+ nonl)) - '(1 font-lock-warning-face t t) - '(0 (outline-font-lock-face) keep t)) - "Used for highlighting Tramp debug buffers in `outline-mode'.") - -(defun tramp-debug-outline-level () - "Return the depth to which a statement is nested in the outline. -Point must be at the beginning of a header line. - -The outline level is equal to the verbosity of the Tramp message." - (1+ (string-to-number (match-string 2)))) - -(put #'tramp-debug-outline-level 'tramp-suppress-trace t) - -;; This function takes action since Emacs 28.1, when -;; `read-extended-command-predicate' is set to -;; `command-completion-default-include-p'. -(defun tramp-debug-buffer-command-completion-p (_symbol buffer) - "A predicate for Tramp interactive commands. -They are completed by \"M-x TAB\" only in Tramp debug buffers." - (with-current-buffer buffer - (string-equal - (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) - ";; Emacs:"))) - -(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) - -(defun tramp-setup-debug-buffer () - "Function to setup debug buffers." - ;; (declare (completion tramp-debug-buffer-command-completion-p)) - (interactive) - (set-buffer-file-coding-system 'utf-8) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes die. - ;; Yes: I've seen `flyspell-mode', which starts "ispell". - ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises - ;; on error in `(outline-mode)', we don't want to see it in the - ;; traces. - (let ((default-directory tramp-compat-temporary-file-directory)) - (outline-mode)) - (setq-local outline-level 'tramp-debug-outline-level) - (setq-local font-lock-keywords - ;; FIXME: This `(t FOO . BAR)' representation in - ;; `font-lock-keywords' is supposed to be an internal - ;; implementation "detail". Don't abuse it here! - `(t (eval ,tramp-debug-font-lock-keywords t) - ,(eval tramp-debug-font-lock-keywords t))) - ;; Do not edit the debug buffer. - (use-local-map special-mode-map) - (set-buffer-modified-p nil) - ;; For debugging purposes. - (local-set-key "\M-n" 'clone-buffer) - (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) - -(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) - -(function-put - #'tramp-setup-debug-buffer 'completion-predicate - #'tramp-debug-buffer-command-completion-p) - -(defun tramp-get-debug-buffer (vec) - "Get the debug buffer for VEC." - (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) - (when (bobp) - (tramp-setup-debug-buffer)) - (current-buffer))) - -(put #'tramp-get-debug-buffer 'tramp-suppress-trace t) - -(defun tramp-get-debug-file-name (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 traced with `tramp-verbose' > 10.") - -;;;###tramp-autoload -(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 -ARGUMENTS to actually emit the message (if applicable)." - (let ((inhibit-message t) - create-lockfiles file-name-handler-alist message-log-max - signal-hook-function) - (with-current-buffer (tramp-get-debug-buffer vec) - (goto-char (point-max)) - (let ((point (point))) - (when (bobp) - ;; Headline. - (insert - (format - ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-" - emacs-version tramp-version)) - (when (>= tramp-verbose 10) - (let ((tramp-verbose 0)) - (insert - (format - "\n;; Location: %s Git: %s/%s" - (locate-library "tramp") - (or tramp-repository-branch "") - (or tramp-repository-version ""))))) - ;; Traces. - (when (>= tramp-verbose 11) - (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))))) - (unless (bolp) - (insert "\n")) - ;; Timestamp. - (insert (format-time-string "%T.%6N ")) - ;; Threads. `current-thread' might not exist when Emacs is - ;; configured --without-threads. - ;; (unless (eq (tramp-compat-funcall 'current-thread) main-thread) - ;; (insert (format "%s " (tramp-compat-funcall 'current-thread)))) - ;; Calling Tramp function. We suppress compat and trace - ;; functions from being displayed. - (let ((frames (backtrace-frames)) - btf fn) - (while (not fn) - (setq btf (cadadr frames)) - (if (not btf) - (setq fn "") - (and (symbolp btf) (setq fn (symbol-name btf)) - (or (not (string-prefix-p "tramp" fn)) - (get btf 'tramp-suppress-trace)) - (setq fn nil)) - (setq frames (cdr frames)))) - ;; The following code inserts filename and line number. - ;; Should be inactive by default, because it is time consuming. - ;; (let ((ffn (find-function-noselect (intern fn)))) - ;; (insert - ;; (format - ;; "%s:%d: " - ;; (file-name-nondirectory (buffer-file-name (car ffn))) - ;; (with-current-buffer (car ffn) - ;; (1+ (count-lines (point-min) (cdr ffn))))))) - (insert (format "%s " fn))) - ;; The message. - (insert (apply #'format-message fmt-string arguments)) - ;; Write message to debug file. - (when tramp-debug-to-file - (ignore-errors - (write-region - point (point-max) (tramp-get-debug-file-name vec) 'append))))))) - -(put #'tramp-debug-message 'tramp-suppress-trace t) - -;;;###tramp-autoload -(defvar tramp-inhibit-progress-reporter nil - "Show Tramp progress reporter in the minibuffer. -This variable is used to disable concurrent progress reporter messages.") - -;;;###tramp-autoload -(defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) - "Emit a message depending on verbosity level. -VEC-OR-PROC identifies the Tramp buffer to use. It can be either a -vector or a process. LEVEL says to be quiet if `tramp-verbose' is -less than LEVEL. The message is emitted only if `tramp-verbose' is -greater than or equal to LEVEL. - -The message is also logged into the debug buffer when `tramp-verbose' -is greater than or equal 4. - -Calls functions `message' and `tramp-debug-message' with FMT-STRING as -control string and the remaining ARGUMENTS to actually emit the message (if -applicable)." - (ignore-errors - (when (<= level tramp-verbose) - ;; Display only when there is a minimum level, and the progress - ;; reporter doesn't suppress further messages. - (when (and (<= level 3) (null tramp-inhibit-progress-reporter)) - (apply #'message - (concat - (cond - ((= level 0) "") - ((= level 1) "") - ((= level 2) "Warning: ") - (t "Tramp: ")) - fmt-string) - arguments)) - ;; Log only when there is a minimum level. - (when (>= tramp-verbose 4) - (let ((tramp-verbose 0)) - ;; Append connection buffer for error messages, if exists. - (when (= level 1) - (ignore-errors - (setq fmt-string (concat fmt-string "\n%s") - arguments - (append - arguments - `(,(tramp-get-buffer-string - (if (processp vec-or-proc) - (process-buffer vec-or-proc) - (tramp-get-connection-buffer - vec-or-proc 'dont-create)))))))) - ;; Translate proc to vec. - (when (processp vec-or-proc) - (setq vec-or-proc (process-get vec-or-proc 'tramp-vector)))) - ;; Do it. - (when (tramp-file-name-p vec-or-proc) - (apply #'tramp-debug-message - vec-or-proc - (concat (format "(%d) # " level) fmt-string) - arguments)))))) - -(defsubst tramp-backtrace (&optional vec-or-proc force) - "Dump a backtrace into the debug buffer. -If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE -forces the backtrace even if `tramp-verbose' is less than 10. -This function is meant for debugging purposes." - (let ((tramp-verbose (if force 10 tramp-verbose))) - (when (>= tramp-verbose 10) - (if vec-or-proc - (tramp-message - vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) - (with-output-to-temp-buffer "*debug tramp*" (backtrace)))))) - -(defun tramp-error (vec-or-proc signal fmt-string &rest arguments) - "Emit an error. -VEC-OR-PROC identifies the connection to use, SIGNAL is the -signal identifier to be raised, remaining arguments passed to -`tramp-message'. Finally, signal SIGNAL is raised with -FMT-STRING and ARGUMENTS." - (let (signal-hook-function) - (tramp-backtrace vec-or-proc) - (unless arguments - ;; FMT-STRING could be just a file name, as in - ;; `file-already-exists' errors. It could contain the ?\% - ;; character, as in smb domain spec. - (setq arguments (list fmt-string) - fmt-string "%s")) - (when vec-or-proc - (tramp-message - vec-or-proc 1 "%s" - (error-message-string - (list signal - (get signal 'error-message) - (apply #'format-message fmt-string arguments))))) - (signal signal (list (substring-no-properties - (apply #'format-message fmt-string arguments)))))) - -(put #'tramp-error 'tramp-suppress-trace t) - -(defvar tramp-error-show-message-timeout 30 - "Time to show the Tramp buffer in case of an error. -If it is bound to nil, the buffer is not shown. This is used in -tramp-tests.el.") - -(defsubst tramp-error-with-buffer - (buf vec-or-proc signal fmt-string &rest arguments) - "Emit an error, and show BUF. -If BUF is nil, show the connection buf. Wait for 30\", or until -an input event arrives. The other arguments are passed to `tramp-error'." - (save-window-excursion - (let* ((buf (or (and (bufferp buf) buf) - (and (processp vec-or-proc) (process-buffer vec-or-proc)) - (and (tramp-file-name-p vec-or-proc) - (tramp-get-connection-buffer vec-or-proc)))) - (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc) - (and buf (tramp-dissect-file-name - (tramp-get-default-directory buf)))))) - (unwind-protect - (apply #'tramp-error vec-or-proc signal fmt-string arguments) - ;; Save exit. - (when (and buf - (natnump tramp-error-show-message-timeout) - (not (zerop tramp-verbose)) - ;; Do not show when flagged from outside. - (not non-essential) - ;; Show only when Emacs has started already. - (current-message)) - (let ((enable-recursive-minibuffers t) - inhibit-message) - ;; `tramp-error' does not show messages. So we must do it - ;; ourselves. - (apply #'message fmt-string arguments) - ;; Show buffer. - (pop-to-buffer buf) - (discard-input) - (sit-for tramp-error-show-message-timeout))) - ;; Reset timestamp. It would be wrong after waiting for a while. - (when (tramp-file-name-equal-p vec (car tramp-current-connection)) - (setcdr tramp-current-connection (current-time))))))) - -;; We must make it a defun, because it is used earlier already. -(defun tramp-user-error (vec-or-proc fmt-string &rest arguments) - "Signal a user error (or \"pilot error\")." - (unwind-protect - (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) - ;; Save exit. - (when (and (natnump tramp-error-show-message-timeout) - (not (zerop tramp-verbose)) - ;; Do not show when flagged from outside. - (not non-essential) - ;; Show only when Emacs has started already. - (current-message)) - (let ((enable-recursive-minibuffers t) - inhibit-message) - ;; `tramp-error' does not show messages. So we must do it ourselves. - (apply #'message fmt-string arguments) - (discard-input) - (sit-for tramp-error-show-message-timeout) - ;; Reset timestamp. It would be wrong after waiting for a while. - (when - (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) - (setcdr tramp-current-connection (current-time))))))) - -(put #'tramp-user-error 'tramp-suppress-trace t) - -(defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) - "Execute BODY while redirecting the error message to `tramp-message'. -BODY is executed like wrapped by `with-demoted-errors'. FORMAT -is a format-string containing a %-sequence meaning to substitute -the resulting error message." - (declare (indent 2) (debug (symbolp form body))) - (let ((err (make-symbol "err"))) - `(condition-case-unless-debug ,err - (progn ,@body) - (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) - ;; This macro shall optimize the cases where a `file-exists-p' call is ;; invoked first. Often, the file exists, so the remote command is ;; superfluous. @@ -2402,6 +2014,11 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (when (tramp-compat-string-search message (or (current-message) "")) (progress-reporter-update reporter value suffix)))) +;;;###tramp-autoload +(defvar tramp-inhibit-progress-reporter nil + "Show Tramp progress reporter in the minibuffer. +This variable is used to disable concurrent progress reporter messages.") + (defmacro with-tramp-progress-reporter (vec level message &rest body) "Execute BODY, spinning a progress reporter with MESSAGE in interactive mode. If LEVEL does not fit for visible messages, there are only traces @@ -2762,22 +2379,20 @@ Fall back to normal file name handler if no Tramp file name handler exists." tramp-compat-temporary-file-directory) file-name-handler-alist) (autoload-do-load sf foreign))) - ;; (tramp-message - ;; v 4 "Running `%s'..." (cons operation args)) - ;; If `non-essential' is non-nil, Tramp shall - ;; not open a new connection. - ;; If Tramp detects that it shouldn't continue - ;; to work, it throws the `suppress' event. - ;; This could happen for example, when Tramp - ;; tries to open the same connection twice in - ;; a short time frame. - ;; In both cases, we try the default handler then. - (setq result - (catch 'non-essential - (catch 'suppress - (apply foreign operation args)))) - ;; (tramp-message - ;; v 4 "Running `%s'...`%s'" (cons operation args) result) + (with-tramp-debug-message + v (format "Running `%S'" (cons operation args)) + ;; If `non-essential' is non-nil, Tramp shall + ;; not open a new connection. + ;; If Tramp detects that it shouldn't continue + ;; to work, it throws the `suppress' event. + ;; This could happen for example, when Tramp + ;; tries to open the same connection twice in + ;; a short time frame. + ;; In both cases, we try the default handler then. + (setq result + (catch 'non-essential + (catch 'suppress + (apply foreign operation args))))) (cond ((eq result 'non-essential) (tramp-message @@ -3378,7 +2993,7 @@ for all methods. Resulting data are derived from default settings." "Return a (user host) tuple allowed to access. User is always nil." (let (result) - (when (re-search-forward regexp (line-end-position) t) + (when (search-forward-regexp regexp (line-end-position) t) (setq result (list nil (match-string match-level)))) (or (> (skip-chars-forward skip-chars) 0) @@ -3411,7 +3026,7 @@ Either user or host may be nil." (rx bol (group (regexp tramp-host-regexp)) (? (+ blank) (group (regexp tramp-user-regexp)))))) - (when (re-search-forward regexp (line-end-position) t) + (when (search-forward-regexp regexp (line-end-position) t) (setq result (append (list (match-string 2) (match-string 1))))) (forward-line 1) result)) @@ -3499,7 +3114,7 @@ Host is always \"localhost\"." Host is always \"localhost\"." (let (result (regexp (rx bol (group (regexp tramp-user-regexp)) ":"))) - (when (re-search-forward regexp (line-end-position) t) + (when (search-forward-regexp regexp (line-end-position) t) (setq result (list (match-string 1) "localhost"))) (forward-line 1) result)) @@ -3556,7 +3171,7 @@ User is always nil." User is always nil." (let (result (regexp (rx (literal registry) "\\" (group (+ nonl))))) - (when (re-search-forward regexp (line-end-position) t) + (when (search-forward-regexp regexp (line-end-position) t) (setq result (list nil (match-string 1)))) (forward-line 1) result)) @@ -5053,7 +4668,8 @@ a connection-local variable." (process-put proc 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag proc nil) (tramp-taint-remote-process-buffer (process-buffer proc)) - (tramp-message vec 6 "%s" (string-join (process-command proc) " "))) + (when (process-command proc) + (tramp-message vec 6 "%s" (string-join (process-command proc) " ")))) (put #'tramp-post-process-creation 'tramp-suppress-trace t) @@ -5240,25 +4856,25 @@ support symbolic links." ((zerop (process-file "cat" nil '(t) nil "/proc/meminfo")) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "MemTotal:" (* space) (group (+ digit)) (* space) "kB" eol) nil 'noerror) (setcar (nthcdr 0 result) (string-to-number (match-string 1)))) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "MemFree:" (* space) (group (+ digit)) (* space) "kB" eol) nil 'noerror) (setcar (nthcdr 1 result) (string-to-number (match-string 1)))) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "SwapTotal:" (* space) (group (+ digit)) (* space) "kB" eol) nil 'noerror) (setcar (nthcdr 2 result) (string-to-number (match-string 1)))) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "SwapFree:" (* space) (group (+ digit)) (* space) "kB" eol) nil 'noerror) (setcar (nthcdr 3 result) (string-to-number (match-string 1))))) @@ -5268,13 +4884,13 @@ support symbolic links." ((zerop (process-file "sysctl" nil '(t) nil "-a")) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "hw.pagesize:" (* space) (group (+ digit)) eol) nil 'noerror) (let ((pagesize (string-to-number (match-string 1)))) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "vm.stats.vm.v_page_count:" (* space) (group (+ digit)) eol) nil 'noerror) @@ -5283,7 +4899,7 @@ support symbolic links." (/ (* (string-to-number (match-string 1)) pagesize) 1024))) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "vm.stats.vm.v_free_count:" (* space) (group (+ digit)) eol) nil 'noerror) @@ -5294,7 +4910,7 @@ support symbolic links." (when (zerop (process-file "swapctl" nil '(t) nil "-sk")) (goto-char (point-min)) (when - (re-search-forward + (search-forward-regexp (rx bol "Total:" (* space) (group (+ digit)) (* space) (group (+ digit)) eol) nil 'noerror) @@ -5785,7 +5401,7 @@ Wait, until the connection buffer changes." ;; This can be ignored. (with-current-buffer (process-buffer proc) (goto-char (point-min)) - (if (re-search-forward tramp-operation-not-permitted-regexp nil t) + (if (search-forward-regexp tramp-operation-not-permitted-regexp nil t) (progn (tramp-message vec 5 "'set mode' error ignored.") (tramp-message vec 3 "Process has finished.") @@ -5808,7 +5424,7 @@ See `tramp-process-actions' for the format of ACTIONS." ;; Remove ANSI control escape sequences. (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp ansi-color-control-seq-regexp nil t) (replace-match ""))) (setq todo actions) (while todo @@ -5963,7 +5579,7 @@ Otherwise, return nil." ;; We restrict ourselves to the last 256 characters. There were ;; reports of a shell command "git ls-files -zco --exclude-standard" ;; with 85k files involved, which has blocked Tramp forever. - (re-search-backward regexp (max (point-min) (- (point) 256)) 'noerror)) + (search-backward-regexp regexp (max (point-min) (- (point) 256)) 'noerror)) (defun tramp-check-for-regexp (proc regexp) "Check, whether REGEXP is contained in process buffer of PROC. @@ -5975,12 +5591,12 @@ Erase echoed commands if exists." ;; the echo mark regexp is taken for search. We restrict the ;; search for the second echo mark to PIPE_BUF characters. (when (and (tramp-get-connection-property proc "check-remote-echo") - (re-search-forward + (search-forward-regexp tramp-echoed-echo-mark-regexp (+ (point) (* 5 tramp-echo-mark-marker-length)) t)) (let ((begin (match-beginning 0))) (when - (re-search-forward + (search-forward-regexp tramp-echoed-echo-mark-regexp (+ (point) (tramp-get-connection-property proc "pipe-buf" 4096)) t) ;; Discard echo from remote output. @@ -6492,19 +6108,19 @@ Set connection properties \"{uid,gid,groups}-{integer,string}\"." groups-integer groups-string) (goto-char (point-min)) ;; Read uid. - (when (re-search-forward + (when (search-forward-regexp (rx "uid=" (group (+ digit)) "(" (group (+ (any "_" word))) ")") nil 'noerror) (setq uid-integer (string-to-number (match-string 1)) uid-string (match-string 2))) ;; Read gid. - (when (re-search-forward + (when (search-forward-regexp (rx "gid=" (group (+ digit)) "(" (group (+ (any "_" word))) ")") nil 'noerror) (setq gid-integer (string-to-number (match-string 1)) gid-string (match-string 2))) ;; Read groups. - (when (re-search-forward (rx "groups=") nil 'noerror) + (when (search-forward-regexp (rx "groups=") nil 'noerror) (while (looking-at (rx (group (+ digit)) "(" (group (+ (any "_" word))) ")")) (setq groups-integer (cons (string-to-number (match-string 1)) diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index ad7bf94cdcd..4d56cf367e3 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -47,6 +47,7 @@ (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") +;;;###tramp-autoload (defconst tramp-repository-branch (ignore-errors ;; Suppress message from `emacs-repository-get-branch'. We must @@ -60,6 +61,7 @@ (emacs-repository-get-branch dir)))) "The repository branch of the Tramp sources.") +;;;###tramp-autoload (defconst tramp-repository-version (ignore-errors ;; Suppress message from `emacs-repository-get-version'. We must diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 9bc8ad8ce39..ee9c09df9d8 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -263,7 +263,6 @@ 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 (tramp-trace-buffer-name tramp-test-vec)) (debug-ignored-errors (append '("^make-symbolic-link not supported$" @@ -3502,14 +3501,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "tramp-test*" ert-remote-temporary-file-directory))) (goto-char (point-min)) (should - (re-search-forward + (search-forward-regexp (rx (literal (file-relative-name tmp-name1 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should - (re-search-forward + (search-forward-regexp (rx (literal (file-relative-name @@ -3524,14 +3523,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "tramp-test*/*" ert-remote-temporary-file-directory))) (goto-char (point-min)) (should - (re-search-forward + (search-forward-regexp (rx (literal (file-relative-name tmp-name3 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should - (re-search-forward + (search-forward-regexp (rx (literal (file-relative-name @@ -3554,14 +3553,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "tramp-test*/*" ert-remote-temporary-file-directory))) (goto-char (point-min)) (should - (re-search-forward + (search-forward-regexp (rx (literal (file-relative-name tmp-name3 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should - (re-search-forward + (search-forward-regexp (rx (literal (file-relative-name @@ -4980,10 +4979,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; We must remove leading `default-directory'. (goto-char (point-min)) (let ((inhibit-read-only t)) - (while (re-search-forward "//" nil 'noerror) + (while (search-forward-regexp "//" nil 'noerror) (delete-region (line-beginning-position) (point)))) (goto-char (point-min)) - (re-search-forward + (search-forward-regexp (rx bol (0+ nonl) (any "Pp") "ossible completions" (0+ nonl) eol)) @@ -5095,7 +5094,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if (bufferp destination) destination (current-buffer)) ;; "ls" could produce colorized output. (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp + ansi-color-control-seq-regexp nil t) (replace-match "" nil nil)) (should (string-equal (if destination (format "%s\n" fnnd) "") @@ -5109,7 +5109,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if (bufferp destination) destination (current-buffer)) ;; "ls" could produce colorized output. (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp + ansi-color-control-seq-regexp nil t) (replace-match "" nil nil)) (should (string-equal @@ -5823,7 +5824,7 @@ INPUT, if non-nil, is a string sent to the process." (current-buffer)) ;; "ls" could produce colorized output. (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp ansi-color-control-seq-regexp nil t) (replace-match "" nil nil)) (should (string-equal @@ -7374,7 +7375,7 @@ This requires restrictions of file name syntax." (should (zerop (process-file "printenv" nil t nil))) (goto-char (point-min)) (should - (re-search-forward + (search-forward-regexp (rx bol (literal envvar) "=" (literal (getenv envvar)) eol))))))))