Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-06-14 04:21:24 +00:00
Code Issues Projects Releases Packages Wiki Activity

Extend Tramp external operations

Browse source 
* doc/misc/tramp.texi (New operations): Extend.

* lisp/net/tramp.el (tramp-file-name-for-operation-external):
Extend docstring.
(tramp-file-name-for-operation): Make more use of
`tramp-file-name-for-operation-external'.
(tramp-add-external-operation): Support ARG-TYPE `tramp-file-name'.

* test/lisp/net/tramp-tests.el (tramp-test49-external-backend-function):
Extend test.
This commit is contained in:
Michael Albinus 2026-06-10 15:45:31 +02:00
parent 4dea6ea36b
commit f89ff62367
3 changed files with 132 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
doc/misc/tramp.texi
View file

@ -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}.

105
lisp/net/tramp.el
View file

@ -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.

44
test/lisp/net/tramp-tests.el
View file

@ -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)