Commit 76b3bd8c authored by Michael Albinus's avatar Michael Albinus
Browse files

Improve Tramp cache for asynchronous processes

* lisp/net/tramp-adb.el (tramp-adb-handle-exec-path)
(tramp-adb-get-device):
* lisp/net/tramp-gvfs.el (tramp-gvfs-handler-askquestion):
* lisp/net/tramp-sh.el (tramp-remote-selinux-p, tramp-remote-acl-p)
(tramp-open-connection-setup-interactive-shell)
(tramp-maybe-open-connection, tramp-get-remote-path)
(tramp-get-inline-compress, tramp-get-inline-coding):
* lisp/net/tramp-smb.el (tramp-smb-get-cifs-capabilities)
(tramp-smb-get-stat-capability):
* lisp/net/tramp-sudoedit.el (tramp-sudoedit-remote-acl-p)
(tramp-sudoedit-remote-selinux-p): Cache property in main process.

* lisp/net/tramp-cache.el (tramp-cache-undefined): New defconst.
(tramp-get-hash-table, tramp-connection-property-p): Use it.
(tramp-set-connection-property, tramp-flush-connection-property)
(tramp-flush-connection-properties): Add sanity checks.
(tramp-get-file-property, tramp-set-file-property)
(tramp-get-connection-property, tramp-set-connection-property)
(tramp-dump-connection-properties): Adapt docstring.

* lisp/net/tramp-cmds.el (tramp-cleanup-connection): Delete all
processes.

* lisp/net/tramp-gvfs.el (tramp-gvfs-unmount):
Use `tramp-cleanup-connection'.

* lisp/net/tramp-sh.el (tramp-sh-handle-vc-registered):
Use `bound-and-true-p'.

* lisp/net/tramp.el (tramp-get-process): New defun.
parent 96e53675
Pipeline #5117 passed with stage
in 60 minutes and 1 second
......@@ -1097,7 +1097,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Like `exec-path' for Tramp files."
(append
(with-parsed-tramp-file-name default-directory nil
(with-tramp-connection-property v "remote-path"
(with-tramp-connection-property (tramp-get-process v) "remote-path"
(tramp-adb-send-command v "echo \\\"$PATH\\\"")
(split-string
(with-current-buffer (tramp-get-connection-buffer v)
......@@ -1112,11 +1112,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Return full host name from VEC to be used in shell execution.
E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\"
a host name \"R38273882DE\" returns \"R38273882DE\"."
;; Sometimes this is called before there is a connection process
;; yet. In order to work with the connection cache, we flush all
;; unwanted entries first.
(tramp-flush-connection-properties nil)
(with-tramp-connection-property (tramp-get-connection-process vec) "device"
(with-tramp-connection-property (tramp-get-process vec) "device"
(let* ((host (tramp-file-name-host vec))
(port (tramp-file-name-port-or-default vec))
(devices (mapcar #'cadr (tramp-adb-parse-device-names nil))))
......
......@@ -31,13 +31,13 @@
;; a process, has a unique cache. We distinguish 4 kind of caches,
;; depending on the key:
;;
;; - localname is NIL. This are reusable properties. Examples:
;; - localname is nil. These are reusable properties. Examples:
;; "remote-shell" identifies the POSIX shell to be called on the
;; remote host, or "perl" is the command to be called on the remote
;; host when starting a Perl script. These properties are saved in
;; the file `tramp-persistency-file-name'.
;;
;; - localname is a string. This are temporary properties, which are
;; - localname is a string. These are temporary properties, which are
;; related to the file localname is referring to. Examples:
;; "file-exists-p" is t or nil, depending on the file existence, or
;; "file-attributes" caches the result of the function
......@@ -45,21 +45,32 @@
;; expire after `remote-file-name-inhibit-cache' seconds if this
;; variable is set.
;;
;; - The key is a process. This are temporary properties related to
;; - The key is a process. These are temporary properties related to
;; an open connection. Examples: "scripts" keeps shell script
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the time stamp a command has been sent to the remote process.
;;
;; - The key is nil. This are temporary properties related to the
;; - The key is nil. These are temporary properties related to the
;; local machine. Examples: "parse-passwd" and "parse-group" keep
;; the results of parsing "/etc/passwd" and "/etc/group",
;; "{uid,gid}-{integer,string}" are the local uid and gid, and
;; "locale" is the used shell locale.
;;
;; - The key is `tramp-cache-undefined'. All functions return the
;; expected values, but nothing is cached.
;; Some properties are handled special:
;;
;; - "process-name", "process-buffer" and "first-password-request" are
;; not saved in the file `tramp-persistency-file-name'.
;; not saved in the file `tramp-persistency-file-name', although
;; being connection properties related to a `tramp-file-name'
;; structure.
;;
;; - Reusable properties, which should not be saved, are kept in the
;; process key retrieved by `tramp-get-process' (the main connection
;; process). Other processes could reuse these properties, avoiding
;; recomputation when a new asynchronous process is created by
;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el).
;;; Code:
......@@ -96,25 +107,31 @@ details see the info pages."
(defvar tramp-cache-data-changed nil
"Whether persistent cache data have been changed.")
;;;###tramp-autoload
(defconst tramp-cache-undefined 'undef
"The symbol marking undefined hash keys and values.")
(defun tramp-get-hash-table (key)
"Return the hash table for KEY.
If it doesn't exist yet, it is created and initialized with
matching entries of `tramp-connection-properties'."
(or (gethash key tramp-cache-data)
(let ((hash
(puthash key (make-hash-table :test #'equal) tramp-cache-data)))
(when (tramp-file-name-p key)
(dolist (elt tramp-connection-properties)
(when (string-match-p
(or (nth 0 elt) "")
(tramp-make-tramp-file-name key 'noloc 'nohop))
(tramp-set-connection-property key (nth 1 elt) (nth 2 elt)))))
hash)))
matching entries of `tramp-connection-properties'.
If KEY is `tramp-cache-undefined', don't create anything, and return nil."
(unless (eq key tramp-cache-undefined)
(or (gethash key tramp-cache-data)
(let ((hash
(puthash key (make-hash-table :test #'equal) tramp-cache-data)))
(when (tramp-file-name-p key)
(dolist (elt tramp-connection-properties)
(when (string-match-p
(or (nth 0 elt) "")
(tramp-make-tramp-file-name key 'noloc 'nohop))
(tramp-set-connection-property key (nth 1 elt) (nth 2 elt)))))
hash))))
;;;###tramp-autoload
(defun tramp-get-file-property (key file property default)
"Get the PROPERTY of FILE from the cache context of KEY.
Returns DEFAULT if not set."
Return DEFAULT if not set."
;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq file (tramp-compat-file-name-unquote file)
key (copy-tramp-file-name key))
......@@ -152,7 +169,7 @@ Returns DEFAULT if not set."
;;;###tramp-autoload
(defun tramp-set-file-property (key file property value)
"Set the PROPERTY of FILE to VALUE, in the cache context of KEY.
Returns VALUE."
Return VALUE."
;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq file (tramp-compat-file-name-unquote file)
key (copy-tramp-file-name key))
......@@ -283,8 +300,9 @@ This is suppressed for temporary buffers."
"Get the named PROPERTY for the connection.
KEY identifies the connection, it is either a process or a
`tramp-file-name' structure. A special case is nil, which is
used to cache connection properties of the local machine. If the
value is not set for the connection, returns DEFAULT."
used to cache connection properties of the local machine.
If KEY is `tramp-cache-undefined', or if the value is not set for
the connection, return DEFAULT."
;; Unify key by removing localname and hop from `tramp-file-name'
;; structure. Work with a copy in order to avoid side effects.
(when (tramp-file-name-p key)
......@@ -308,19 +326,22 @@ value is not set for the connection, returns DEFAULT."
"Set the named PROPERTY of a connection to VALUE.
KEY identifies the connection, it is either a process or a
`tramp-file-name' structure. A special case is nil, which is
used to cache connection properties of the local machine.
PROPERTY is set persistent when KEY is a `tramp-file-name' structure."
used to cache connection properties of the local machine. If KEY
is `tramp-cache-undefined', nothing is set.
PROPERTY is set persistent when KEY is a `tramp-file-name' structure.
Return VALUE."
;; Unify key by removing localname and hop from `tramp-file-name'
;; structure. Work with a copy in order to avoid side effects.
(when (tramp-file-name-p key)
(setq key (copy-tramp-file-name key))
(setf (tramp-file-name-localname key) nil
(tramp-file-name-hop key) nil))
(let ((hash (tramp-get-hash-table key)))
(puthash property value hash)
(setq tramp-cache-data-changed t)
(tramp-message key 7 "%s %s" property value)
value))
(when-let ((hash (tramp-get-hash-table key)))
(puthash property value hash))
(setq tramp-cache-data-changed
(or tramp-cache-data-changed (tramp-tramp-file-p key)))
(tramp-message key 7 "%s %s" property value)
value)
;;;###tramp-autoload
(defun tramp-connection-property-p (key property)
......@@ -328,7 +349,8 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure."
KEY identifies the connection, it is either a process or a
`tramp-file-name' structure. A special case is nil, which is
used to cache connection properties of the local machine."
(not (eq (tramp-get-connection-property key property 'undef) 'undef)))
(not (eq (tramp-get-connection-property key property tramp-cache-undefined)
tramp-cache-undefined)))
;;;###tramp-autoload
(defun tramp-flush-connection-property (key property)
......@@ -343,8 +365,10 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure."
(setq key (copy-tramp-file-name key))
(setf (tramp-file-name-localname key) nil
(tramp-file-name-hop key) nil))
(remhash property (tramp-get-hash-table key))
(setq tramp-cache-data-changed t)
(when-let ((hash (tramp-get-hash-table key)))
(remhash property hash))
(setq tramp-cache-data-changed
(or tramp-cache-data-changed (tramp-tramp-file-p key)))
(tramp-message key 7 "%s" property))
;;;###tramp-autoload
......@@ -361,9 +385,10 @@ used to cache connection properties of the local machine."
(tramp-file-name-hop key) nil))
(tramp-message
key 7 "%s %s" key
(let ((hash (gethash key tramp-cache-data)))
(when (hash-table-p hash) (hash-table-keys hash))))
(setq tramp-cache-data-changed t)
(when-let ((hash (gethash key tramp-cache-data)))
(hash-table-keys hash)))
(setq tramp-cache-data-changed
(or tramp-cache-data-changed (tramp-tramp-file-p key)))
(remhash key tramp-cache-data))
;;;###tramp-autoload
......@@ -414,7 +439,8 @@ used to cache connection properties of the local machine."
(hash-table-keys tramp-cache-data)))))
(defun tramp-dump-connection-properties ()
"Write persistent connection properties into file `tramp-persistency-file-name'."
"Write persistent connection properties into file \
`tramp-persistency-file-name'."
;; We shouldn't fail, otherwise Emacs might not be able to be closed.
(ignore-errors
(when (and (hash-table-p tramp-cache-data)
......
......@@ -107,21 +107,19 @@ When called interactively, a Tramp connection has to be selected."
;; suppressed.
(setq tramp-current-connection nil)
;; Flush file cache.
(tramp-flush-directory-properties vec "")
;; Flush connection cache.
(when (processp (tramp-get-connection-process vec))
(tramp-flush-connection-properties (tramp-get-connection-process vec))
(delete-process (tramp-get-connection-process vec)))
(tramp-flush-connection-properties vec)
;; Cancel timer.
(dolist (timer timer-list)
(when (and (eq (timer--function timer) 'tramp-timeout-session)
(tramp-file-name-equal-p vec (car (timer--args timer))))
(cancel-timer timer)))
;; Delete processes.
(dolist (key (hash-table-keys tramp-cache-data))
(when (and (processp key)
(tramp-file-name-equal-p (process-get key 'vector) vec))
(tramp-flush-connection-properties key)
(delete-process key)))
;; Remove buffers.
(dolist
(buf (list (get-buffer (tramp-buffer-name vec))
......@@ -130,6 +128,12 @@ When called interactively, a Tramp connection has to be selected."
(tramp-get-connection-property vec "process-buffer" nil)))
(when (bufferp buf) (kill-buffer buf)))
;; Flush file cache.
(tramp-flush-directory-properties vec "")
;; Flush connection cache.
(tramp-flush-connection-properties vec)
;; The end.
(run-hook-with-args 'tramp-cleanup-connection-hook vec)))
......
......@@ -1731,8 +1731,7 @@ a downcased host name only."
(list
t ;; handled.
nil ;; no abort of D-Bus.
(with-tramp-connection-property
(tramp-get-connection-process v) message
(with-tramp-connection-property (tramp-get-process v) message
;; In theory, there can be several choices.
;; Until now, there is only the question whether
;; to accept an unknown host signature or certificate.
......@@ -1946,8 +1945,7 @@ a downcased host name only."
(tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec))))
(while (tramp-gvfs-connection-mounted-p vec)
(read-event nil nil 0.1))
(tramp-flush-connection-properties vec)
(tramp-flush-connection-properties (tramp-get-connection-process vec)))
(tramp-cleanup-connection vec 'keep-debug 'keep-password))
(defun tramp-gvfs-mount-spec-entry (key value)
"Construct a mount-spec entry to be used in a mount_spec.
......
......@@ -1539,7 +1539,7 @@ of."
(defun tramp-remote-selinux-p (vec)
"Check, whether SELINUX is enabled on the remote host."
(with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p"
(with-tramp-connection-property (tramp-get-process vec) "selinux-p"
(tramp-send-command-and-check vec "selinuxenabled")))
(defun tramp-sh-handle-file-selinux-context (filename)
......@@ -1588,7 +1588,7 @@ of."
(defun tramp-remote-acl-p (vec)
"Check, whether ACL is enabled on the remote host."
(with-tramp-connection-property (tramp-get-connection-process vec) "acl-p"
(with-tramp-connection-property (tramp-get-process vec) "acl-p"
(tramp-send-command-and-check vec "getfacl /")))
(defun tramp-sh-handle-file-acl (filename)
......@@ -3580,23 +3580,29 @@ STDERR can also be a file name."
remote-file-name-inhibit-cache process-file-side-effects)
;; Reduce `vc-handled-backends' in order to minimize
;; process calls.
(when (and (memq 'Bzr vc-handled-backends)
(boundp 'vc-bzr-program)
(not (with-tramp-connection-property v vc-bzr-program
(tramp-find-executable
v vc-bzr-program (tramp-get-remote-path v)))))
(when (and
(memq 'Bzr vc-handled-backends)
(not (and
(bound-and-true-p vc-bzr-program)
(with-tramp-connection-property v vc-bzr-program
(tramp-find-executable
v vc-bzr-program (tramp-get-remote-path v))))))
(setq vc-handled-backends (remq 'Bzr vc-handled-backends)))
(when (and (memq 'Git vc-handled-backends)
(boundp 'vc-git-program)
(not (with-tramp-connection-property v vc-git-program
(tramp-find-executable
v vc-git-program (tramp-get-remote-path v)))))
(when (and
(memq 'Git vc-handled-backends)
(not (and
(bound-and-true-p vc-git-program)
(with-tramp-connection-property v vc-git-program
(tramp-find-executable
v vc-git-program (tramp-get-remote-path v))))))
(setq vc-handled-backends (remq 'Git vc-handled-backends)))
(when (and (memq 'Hg vc-handled-backends)
(boundp 'vc-hg-program)
(not (with-tramp-connection-property v vc-hg-program
(tramp-find-executable
v vc-hg-program (tramp-get-remote-path v)))))
(when (and
(memq 'Hg vc-handled-backends)
(not (and
(bound-and-true-p vc-hg-program)
(with-tramp-connection-property v vc-hg-program
(tramp-find-executable
v vc-hg-program (tramp-get-remote-path v))))))
(setq vc-handled-backends (remq 'Hg vc-handled-backends)))
;; Run.
(tramp-with-demoted-errors
......@@ -4290,11 +4296,15 @@ process to set up. VEC specifies the connection."
;; connection properties. We start again with
;; `tramp-maybe-open-connection', it will be caught there.
(tramp-message vec 5 "Checking system information")
(let ((old-uname (tramp-get-connection-property vec "uname" nil))
(uname
(tramp-set-connection-property
vec "uname"
(tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))
(let* ((old-uname (tramp-get-connection-property vec "uname" nil))
(uname
;; If we are in `make-process', we don't need to recompute.
(if (and old-uname
(tramp-get-connection-property vec "process-name" nil))
old-uname
(tramp-set-connection-property
vec "uname"
(tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))))
(when (and (stringp old-uname) (not (string-equal old-uname uname)))
(tramp-message
vec 3
......@@ -5053,7 +5063,7 @@ connection if a previous connection has died for some reason."
;; we cannot use `tramp-get-connection-process'.
(tmpfile
(with-tramp-connection-property
(get-process (tramp-buffer-name vec)) "temp-file"
(tramp-get-process vec) "temp-file"
(make-temp-name
(expand-file-name
tramp-temp-name-prefix
......@@ -5426,7 +5436,7 @@ Nonexistent directories are removed from spec."
;; cache the result for the session only. Otherwise, the
;; result is cached persistently.
(if (memq 'tramp-own-remote-path tramp-remote-path)
(tramp-get-connection-process vec)
(tramp-get-process vec)
vec)
"remote-path"
(let* ((remote-path (copy-tree tramp-remote-path))
......@@ -5945,10 +5955,9 @@ the length of the file to be compressed.
If no corresponding command is found, nil is returned."
(when (and (integerp tramp-inline-compress-start-size)
(> size tramp-inline-compress-start-size))
(with-tramp-connection-property (tramp-get-connection-process vec) prop
(with-tramp-connection-property (tramp-get-process vec) prop
(tramp-find-inline-compress vec)
(tramp-get-connection-property
(tramp-get-connection-process vec) prop nil))))
(tramp-get-connection-property (tramp-get-process vec) prop nil))))
(defun tramp-get-inline-coding (vec prop size)
"Return the coding command related to PROP.
......@@ -5966,11 +5975,9 @@ function cell is returned to be applied on a buffer."
;; no inline coding is found.
(ignore-errors
(let ((coding
(with-tramp-connection-property
(tramp-get-connection-process vec) prop
(with-tramp-connection-property (tramp-get-process vec) prop
(tramp-find-inline-encoding vec)
(tramp-get-connection-property
(tramp-get-connection-process vec) prop nil)))
(tramp-get-connection-property (tramp-get-process vec) prop nil)))
(prop1 (if (string-match-p "encoding" prop)
"inline-compress" "inline-decompress"))
compress)
......
......@@ -1845,7 +1845,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(if (and (process-live-p (tramp-get-connection-process vec))
(tramp-get-connection-property vec "posix" t))
(with-tramp-connection-property
(tramp-get-connection-process vec) "cifs-capabilities"
(tramp-get-process vec) "cifs-capabilities"
(save-match-data
(when (tramp-smb-send-command vec "posix")
(with-current-buffer (tramp-get-connection-buffer vec)
......@@ -1862,8 +1862,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
;; When we are not logged in yet, we return nil.
(if (and (tramp-smb-get-share vec)
(process-live-p (tramp-get-connection-process vec)))
(with-tramp-connection-property
(tramp-get-connection-process vec) "stat-capability"
(with-tramp-connection-property (tramp-get-process vec) "stat-capability"
(tramp-smb-send-command vec "stat \"/\""))))
......
......@@ -373,7 +373,7 @@ the result will be a local, non-Tramp, file name."
(defun tramp-sudoedit-remote-acl-p (vec)
"Check, whether ACL is enabled on the remote host."
(with-tramp-connection-property (tramp-get-connection-process vec) "acl-p"
(with-tramp-connection-property (tramp-get-process vec) "acl-p"
(zerop (tramp-call-process vec "getfacl" nil nil nil "/"))))
(defun tramp-sudoedit-handle-file-acl (filename)
......@@ -478,7 +478,7 @@ the result will be a local, non-Tramp, file name."
(defun tramp-sudoedit-remote-selinux-p (vec)
"Check, whether SELINUX is enabled on the remote host."
(with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p"
(with-tramp-connection-property (tramp-get-process vec) "selinux-p"
(zerop (tramp-call-process vec "selinuxenabled"))))
(defun tramp-sudoedit-handle-file-selinux-context (filename)
......
......@@ -37,7 +37,7 @@
;; For more detailed instructions, please see the info file.
;;
;; Notes:
;; -----
;; ------
;;
;; Also see the todo list at the bottom of this file.
;;
......@@ -46,6 +46,7 @@
;;
;; There's a mailing list for this, as well. Its name is:
;; tramp-devel@gnu.org
;; You can use the Web to subscribe, under the following URL:
;; https://lists.gnu.org/mailman/listinfo/tramp-devel
;;
......@@ -1631,6 +1632,15 @@ from the default one."
(or (tramp-get-connection-property vec "process-name" nil)
(tramp-buffer-name vec)))
(defun tramp-get-process (vec-or-proc)
"Get the default connection process to be used for VEC-OR-PROC.
Return `tramp-cache-undefined' in case it doesn't exist."
(or (and (tramp-file-name-p vec-or-proc)
(get-buffer-process (tramp-buffer-name vec-or-proc)))
(and (processp vec-or-proc)
(tramp-get-process (process-get vec-or-proc 'vector)))
tramp-cache-undefined))
(defun tramp-get-connection-process (vec)
"Get the connection process to be used for VEC.
In case a second asynchronous communication has been started, it is different
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment