diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 6daa2b010cf..7bee92a94d5 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -6973,7 +6973,7 @@ If the same @var{function} shall be used for different @value{tramp} backends, @code{tramp-add-external-operation} must be called for every backend, respectively. -The optional argument @var{arg-type} specisfies, which argument of +The optional argument @var{arg-type} specifies, which argument of @var{operation} shall be used in order to determine, whether the handler @var{function} should be called. It can be @@ -6988,6 +6988,10 @@ checked. This is the default, if @var{arg-type} is @code{nil}. @item @code{process}@* @code{default-directory} of the process buffer of the first argument of @var{operation}, a process, is the remote file name to be checked. + +@item @code{tramp-file-name}@* +The @code{tramp-file-name} structure of the first argument of +@var{operation} is the remote file name to be checked. @end itemize If the first argument of @var{operation} is nil, @@ -7015,6 +7019,26 @@ The example above could be changed like this: @end lisp @end defun +@defun tramp-external-operation-p operation backend +This checks, whether @value{tramp}'s backend @var{backend} supports +external @var{operation}. It returns the function registered as +handler, or @code{nil}. Example: + +@lisp +@group +(tramp-external-operation-p + #'my-test-operation 'tramp-sh) +@result{} my-handle-test-operation +@end group + +@group +(tramp-external-operation-p + #'my-test-operation 'tramp-gvfs) +@result{} nil +@end group +@end lisp +@end defun + @defun tramp-remove-external-operation operation backend The handler for @var{operation}, added by @code{tramp-add-external-operation}, is removed from @var{backend}. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 75a8eb16621..87ec55def37 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2447,6 +2447,8 @@ symbol checked. - `process': `default-directory' of the process buffer of the first argument of OPERATION is the remote file name to be checked. +- `tramp-file-name': the first argument of OPERATION, a + `tramp-file-name' structure, is the remote file name to be checked. If the first argument of OPERATION is nil, `default-directory' is the remote file name to be checked in case of `file' and `process'. @@ -2500,8 +2502,10 @@ Must be handled by the callers." (if (and (stringp (nth 0 args)) (file-name-absolute-p (nth 0 args))) (nth 0 args) default-directory)) + ;; STRING FILE. ((eq operation 'make-symbolic-link) (nth 1 args)) + ;; FILE DIRECTORY resp FILE1 FILE2. ((memq operation '(add-name-to-file copy-directory copy-file @@ -2512,23 +2516,27 @@ Must be handled by the callers." ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) ((file-name-absolute-p (nth 1 args)) (nth 1 args)) (t default-directory))) + ;; FILE DIRECTORY resp FILE1 FILE2. ((eq operation 'expand-file-name) (cond ((file-name-absolute-p (nth 0 args)) (nth 0 args)) ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) (t default-directory))) + ;; START END FILE. ((eq operation 'write-region) (if (file-name-absolute-p (nth 2 args)) (nth 2 args) default-directory)) + ;; BUFFER. ((memq operation '(make-auto-save-file-name set-visited-file-modtime verify-visited-file-modtime)) (buffer-file-name (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) + ;; COMMAND. ((or (memq operation @@ -2541,6 +2549,7 @@ Must be handled by the callers." (eq (alist-get operation tramp-file-name-for-operation-external) 'default-directory)) default-directory) + ;; PROC or BUFFER. ((or (memq operation '(file-notify-rm-watch file-notify-valid-p)) @@ -2557,16 +2566,25 @@ Must be handled by the callers." (or (get-process (nth 0 args)) (get-buffer (nth 0 args))))))) (tramp-get-default-directory buf)) "")) + ;; VEC. - ((memq operation - '(tramp-get-home-directory tramp-get-remote-gid - tramp-get-remote-groups tramp-get-remote-uid)) - (tramp-make-tramp-file-name (nth 0 args))) + ((or + (memq operation + '(tramp-get-home-directory tramp-get-remote-gid + tramp-get-remote-groups tramp-get-remote-uid)) + (eq (alist-get operation tramp-file-name-for-operation-external) + 'tramp-file-name)) + (or + (and (tramp-file-name-p (nth 0 args)) + (tramp-make-tramp-file-name (nth 0 args))) + "")) + ;; A function. ((functionp (alist-get operation tramp-file-name-for-operation-external)) (apply (alist-get operation tramp-file-name-for-operation-external) operation args)) + ;; Unknown file primitive. (t (unless (memq 'remote-file-error debug-ignored-errors) (tramp-error @@ -2601,17 +2619,17 @@ OPERATION must not be one of the magic operations listed in Info node `(elisp) Magic File Names'. FUNCTION must have the same argument list as OPERATION. BACKEND, a symbol, must be one of the Tramp backend packages like `tramp-sh' (except `tramp-ftp'). ARG-TYPE is either -`file' (the default), `default-directory', `process' or a function -symbol. It describes the type of the OPERATION argument to be checked. -See the docstring of `tramp-file-name-for-operation-external' for its -meaning." +`file' (the default), `default-directory', `process', `tramp-file-name', +or a function symbol. It describes the type of the OPERATION argument +to be checked. See the docstring of +`tramp-file-name-for-operation-external' for its meaning." (require backend) (when-let* ((fnha (intern-soft (concat (symbol-name backend) "-file-name-handler-alist"))) ((boundp fnha)) (arg-type (or arg-type 'file))) - (unless (or (memq arg-type '(file default-directory process)) + (unless (or (memq arg-type '(file default-directory process tramp-file-name)) (functionp arg-type)) (tramp-error nil 'remote-file-error "Unknown arg type: %s" arg-type)) ;; Make BACKEND aware of the new operation. @@ -2635,6 +2653,15 @@ meaning." (apply orig-fun args))) `((name . ,(concat "tramp-advice-" (symbol-name operation)))))))) +(defun tramp-external-operation-p (operation backend) + "Check, whether Tramp BACKEND supports external OPERATION. +It returns the function registered as handler, or nil." + (and-let* ((fnha + (intern-soft + (concat (symbol-name backend) "-file-name-handler-alist"))) + ((boundp fnha)) + ((alist-get operation (symbol-value fnha)))))) + (defun tramp-remove-external-operation (operation backend) "Remove OPERATION from Tramp BACKEND as handler for OPERATION. OPERATION must not be one of the magic operations listed in Info @@ -4264,9 +4291,8 @@ Let-bind it when necessary.") (tramp-get-connection-property vec "~")))) (when home-dir (setq home-dir - (tramp-compat-funcall - 'directory-abbrev-apply - (tramp-make-tramp-file-name vec home-dir)))) + (tramp-compat-funcall 'directory-abbrev-apply + (tramp-make-tramp-file-name vec home-dir)))) ;; If any elt of `directory-abbrev-alist' matches this name, ;; abbreviate accordingly. (setq filename (tramp-compat-funcall 'directory-abbrev-apply filename)) @@ -4864,22 +4890,21 @@ existing) are returned." (setq remote-copy (tramp-make-tramp-temp-file v)) ;; This is defined in tramp-sh.el. Let's assume ;; this is loaded already. - (tramp-compat-funcall - 'tramp-send-command - v - (cond - ((and beg end) - (format "dd bs=1 skip=%d if=%s count=%d of=%s" - beg (tramp-shell-quote-argument localname) - (- end beg) remote-copy)) - (beg - (format "dd bs=1 skip=%d if=%s of=%s" - beg (tramp-shell-quote-argument localname) - remote-copy)) - (end - (format "dd bs=1 count=%d if=%s of=%s" - end (tramp-shell-quote-argument localname) - remote-copy)))) + (tramp-compat-funcall 'tramp-send-command + v + (cond + ((and beg end) + (format "dd bs=1 skip=%d if=%s count=%d of=%s" + beg (tramp-shell-quote-argument localname) + (- end beg) remote-copy)) + (beg + (format "dd bs=1 skip=%d if=%s of=%s" + beg (tramp-shell-quote-argument localname) + remote-copy)) + (end + (format "dd bs=1 count=%d if=%s of=%s" + end (tramp-shell-quote-argument localname) + remote-copy)))) (setq tramp-temp-buffer-file-name nil beg nil end nil)) ;; `insert-file-contents-literally' takes care to @@ -5565,12 +5590,10 @@ processes." (tramp-compat-make-temp-name)))) (options (when sh-file-name-handler-p - (tramp-compat-funcall - 'tramp-ssh-controlmaster-options v))) + (tramp-compat-funcall 'tramp-ssh-controlmaster-options v))) (device (when adb-file-name-handler-p - (tramp-compat-funcall - 'tramp-adb-get-device v))) + (tramp-compat-funcall 'tramp-adb-get-device v))) (pta (unless (eq connection-type 'pipe) "-t")) login-args p) @@ -7475,13 +7498,12 @@ name of a process or buffer, or nil to default to the current buffer." ;; This is for tramp-sh.el. Other backends do not support this (yet). ;; Not all "kill" implementations support process groups by ;; negative pid, so we try both variants. - (tramp-compat-funcall - 'tramp-send-command - (process-get proc 'tramp-vector) - (format "(\\kill -2 -%d || \\kill -2 %d) 2>%s" - pid pid - (tramp-get-remote-null-device - (process-get proc 'tramp-vector)))) + (tramp-compat-funcall 'tramp-send-command + (process-get proc 'tramp-vector) + (format "(\\kill -2 -%d || \\kill -2 %d) 2>%s" + pid pid + (tramp-get-remote-null-device + (process-get proc 'tramp-vector)))) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. (while (tramp-accept-process-output proc)) @@ -7531,9 +7553,8 @@ SIGCODE may be an integer, or a symbol whose name is a signal name." (tramp-message vec 5 "Send signal %s to process %s with pid %s" sigcode process pid) ;; This is for tramp-sh.el. Other backends do not support this (yet). - (if (tramp-compat-funcall - 'tramp-send-command-and-check - vec (format "\\kill -%s %d" sigcode pid)) + (if (tramp-compat-funcall 'tramp-send-command-and-check + vec (format "\\kill -%s %d" sigcode pid)) 0 -1)))) ;; `signal-process-functions' exists since Emacs 29.1. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3577388aa62..0aaf7d36dfa 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -8920,6 +8920,9 @@ process sentinels. They shall not disturb each other." (intern (string-remove-suffix "-file-name-handler" (symbol-name file-name-handler))))) + ;; Cleanup. + (tramp-remove-external-operation #'tramp--test-operation backend) + (tramp-remove-external-operation #'process-id backend) ;; There is no backend specific code. (should-not @@ -8950,6 +8953,9 @@ process sentinels. They shall not disturb each other." ;; This doesn't hurt. (tramp-add-external-operation #'tramp--test-operation #'tramp--handle-test-operation backend 'file) + (should + (eq #'tramp--handle-test-operation + (tramp-external-operation-p #'tramp--test-operation backend))) ;; The backend specific function is called. (should @@ -8977,6 +8983,7 @@ process sentinels. They shall not disturb each other." (tramp-remove-external-operation #'tramp--test-operation backend) ;; There is no backend specific code. + (should-not (tramp-external-operation-p #'tramp--test-operation backend)) (should-not (string-equal (tramp--test-operation ert-remote-temporary-file-directory) (tramp--handle-test-operation @@ -9004,6 +9011,9 @@ process sentinels. They shall not disturb each other." (tramp-add-external-operation #'tramp--test-operation #'tramp--handle-test-operation backend 'default-directory) + (should + (eq #'tramp--handle-test-operation + (tramp-external-operation-p #'tramp--test-operation backend))) ;; The backend specific function is called. (let ((default-directory ert-remote-temporary-file-directory)) @@ -9017,6 +9027,7 @@ process sentinels. They shall not disturb each other." (tramp-remove-external-operation #'tramp--test-operation backend) ;; There is no backend specific code. + (should-not (tramp-external-operation-p #'tramp--test-operation backend)) (let ((default-directory ert-remote-temporary-file-directory)) (should-not (string-equal (tramp--test-operation) @@ -9048,16 +9059,48 @@ process sentinels. They shall not disturb each other." (should (natnump (setq id (process-id proc)))) (tramp-add-external-operation #'process-id #'tramp--handle-process-id backend 'process) + (should + (eq #'tramp--handle-process-id + (tramp-external-operation-p #'process-id backend))) (should (= (process-id proc) (1+ id)))) ;; Cleanup. (tramp-remove-external-operation #'process-id backend) + (should-not (tramp-external-operation-p #'process-id backend)) (ignore-errors (delete-process proc))))) + ;; Test `tramp-file-name' arg type. + (tramp-add-external-operation + #'tramp--test-operation #'tramp--handle-test-operation + backend 'tramp-file-name) + (should + (eq #'tramp--handle-test-operation + (tramp-external-operation-p #'tramp--test-operation backend))) + + ;; The backend specific function is called. + (should + (string-equal (tramp--test-operation tramp-test-vec) + (tramp--handle-test-operation tramp-test-vec))) + (let ((vec (copy-tramp-file-name tramp-test-vec))) + (setf (tramp-file-name-method vec) (if (tramp--test-sh-p) "sftp" "sudo")) + (should-not + (string-equal (tramp--test-operation vec) + (tramp--handle-test-operation vec)))) + + (tramp-remove-external-operation #'tramp--test-operation backend) + ;; There is no backend specific code. + (should-not (tramp-external-operation-p #'tramp--test-operation backend)) + (should-not + (string-equal (tramp--test-operation tramp-test-vec) + (tramp--handle-test-operation tramp-test-vec))) + ;; Test function arg type. (tramp-add-external-operation #'tramp--test-operation #'tramp--handle-test-operation backend #'tramp--test-operation-file-name-for-operation) + (should + (eq #'tramp--handle-test-operation + (tramp-external-operation-p #'tramp--test-operation backend))) ;; The backend specific function is called. (let ((default-directory ert-remote-temporary-file-directory)) @@ -9071,6 +9114,7 @@ process sentinels. They shall not disturb each other." (tramp-remove-external-operation #'tramp--test-operation backend) ;; There is no backend specific code. + (should-not (tramp-external-operation-p #'tramp--test-operation backend)) (let ((default-directory ert-remote-temporary-file-directory)) (should-not (string-equal (tramp--test-operation)