diff options
Diffstat (limited to 'lisp/net')
33 files changed, 3377 insertions, 1783 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 92ed98b2a89..0cb8d7cb837 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -838,7 +838,7 @@ If nil, prompt the user for a password." "If non-nil, regexp matching hosts on which `dir' command lists directory." :group 'ange-ftp :type '(choice (const :tag "Default" nil) - string)) + regexp)) (defcustom ange-ftp-binary-file-name-regexp "" "If a file matches this regexp then it is transferred in binary mode." @@ -4169,8 +4169,7 @@ directory, so that Emacs will know its current contents." (if (file-directory-p file) (ange-ftp-delete-directory file recursive trash) (delete-file file trash))) - ;; We do not want to delete "." and "..". - (directory-files dir 'full (rx (or (not ".") "..."))))) + (directory-files dir 'full directory-files-no-dot-files-regexp))) (if parsed (let* ((host (nth 0 parsed)) (user (nth 1 parsed)) @@ -4739,7 +4738,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired. 0) -(defun ange-ftp-set-file-modes (filename mode) +(defun ange-ftp-set-file-modes (filename mode &optional flag) + flag ;; FIXME: Support 'nofollow'. (ange-ftp-call-chmod (list (format "%o" mode) filename))) (defun ange-ftp-make-symbolic-link (&rest _arguments) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 25aabf6d61d..8892e800cd6 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,7 +39,6 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany Epiphany Don't know -;; browse-url-conkeror Conkeror Don't know ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -114,9 +113,23 @@ ;; To always save modified buffers before displaying the file in a browser: ;; (setq browse-url-save-file t) -;; To invoke different browsers for different URLs: -;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail) -;; ("." . browse-url-firefox))) +;; To invoke different browsers/tools for different URLs, customize +;; `browse-url-handlers'. In earlier versions of Emacs, the same +;; could be done by setting `browse-url-browser-function' to an alist +;; but this usage is deprecated now. + +;; All browser functions provided by here have a +;; `browse-url-browser-kind' symbol property set to either `internal' +;; or `external' which determines if they browse the given URL inside +;; Emacs or spawn an external application with it. Some parts of +;; Emacs make use of that, e.g., when an URL is dragged into Emacs, it +;; is not sensible to invoke an external browser with it, so here only +;; internal browsers are considered. Therefore, it is advised to put +;; that property also on custom browser functions. +;; (function-put 'my-browse-url-in-emacs 'browse-url-browser-kind +;; 'internal) +;; (function-put 'my-browse-url-externally 'browse-url-browser-kind +;; 'external) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code: @@ -140,7 +153,6 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "Epiphany" :value browse-url-epiphany) - (function-item :tag "Conkeror" :value browse-url-conkeror) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -157,7 +169,9 @@ :value browse-url-default-browser) (function :tag "Your own function") (alist :tag "Regexp/function association list" - :key-type regexp :value-type function))) + :key-type regexp :value-type function + :format "%{%t%}\n%d%v\n" + :doc "Deprecated. Use `browse-url-handlers' instead."))) ;;;###autoload (defcustom browse-url-browser-function 'browse-url-default-browser @@ -165,13 +179,8 @@ This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. -If the value is not a function it should be a list of pairs -\(REGEXP . FUNCTION). In this case the function called will be the one -associated with the first REGEXP which matches the current URL. The -function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser. - -Also see `browse-url-secondary-browser-function'." +Also see `browse-url-secondary-browser-function' and +`browse-url-handlers'." :type browse-url--browser-defcustom-type :version "24.1") @@ -216,7 +225,7 @@ be used instead." "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" "\\|" "[" chars punct "]+" "[" chars "]" @@ -385,6 +394,8 @@ If non-nil, then open the URL in a new buffer rather than a new window if :version "25.1" :type 'boolean) +(make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1") + (defcustom browse-url-galeon-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if @@ -438,11 +449,15 @@ commands reverses the effect of this variable." :type 'string :version "25.1") +(make-obsolete-variable 'browse-url-conkeror-program nil "28.1") + (defcustom browse-url-conkeror-arguments nil "A list of strings to pass to Conkeror as arguments." :version "25.1" :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'browse-url-conkeror-arguments nil "28.1") + (defcustom browse-url-filename-alist `(("^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*" . "ftp://\\2/") ;; The above loses the username to avoid the browser prompting for @@ -595,6 +610,116 @@ down (this *won't* always work)." "Wrapper command prepended to the Elinks command-line." :type '(repeat (string :tag "Wrapper"))) +(defun browse-url--browser-kind (function url) + "Return the browser kind of a browser FUNCTION for URL. +The browser kind is either `internal' (the browser runs inside +Emacs), `external' (the browser is spawned in an external +process), or nil (we don't know)." + (let ((kind (if (symbolp function) + (get function 'browse-url-browser-kind)))) + (if (functionp kind) + (funcall kind url) + kind))) + +(defun browse-url--mailto (url &rest args) + "Calls `browse-url-mailto-function' with URL and ARGS." + (funcall browse-url-mailto-function url args)) + +(defun browse-url--browser-kind-mailto (url) + (browse-url--browser-kind browse-url-mailto-function url)) +(function-put 'browse-url--mailto 'browse-url-browser-kind + #'browse-url--browser-kind-mailto) + +(defun browse-url--man (url &rest args) + "Calls `browse-url-man-function' with URL and ARGS." + (funcall browse-url-man-function url args)) + +(defun browse-url--browser-kind-man (url) + (browse-url--browser-kind browse-url-man-function url)) +(function-put 'browse-url--man 'browse-url-browser-kind + #'browse-url--browser-kind-man) + +(defun browse-url--browser (url &rest args) + "Calls `browse-url-browser-function' with URL and ARGS." + (funcall browse-url-browser-function url args)) + +(defun browse-url--browser-kind-browser (url) + (browse-url--browser-kind browse-url-browser-function url)) +(function-put 'browse-url--browser 'browse-url-browser-kind + #'browse-url--browser-kind-browser) + +(defun browse-url--non-html-file-url-p (url) + "Return non-nil if URL is a file:// URL of a non-HTML file." + (and (string-match-p "\\`file://" url) + (not (string-match-p "\\`file://.*\\.html?\\b" url)))) + +;;;###autoload +(defvar browse-url-default-handlers + '(("\\`mailto:" . browse-url--mailto) + ("\\`man:" . browse-url--man) + (browse-url--non-html-file-url-p . browse-url-emacs)) + "Like `browse-url-handlers' but populated by Emacs and packages. + +Emacs and external packages capable of browsing certain URLs +should place their entries in this alist rather than +`browse-url-handlers' which is reserved for the user.") + +(defcustom browse-url-handlers nil + "An alist with elements of the form (REGEXP-OR-PREDICATE . HANDLER). +Each REGEXP-OR-PREDICATE is matched against the URL to be opened +in turn and the first match's HANDLER is invoked with the URL. + +A HANDLER must be a function with the same arguments as +`browse-url'. + +If no REGEXP-OR-PREDICATE matches, the same procedure is +performed with the value of `browse-url-default-handlers'. If +there is also no match, the URL is opened using the value of +`browse-url-browser-function'." + :type '(alist :key-type (choice + (regexp :tag "Regexp") + (function :tag "Predicate")) + :value-type (function :tag "Handler")) + :version "28.1") + +;;;###autoload +(defun browse-url-select-handler (url &optional kind) + "Return a handler of suitable for browsing URL. +This searches `browse-url-handlers', and +`browse-url-default-handlers' for a matching handler. Return nil +if no handler is found. + +If KIND is given, the search is restricted to handlers whose +function symbol has the symbol-property `browse-url-browser-kind' +set to KIND. + +Currently, it also consults `browse-url-browser-function' first +if it is set to an alist, although this usage is deprecated since +Emacs 28.1 and will be removed in a future release." + (catch 'custom-url-handler + (dolist (rxpred-handler + (append + ;; The alist choice of browse-url-browser-function + ;; is deprecated since 28.1, so the (unless ...) + ;; can be removed at some point in time. + (when (and (consp browse-url-browser-function) + (not (functionp browse-url-browser-function))) + (lwarn 'browse-url :warning + "Having `browse-url-browser-function' set to an +alist is deprecated. Use `browse-url-handlers' instead.") + browse-url-browser-function) + browse-url-handlers + browse-url-default-handlers)) + (let ((rx-or-pred (car rxpred-handler)) + (handler (cdr rxpred-handler))) + (when (and (or (null kind) + (eq kind (browse-url--browser-kind + handler url))) + (if (functionp rx-or-pred) + (funcall rx-or-pred url) + (string-match-p rx-or-pred url))) + (throw 'custom-url-handler handler)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL encoding @@ -768,16 +893,18 @@ narrowed." "Ask a WWW browser to load URL. Prompt for a URL, defaulting to the URL at or before point. Invokes a suitable browser function which does the actual job. -The variable `browse-url-browser-function' says which browser function to -use. If the URL is a mailto: URL, consult `browse-url-mailto-function' -first, if that exists. - -The additional ARGS are passed to the browser function. See the doc -strings of the actual functions, starting with `browse-url-browser-function', -for information about the significance of ARGS (most of the functions -ignore it). -If ARGS are omitted, the default is to pass `browse-url-new-window-flag' -as ARGS." + +The variables `browse-url-browser-function', +`browse-url-handlers', and `browse-url-default-handlers' +determine which browser function to use. + +The additional ARGS are passed to the browser function. See the +doc strings of the actual functions, starting with +`browse-url-browser-function', for information about the +significance of ARGS (most of the functions ignore it). + +If ARGS are omitted, the default is to pass +`browse-url-new-window-flag' as ARGS." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) @@ -786,12 +913,9 @@ as ARGS." (not (string-match "\\`[a-z]+:" url))) (setq url (expand-file-name url))) (let ((process-environment (copy-sequence process-environment)) - (function (or (and (string-match "\\`mailto:" url) - browse-url-mailto-function) - (and (string-match "\\`man:" url) - browse-url-man-function) - browse-url-browser-function)) - ;; Ensure that `default-directory' exists and is readable (b#6077). + (function (or (browse-url-select-handler url) + browse-url-browser-function)) + ;; Ensure that `default-directory' exists and is readable (bug#6077). (default-directory (or (unhandled-file-name-directory default-directory) (expand-file-name "~/")))) ;; When connected to various displays, be careful to use the display of @@ -799,20 +923,9 @@ as ARGS." ;; which may not even exist any more. (if (stringp (frame-parameter nil 'display)) (setenv "DISPLAY" (frame-parameter nil 'display))) - (if (and (consp function) - (not (functionp function))) - ;; The `function' can be an alist; look down it for first match - ;; and apply the function (which might be a lambda). - (catch 'done - (dolist (bf function) - (when (string-match (car bf) url) - (apply (cdr bf) url args) - (throw 'done t))) - (error "No browse-url-browser-function matching URL %s" - url)) - ;; Unbound symbols go down this leg, since void-function from - ;; apply is clearer than wrong-type-argument from dolist. - (apply function url args)))) + (if (functionp function) + (apply function url args) + (error "No suitable browser for URL %s" url)))) ;;;###autoload (defun browse-url-at-point (&optional arg) @@ -829,6 +942,34 @@ Optional prefix argument ARG non-nil inverts the value of the option (error "No URL found")))) ;;;###autoload +(defun browse-url-with-browser-kind (kind url &optional arg) + "Browse URL with a browser of the given browser KIND. +KIND is either `internal' or `external'. + +When called interactively, the default browser kind is the +opposite of the browser kind of `browse-url-browser-function'." + (interactive + (let* ((url-arg (browse-url-interactive-arg "URL: ")) + ;; Default to the inverse kind of the default browser. + (default (if (eq (browse-url--browser-kind + browse-url-browser-function (car url-arg)) + 'internal) + 'external + 'internal)) + (k (intern (completing-read + (format "Browser kind (default %s): " default) + '(internal external) + nil t nil nil + default)))) + (cons k url-arg))) + (let ((function (browse-url-select-handler url kind))) + (unless function + (setq function (if (eq kind 'external) + #'browse-url-default-browser + #'eww))) + (funcall function url arg))) + +;;;###autoload (defun browse-url-at-mouse (event) "Ask a WWW browser to load a URL clicked with the mouse. The URL is the one around or before the position of the mouse click @@ -875,12 +1016,18 @@ The optional NEW-WINDOW argument is not used." (url-unhex-string url) url))))) +(function-put 'browse-url-default-windows-browser 'browse-url-browser-kind + 'external) + (defun browse-url-default-macosx-browser (url &optional _new-window) "Invoke the macOS system's default Web browser. The optional NEW-WINDOW argument is not used." (interactive (browse-url-interactive-arg "URL: ")) (start-process (concat "open " url) nil "open" url)) +(function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind + 'external) + ;; --- Netscape --- (defun browse-url-process-environment () @@ -929,7 +1076,7 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-kde-program) 'browse-url-kde) ;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ;;; ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) - ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) +;;; ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) ((executable-find browse-url-chrome-program) 'browse-url-chrome) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) @@ -937,6 +1084,10 @@ instead of `browse-url-new-window-flag'." (lambda (&rest _ignore) (error "No usable browser found")))) url args)) +(function-put 'browse-url-default-browser 'browse-url-browser-kind + ;; Well, most probably external if we ignore w3. + 'external) + (defun browse-url-can-use-xdg-open () "Return non-nil if the \"xdg-open\" program can be used. xdg-open is a desktop utility that calls your preferred web browser." @@ -956,6 +1107,8 @@ The optional argument IGNORED is not used." (interactive (browse-url-interactive-arg "URL: ")) (call-process "xdg-open" nil 0 nil url)) +(function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-netscape (url &optional new-window) "Ask the Netscape WWW browser to load URL. @@ -999,6 +1152,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-netscape-sentinel process ,url))))) +(function-put 'browse-url-netscape 'browse-url-browser-kind 'external) + (defun browse-url-netscape-sentinel (process url) "Handle a change to the process communicating with Netscape." (declare (obsolete nil "25.1")) @@ -1069,6 +1224,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-mozilla-sentinel process ,url))))) +(function-put 'browse-url-mozilla 'browse-url-browser-kind 'external) + (defun browse-url-mozilla-sentinel (process url) "Handle a change to the process communicating with Mozilla." (or (eq (process-exit-status process) 0) @@ -1109,6 +1266,8 @@ instead of `browse-url-new-window-flag'." '("-new-window"))) (list url))))) +(function-put 'browse-url-firefox 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-chromium (url &optional _new-window) "Ask the Chromium WWW browser to load URL. @@ -1126,6 +1285,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chromium-arguments (list url))))) +(function-put 'browse-url-chromium 'browse-url-browser-kind 'external) + (defun browse-url-chrome (url &optional _new-window) "Ask the Google Chrome WWW browser to load URL. Default to the URL around or before point. The strings in @@ -1142,6 +1303,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chrome-arguments (list url))))) +(function-put 'browse-url-chrome 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-galeon (url &optional new-window) "Ask the Galeon WWW browser to load URL. @@ -1179,6 +1342,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-galeon-sentinel process ,url))))) +(function-put 'browse-url-galeon 'browse-url-browser-kind 'external) + (defun browse-url-galeon-sentinel (process url) "Handle a change to the process communicating with Galeon." (declare (obsolete nil "25.1")) @@ -1225,6 +1390,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-epiphany-sentinel process ,url))))) +(function-put 'browse-url-epiphany 'browse-url-browser-kind 'external) + (defun browse-url-epiphany-sentinel (process url) "Handle a change to the process communicating with Epiphany." (or (eq (process-exit-status process) 0) @@ -1249,6 +1416,8 @@ currently selected window instead." file-name-handler-alist))) (if same-window (find-file url) (find-file-other-window url)))) +(function-put 'browse-url-emacs 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. @@ -1273,6 +1442,8 @@ used instead of `browse-url-new-window-flag'." '("--newwin")) (list "--raise" url)))) +(function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external) + ;; --- Mosaic --- ;;;###autoload @@ -1324,6 +1495,8 @@ used instead of `browse-url-new-window-flag'." (append browse-url-mosaic-arguments (list url))) (message "Starting %s...done" browse-url-mosaic-program)))) +(function-put 'browse-url-mosaic 'browse-url-browser-kind 'external) + ;; --- Mosaic using CCI --- ;;;###autoload @@ -1356,6 +1529,8 @@ used instead of `browse-url-new-window-flag'." (process-send-string "browse-url" "disconnect\r\n") (delete-process "browse-url")) +(function-put 'browse-url-cci 'browse-url-browser-kind 'external) + ;; --- Conkeror --- ;;;###autoload (defun browse-url-conkeror (url &optional new-window) @@ -1375,6 +1550,7 @@ new window, load it in a new buffer in an existing window instead. When called non-interactively, use optional second argument NEW-WINDOW instead of `browse-url-new-window-flag'." + (declare (obsolete nil "28.1")) (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) @@ -1392,6 +1568,9 @@ NEW-WINDOW instead of `browse-url-new-window-flag'." "window") "buffer") url)))))) + +(function-put 'browse-url-conkeror 'browse-url-browser-kind 'external) + ;; --- W3 --- ;; External. @@ -1415,6 +1594,8 @@ used instead of `browse-url-new-window-flag'." (w3-fetch-other-window url) (w3-fetch url))) +(function-put 'browse-url-w3 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-w3-gnudoit (url &optional _new-window) ;; new-window ignored @@ -1429,6 +1610,8 @@ The `browse-url-gnudoit-program' program is used with options given by (list (concat "(w3-fetch \"" url "\")") "(raise-frame)")))) +(function-put 'browse-url-w3-gnudoit 'browse-url-browser-kind 'internal) + ;; --- Lynx in an xterm --- ;;;###autoload @@ -1446,6 +1629,8 @@ The optional argument NEW-WINDOW is not used." ,@browse-url-xterm-args "-e" ,browse-url-text-browser ,url))) +(function-put 'browse-url-text-xterm 'browse-url-browser-kind 'external) + ;; --- Lynx in an Emacs "term" window --- (declare-function term-char-mode "term" ()) @@ -1520,6 +1705,8 @@ used instead of `browse-url-new-window-flag'." url "\r"))))) +(function-put 'browse-url-text-emacs 'browse-url-browser-kind 'internal) + ;; --- mailto --- (autoload 'rfc2368-parse-mailto-url "rfc2368") @@ -1567,6 +1754,8 @@ used instead of `browse-url-new-window-flag'." (unless (bolp) (insert "\n")))))))) +(function-put 'browse-url-mail 'browse-url-browser-kind 'internal) + ;; --- man --- (defvar manual-program) @@ -1578,7 +1767,9 @@ used instead of `browse-url-new-window-flag'." (setq url (replace-regexp-in-string "\\`man:" "" url)) (cond ((executable-find manual-program) (man url)) - (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + +(function-put 'browse-url-man 'browse-url-browser-kind 'internal) ;; --- Random browser --- @@ -1597,6 +1788,8 @@ don't offer a form of remote control." 0 nil (append browse-url-generic-args (list url)))) +(function-put 'browse-url-generic 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-kde (url &optional _new-window) "Ask the KDE WWW browser to load URL. @@ -1607,6 +1800,8 @@ The optional argument NEW-WINDOW is not used." (apply #'start-process (concat "KDE " url) nil browse-url-kde-program (append browse-url-kde-args (list url)))) +(function-put 'browse-url-kde 'browse-url-browser-kind 'external) + (defun browse-url-elinks-new-window (url) "Ask the Elinks WWW browser to load URL in a new window." (let ((process-environment (browse-url-process-environment))) @@ -1616,6 +1811,9 @@ The optional argument NEW-WINDOW is not used." browse-url-elinks-wrapper (list "elinks" url))))) +(function-put 'browse-url-elinks-new-window 'browse-url-browser-kind + 'external) + ;;;###autoload (defun browse-url-elinks (url &optional new-window) "Ask the Elinks WWW browser to load URL. @@ -1637,6 +1835,8 @@ from `browse-url-elinks-wrapper'." `(lambda (process change) (browse-url-elinks-sentinel process ,url)))))) +(function-put 'browse-url-elinks 'browse-url-browser-kind 'external) + (defun browse-url-elinks-sentinel (process url) "Determines if Elinks is running or a new one has to be started." ;; Try to determine if an instance is running or if we have to diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 06bd9e567fe..fdd726ff613 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -51,9 +51,6 @@ (unless (boundp 'dbus-debug) (defvar dbus-debug nil)) -;; Pacify byte compiler. -(eval-when-compile (require 'cl-lib)) - (require 'xml) (defconst dbus-service-dbus "org.freedesktop.DBus" @@ -169,10 +166,7 @@ Otherwise, return result of last form in BODY, or all other errors." `(condition-case err (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) -(define-obsolete-variable-alias 'dbus-event-error-hooks - 'dbus-event-error-functions "24.3") (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable @@ -181,7 +175,7 @@ caught in `condition-case' by `dbus-error'.") ;;; Basic D-Bus message functions. -(defvar dbus-return-values-table (make-hash-table :test 'equal) +(defvar dbus-return-values-table (make-hash-table :test #'equal) "Hash table for temporarily storing arguments of reply messages. A key in this hash table is a list (:serial BUS SERIAL), like in `dbus-registered-objects-table'. BUS is either a Lisp symbol, @@ -301,8 +295,8 @@ object is returned instead of a list containing this single Lisp object. (check-interval 0.001) (key (apply - 'dbus-message-internal dbus-message-type-method-call - bus service path interface method 'dbus-call-method-handler args)) + #'dbus-message-internal dbus-message-type-method-call + bus service path interface method #'dbus-call-method-handler args)) (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into @@ -338,10 +332,6 @@ object is returned instead of a list containing this single Lisp object. (cdr result)) (remhash key dbus-return-values-table)))) -;; `dbus-call-method' works non-blocking now. -(defalias 'dbus-call-method-non-blocking 'dbus-call-method) -(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3") - (defun dbus-call-method-asynchronously (bus service path interface method handler &rest args) "Call METHOD on the D-Bus BUS asynchronously. @@ -406,7 +396,7 @@ Example: (or (null handler) (functionp handler) (signal 'wrong-type-argument (list 'functionp handler))) - (apply 'dbus-message-internal dbus-message-type-method-call + (apply #'dbus-message-internal dbus-message-type-method-call bus service path interface method handler args)) (defun dbus-send-signal (bus service path interface signal &rest args) @@ -454,7 +444,7 @@ Example: (or (stringp signal) (signal 'wrong-type-argument (list 'stringp signal))) - (apply 'dbus-message-internal dbus-message-type-signal + (apply #'dbus-message-internal dbus-message-type-signal bus service path interface signal args)) (defun dbus-method-return-internal (bus service serial &rest args) @@ -470,7 +460,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-method-return + (apply #'dbus-message-internal dbus-message-type-method-return bus service serial args)) (defun dbus-method-error-internal (bus service serial &rest args) @@ -486,7 +476,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-error + (apply #'dbus-message-internal dbus-message-type-error bus service serial args)) @@ -552,13 +542,13 @@ placed in the queue. `:already-owner': Service is already the primary owner." ;; Add Peer handler. - (dbus-register-method - bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register) + (dbus-register-method bus service nil dbus-interface-peer "Ping" + #'dbus-peer-handler 'dont-register) ;; Add ObjectManager handler. (dbus-register-method bus service nil dbus-interface-objectmanager "GetManagedObjects" - 'dbus-managed-objects-handler 'dont-register) + #'dbus-managed-objects-handler 'dont-register) (let ((arg 0) reply) @@ -681,7 +671,7 @@ Example: (if (and (stringp service) (not (zerop (length service))) (not (string-equal service dbus-service-dbus)) - (not (string-match "^:" service))) + (/= (string-to-char service) ?:)) (setq uname (dbus-get-name-owner bus service)) (setq uname service)) @@ -710,7 +700,7 @@ Example: ;; `:arg0' .. `:arg63', `:path0' .. `:path63'. ((and (keywordp key) (string-match - "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$" + "\\`:\\(arg\\|path\\)\\([[:digit:]]+\\)\\'" (symbol-name key))) (setq counter (match-string 2 (symbol-name key)) args (cdr args) @@ -726,9 +716,7 @@ Example: "path" "") value)) ;; `:arg-namespace', `:path-namespace'. - ((and (keywordp key) - (string-match - "^:\\(arg\\|path\\)-namespace$" (symbol-name key))) + ((memq key '(:arg-namespace :path-namespace)) (setq args (cdr args) value (car args)) (unless (stringp value) @@ -736,8 +724,7 @@ Example: (list "Wrong argument" key value))) (format ",%s='%s'" - (if (string-equal (match-string 1 (symbol-name key)) "path") - "path_namespace" "arg0namespace") + (if (eq key :path-namespace) "path_namespace" "arg0namespace") value)) ;; `:eavesdrop'. ((eq key :eavesdrop) @@ -751,11 +738,11 @@ Example: bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule) (dbus-error - (if (not (string-match "eavesdrop" rule)) + (if (not (string-match-p "eavesdrop" rule)) (signal (car err) (cdr err)) ;; The D-Bus spec says we shall fall back to a rule without eavesdrop. (when dbus-debug (message "Removing eavesdrop from rule %s" rule)) - (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule)) + (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule t t)) (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule)))) @@ -893,9 +880,7 @@ association to the service from D-Bus." STRING shall be UTF-8 coded." (if (zerop (length string)) '(:array :signature "y") - (let (result) - (dolist (elt (string-to-list string) (append '(:array) result)) - (setq result (append result (list :byte elt))))))) + (cons :array (mapcan (lambda (c) (list :byte c)) string)))) (defun dbus-byte-array-to-string (byte-array &optional multibyte) "Transform BYTE-ARRAY into UTF-8 coded string. @@ -903,12 +888,9 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array'. The resulting string is unibyte encoded, unless MULTIBYTE is non-nil." (apply - (if multibyte 'string 'unibyte-string) - (if (equal byte-array '(:array :signature "y")) - nil - (let (result) - (dolist (elt byte-array result) - (when (characterp elt) (setq result (append result `(,elt))))))))) + (if multibyte #'string #'unibyte-string) + (unless (equal byte-array '(:array :signature "y")) + (seq-filter #'characterp byte-array)))) (defun dbus-escape-as-identifier (string) "Escape an arbitrary STRING so it follows the rules for a C identifier. @@ -930,9 +912,9 @@ telepathy-glib's `tp_escape_as_identifier'." (if (zerop (length string)) "_" (replace-regexp-in-string - "^[0-9]\\|[^A-Za-z0-9]" + "\\`[0-9]\\|[^A-Za-z0-9]" (lambda (x) (format "_%2x" (aref x 0))) - string))) + string nil t))) (defun dbus-unescape-from-identifier (string) "Retrieve the original string from the encoded STRING as unibyte string. @@ -942,7 +924,7 @@ STRING must have been encoded with `dbus-escape-as-identifier'." (replace-regexp-in-string "_.." (lambda (x) (byte-to-string (string-to-number (substring x 1) 16))) - string))) + string nil t))) ;;; D-Bus events. @@ -1020,7 +1002,7 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (if (eq result :ignore) (dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event)) - (apply 'dbus-method-return-internal + (apply #'dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event) (if (consp result) result (list result))))))) ;; Error handling. @@ -1119,10 +1101,9 @@ unique names for services." (defun dbus-list-known-names (bus) "Retrieve all services which correspond to a known name in BUS. A service has a known name if it doesn't start with \":\"." - (let (result) - (dolist (name (dbus-list-names bus) (nreverse result)) - (unless (string-equal ":" (substring name 0 1)) - (push name result))))) + (seq-remove (lambda (name) + (= (string-to-char name) ?:)) + (dbus-list-names bus))) (defun dbus-list-queued-owners (bus service) "Return the unique names registered at D-Bus BUS and queued for SERVICE. @@ -1182,6 +1163,18 @@ It will be registered for all objects created by `dbus-register-service'." ;;; D-Bus introspection. +(defsubst dbus--introspect-names (object tag) + "Return the names of the children of OBJECT with TAG." + (mapcar (lambda (elt) + (dbus-introspect-get-attribute elt "name")) + (xml-get-children object tag))) + +(defsubst dbus--introspect-name (object tag name) + "Return the first child of OBJECT with TAG, whose name is NAME." + (seq-find (lambda (elt) + (string-equal (dbus-introspect-get-attribute elt "name") name)) + (xml-get-children object tag))) + (defun dbus-introspect (bus service path) "Return all interfaces and sub-nodes of SERVICE, registered at object path PATH at bus BUS. @@ -1197,17 +1190,25 @@ XML format." bus service path dbus-interface-introspectable "Introspect" :timeout 1000))) +(defalias 'dbus--parse-xml-buffer + (if (libxml-available-p) + (lambda () + (xml-remove-comments (point-min) (point-max)) + (libxml-parse-xml-region (point-min) (point-max))) + (lambda () + (car (xml-parse-region (point-min) (point-max))))) + "Compatibility shim for `libxml-parse-xml-region'.") + (defun dbus-introspect-xml (bus service path) "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. The data are a parsed list. The root object is a \"node\", representing the object path PATH. The root object can contain \"interface\" and further \"node\" objects." - ;; We don't want to raise errors. - (xml-node-name - (ignore-errors - (with-temp-buffer - (insert (dbus-introspect bus service path)) - (xml-parse-region (point-min) (point-max)))))) + (with-temp-buffer + ;; We don't want to raise errors. + (ignore-errors + (insert (dbus-introspect bus service path)) + (dbus--parse-xml-buffer)))) (defun dbus-introspect-get-attribute (object attribute) "Return the ATTRIBUTE value of D-Bus introspection OBJECT. @@ -1219,21 +1220,15 @@ the D-Bus specification." "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings. The node names stand for further object paths of the D-Bus service." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'node) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'node)) (defun dbus-introspect-get-all-nodes (bus service path) "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings, which are further object paths of SERVICE." - (let ((result (list path))) - (dolist (elt - (dbus-introspect-get-node-names bus service path) - result) - (setq elt (expand-file-name elt path)) - (setq result - (append result (dbus-introspect-get-all-nodes bus service elt)))))) + (cons path (mapcan (lambda (elt) + (setq elt (expand-file-name elt path)) + (dbus-introspect-get-all-nodes bus service elt)) + (dbus-introspect-get-node-names bus service path)))) (defun dbus-introspect-get-interface-names (bus service path) "Return all interface names of SERVICE in D-Bus BUS at object path PATH. @@ -1244,10 +1239,7 @@ always present. Another default interface is \"org.freedesktop.DBus.Properties\". If present, \"interface\" objects can also have \"property\" objects as children, beside \"method\" and \"signal\" objects." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'interface) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'interface)) (defun dbus-introspect-get-interface (bus service path interface) "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH. @@ -1256,22 +1248,14 @@ and a member of the list returned by `dbus-introspect-get-interface-names'. The resulting \"interface\" object can contain \"method\", \"signal\", \"property\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-xml bus service path) 'interface))) - (while (and elt - (not (string-equal - interface - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name (dbus-introspect-xml bus service path) + 'interface interface)) (defun dbus-introspect-get-method-names (bus service path interface) "Return a list of strings of all method names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'method) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'method)) (defun dbus-introspect-get-method (bus service path interface method) "Return method METHOD of interface INTERFACE as an XML object. @@ -1279,22 +1263,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. METHOD must be a string and a member of the list returned by `dbus-introspect-get-method-names'. The resulting \"method\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'method))) - (while (and elt - (not (string-equal - method (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'method method)) (defun dbus-introspect-get-signal-names (bus service path interface) "Return a list of strings of all signal names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'signal) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'signal)) (defun dbus-introspect-get-signal (bus service path interface signal) "Return signal SIGNAL of interface INTERFACE as an XML object. @@ -1302,22 +1279,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. SIGNAL must be a string, element of the list returned by `dbus-introspect-get-signal-names'. The resulting \"signal\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'signal))) - (while (and elt - (not (string-equal - signal (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'signal signal)) (defun dbus-introspect-get-property-names (bus service path interface) "Return a list of strings of all property names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'property) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'property)) (defun dbus-introspect-get-property (bus service path interface property) "Return PROPERTY of INTERFACE as an XML object. @@ -1325,15 +1295,9 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. PROPERTY must be a string and a member of the list returned by `dbus-introspect-get-property-names'. The resulting PROPERTY object can contain \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'property))) - (while (and elt - (not (string-equal - property - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'property property)) (defun dbus-introspect-get-annotation-names (bus service path interface &optional name) @@ -1341,15 +1305,13 @@ object can contain \"annotation\" children." If NAME is nil, the annotations are children of INTERFACE, otherwise NAME must be a \"method\", \"signal\", or \"property\" object, where the annotations belong to." - (let ((object - (if name - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name) - (dbus-introspect-get-property bus service path interface name)) - (dbus-introspect-get-interface bus service path interface))) - result) - (dolist (elt (xml-get-children object 'annotation) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation)) (defun dbus-introspect-get-annotation (bus service path interface name annotation) @@ -1357,22 +1319,13 @@ object, where the annotations belong to." If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise NAME must be the name of a \"method\", \"signal\", or \"property\" object, where the ANNOTATION belongs to." - (let ((elt (xml-get-children - (if name - (or (dbus-introspect-get-method - bus service path interface name) - (dbus-introspect-get-signal - bus service path interface name) - (dbus-introspect-get-property - bus service path interface name)) - (dbus-introspect-get-interface bus service path interface)) - 'annotation))) - (while (and elt - (not (string-equal - annotation - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation annotation)) (defun dbus-introspect-get-argument-names (bus service path interface name) "Return a list of all argument names as a list of strings. @@ -1380,27 +1333,20 @@ NAME must be a \"method\" or \"signal\" object. Argument names are optional, the function can return nil therefore, even if the method or signal has arguments." - (let ((object - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name))) - result) - (dolist (elt (xml-get-children object 'arg) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg)) (defun dbus-introspect-get-argument (bus service path interface name arg) "Return argument ARG as XML object. NAME must be a \"method\" or \"signal\" object. ARG must be a string and a member of the list returned by `dbus-introspect-get-argument-names'." - (let ((elt (xml-get-children - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name)) - 'arg))) - (while (and elt - (not (string-equal - arg (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg arg)) (defun dbus-introspect-get-signature (bus service path interface name &optional direction) @@ -1469,13 +1415,10 @@ name of the property, and its value. If there are no properties, nil is returned." (dbus-ignore-errors ;; "GetAll" returns "a{sv}". - (let (result) - (dolist (dict - (dbus-call-method - bus service path dbus-interface-properties - "GetAll" :timeout 500 interface) - (nreverse result)) - (push (cons (car dict) (cl-caadr dict)) result))))) + (mapcar (lambda (dict) + (cons (car dict) (caadr dict))) + (dbus-call-method bus service path dbus-interface-properties + "GetAll" :timeout 500 interface)))) (defun dbus-register-property (bus service path interface property access value @@ -1520,13 +1463,13 @@ clients from discovering the still incomplete interface." ;; Add handlers for the three property-related methods. (dbus-register-method bus service path dbus-interface-properties "Get" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "GetAll" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "Set" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) ;; Register SERVICE. (unless (or dont-register-service (member service (dbus-list-names bus))) @@ -1673,7 +1616,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." (if (cadr entry2) ;; "sv". (dolist (entry3 (cadr entry2)) - (setcdr entry3 (cl-caadr entry3))) + (setcdr entry3 (caadr entry3))) (setcdr entry2 nil))))) ;; Fallback: collect the information. Slooow! @@ -1730,7 +1673,7 @@ It will be registered for all objects created by `dbus-register-service'." (append (butlast last-input-event 4) (list object dbus-interface-properties - "GetAll" 'dbus-property-handler)))) + "GetAll" #'dbus-property-handler)))) (dbus-property-handler interface)))) (cdr (assoc object result))))))))) dbus-registered-objects-table) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index 852d8ae0491..f36999119f2 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -1,4 +1,4 @@ -;;; dig.el --- Domain Name System dig interface +;;; dig.el --- Domain Name System dig interface -*- lexical-binding:t -*- ;; Copyright (C) 2000-2020 Free Software Foundation, Inc. @@ -42,15 +42,13 @@ (defcustom dig-program "dig" "Name of dig (domain information groper) binary." - :type 'file - :group 'dig) + :type 'file) (defcustom dig-dns-server nil "DNS server to query. If nil, use system defaults." :type '(choice (const :tag "System defaults") - string) - :group 'dig) + string)) (defcustom dig-font-lock-keywords '(("^;; [A-Z]+ SECTION:" 0 font-lock-keyword-face) @@ -58,8 +56,7 @@ If nil, use system defaults." ("^; <<>>.*" 0 font-lock-type-face) ("^;.*" 0 font-lock-function-name-face)) "Default expressions to highlight in dig mode." - :type 'sexp - :group 'dig) + :type 'sexp) (defun dig-invoke (domain &optional query-type query-class query-option diff --git a/lisp/net/dns.el b/lisp/net/dns.el index cefe0851f03..53ea0b19b52 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -138,7 +138,7 @@ updated. Set this variable to t to disable the check.") (defun dns-write (spec &optional tcp-p) "Write a DNS packet according to SPEC. -If TCP-P, the first two bytes of the package with be the length field." +If TCP-P, the first two bytes of the packet will be the length field." (with-temp-buffer (set-buffer-multibyte nil) (dns-write-bytes (dns-get 'id spec) 2) @@ -189,13 +189,15 @@ If TCP-P, the first two bytes of the package with be the length field." (dns-write-bytes (buffer-size) 2)) (buffer-string))) -(defun dns-read (packet) +(defun dns-read (packet &optional tcp-p) (with-temp-buffer (set-buffer-multibyte nil) (let ((spec nil) queries answers authorities additionals) (insert packet) - (goto-char (point-min)) + ;; When using TCP we have a 2 byte length field to ignore. + (goto-char (+ (point-min) + (if tcp-p 2 0))) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t)) @@ -258,10 +260,8 @@ If TCP-P, the first two bytes of the package with be the length field." (nreverse spec)))) (defun dns-read-int32 () - ;; Full 32 bit Integers can't be handled by 32-bit Emacsen. If we - ;; use floats, it works. - (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) - (dns-read-bytes 3)))) + (declare (obsolete nil "28.1")) + (number-to-string (dns-read-bytes 4))) (defun dns-read-type (string type) (let ((buffer (current-buffer)) @@ -286,11 +286,11 @@ If TCP-P, the first two bytes of the package with be the length field." ((eq type 'SOA) (list (list 'mname (dns-read-name buffer)) (list 'rname (dns-read-name buffer)) - (list 'serial (dns-read-int32)) - (list 'refresh (dns-read-int32)) - (list 'retry (dns-read-int32)) - (list 'expire (dns-read-int32)) - (list 'minimum (dns-read-int32)))) + (list 'serial (dns-read-bytes 4)) + (list 'refresh (dns-read-bytes 4)) + (list 'retry (dns-read-bytes 4)) + (list 'expire (dns-read-bytes 4)) + (list 'minimum (dns-read-bytes 4)))) ((eq type 'SRV) (list (list 'priority (dns-read-bytes 2)) (list 'weight (dns-read-bytes 2)) @@ -317,8 +317,8 @@ If TCP-P, the first two bytes of the package with be the length field." (defun dns-set-servers () "Set `dns-servers' to a list of DNS servers or nil if none are found. Parses \"/etc/resolv.conf\" or calls \"nslookup\"." + (setq dns-servers nil) (or (when (file-exists-p "/etc/resolv.conf") - (setq dns-servers nil) (with-temp-buffer (insert-file-contents "/etc/resolv.conf") (goto-char (point-min)) @@ -329,9 +329,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (with-temp-buffer (call-process "nslookup" nil t nil "localhost") (goto-char (point-min)) - (re-search-forward - "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) - (setq dns-servers (list (match-string 1)))))) + (when (re-search-forward + "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\|[[:xdigit:]:]*\\)" nil t) + (setq dns-servers (list (match-string 1))))))) (when (fboundp 'network-interface-list) (setq dns-servers-valid-for-interfaces (network-interface-list)))) @@ -359,7 +359,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." `(let ((server ,server) (coding-system-for-read 'binary) (coding-system-for-write 'binary)) - (if (fboundp 'make-network-process) + (if (and + (fboundp 'make-network-process) + (featurep 'make-network-process '(:type datagram))) (make-network-process :name "dns" :coding 'binary @@ -367,9 +369,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." :host server :service "domain" :type 'datagram) - ;; Older versions of Emacs doesn't have - ;; `make-network-process', so we fall back on opening a TCP - ;; connection to the DNS server. + ;; Older versions of Emacs do not have `make-network-process', + ;; and on MS-Windows datagram sockets are not supported, so we + ;; fall back on opening a TCP connection to the DNS server. (open-network-stream "dns" (current-buffer) server "domain")))) (defvar dns-cache (make-vector 4096 0)) @@ -402,26 +404,30 @@ If REVERSEP, look up an IP address." type 'PTR)) (if (not dns-servers) - (message "No DNS server configuration found") + (progn + (message "No DNS server configuration found") + nil) (with-temp-buffer (set-buffer-multibyte nil) - (let ((process (condition-case () - (dns-make-network-process (car dns-servers)) - (error - (message - "dns: Got an error while trying to talk to %s" - (car dns-servers)) - nil))) + (let* ((process (condition-case () + (dns-make-network-process (car dns-servers)) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) (step 100) (times (* dns-timeout 1000)) - (id (random 65000))) + (id (random 65000)) + (tcp-p (and process (not (process-contact process :type))))) (when process (process-send-string process (dns-write `((id ,id) (opcode query) (queries ((,name (type ,type)))) - (recursion-desired-p t)))) + (recursion-desired-p t)) + tcp-p)) (while (and (zerop (buffer-size)) (> times 0)) (let ((step-sec (/ step 1000.0))) @@ -434,7 +440,7 @@ If REVERSEP, look up an IP address." (when (and (>= (buffer-size) 2) ;; We had a time-out. (> times 0)) - (let ((result (dns-read (buffer-string)))) + (let ((result (dns-read (buffer-string) tcp-p))) (if fullp result (let ((answer (car (dns-get 'answers result)))) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 568b96f4d58..2f6528de948 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -25,14 +25,14 @@ ;;; Code: (require 'cl-lib) -(require 'format-spec) +(require 'mm-url) +(require 'puny) (require 'shr) +(require 'text-property-search) +(require 'thingatpt) (require 'url) (require 'url-queue) -(require 'thingatpt) -(require 'mm-url) -(require 'puny) -(eval-when-compile (require 'subr-x)) ;; for string-trim +(eval-when-compile (require 'subr-x)) (defgroup eww nil "Emacs Web Wowser" @@ -307,9 +307,11 @@ the default EWW buffer." (insert (format "Loading %s..." url)) (goto-char (point-min))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render + (url-retrieve url #'eww-render (list url nil (current-buffer))))) +(function-put 'eww 'browse-url-browser-kind 'internal) + (defun eww--dwim-expand-url (url) (setq url (string-trim url)) (cond ((string-match-p "\\`file:/" url)) @@ -373,8 +375,8 @@ engine used." (let ((region-string (buffer-substring (region-beginning) (region-end)))) (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string)) (eww region-string) - (call-interactively 'eww))) - (call-interactively 'eww))) + (call-interactively #'eww))) + (call-interactively #'eww))) (defun eww-open-in-new-buffer () "Fetch link at point in a new EWW buffer." @@ -541,10 +543,10 @@ Currently this means either text/html or application/xhtml+xml." (goto-char point)) (shr-target-id (goto-char (point-min)) - (let ((point (next-single-property-change - (point-min) 'shr-target-id))) - (when point - (goto-char point)))) + (let ((match (text-property-search-forward + 'shr-target-id shr-target-id t))) + (when match + (goto-char (prop-match-beginning match))))) (t (goto-char (point-min)) ;; Don't leave point inside forms, because the normal eww @@ -1011,7 +1013,7 @@ just re-display the HTML already fetched." (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render + (url-retrieve url #'eww-render (list url (point) (current-buffer) encode)))))) ;; Form support. @@ -1111,11 +1113,13 @@ just re-display the HTML already fetched." (defun eww-form-submit (dom) (let ((start (point)) (value (dom-attr dom 'value))) - (setq value - (if (zerop (length value)) - "Submit" - value)) - (insert value) + (if (null value) + (shr-generic dom) + (insert value)) + ;; If the contents of the <button>...</button> turns out to be + ;; empty, or the value was blank, default to this: + (when (= (point) start) + (insert "Submit")) (add-face-text-property start (point) 'eww-form-submit) (put-text-property start (point) 'eww-form (list :eww-form eww-form @@ -1572,8 +1576,10 @@ If EXTERNAL is double prefix, browse in new buffer." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + ((string-match-p "\\`mailto:" url) + ;; This respects the user options `browse-url-handlers' + ;; and `browse-url-mailto-function'. + (browse-url url)) ((and (consp external) (<= (car external) 4)) (funcall browse-url-secondary-browser-function url) (shr--blink-link)) @@ -1611,7 +1617,7 @@ Use link at point if there is one, else the current page's URL." (eww-current-url)))) (if (not url) (message "No URL under point") - (url-retrieve url 'eww-download-callback (list url))))) + (url-retrieve url #'eww-download-callback (list url))))) (defun eww-download-callback (status url) (unless (plist-get status :error) @@ -1735,7 +1741,7 @@ If CHARSET is nil then use UTF-8." (defun eww-write-bookmarks () (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory) - (insert ";; Auto-generated file; don't edit\n") + (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") (pp eww-bookmarks (current-buffer)))) (defun eww-read-bookmarks () @@ -2124,12 +2130,12 @@ entries (if any) will be removed from the list. Only the properties listed in `eww-desktop-data-save' are included. Generally, the list should not include the (usually overly large) :dom, :source and :text properties." - (let ((history (mapcar 'eww-desktop-data-1 - (cons eww-data eww-history)))) - (list :history (if eww-desktop-remove-duplicates - (cl-remove-duplicates - history :test 'eww-desktop-history-duplicate) - history)))) + (let ((history (mapcar #'eww-desktop-data-1 + (cons eww-data eww-history)))) + (list :history (if eww-desktop-remove-duplicates + (cl-remove-duplicates + history :test #'eww-desktop-history-duplicate) + history)))) (defun eww-restore-desktop (file-name buffer-name misc-data) "Restore an eww buffer from its desktop file record. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 459156e6d27..cd86b4dea65 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -169,8 +169,9 @@ Third arg HOST is the name of the host to connect to, or its IP address. Fourth arg SERVICE is the name of the service desired, or an integer specifying a port number to connect to. Fifth arg PARAMETERS is an optional list of keyword/value pairs. -Only :client-certificate and :nowait keywords are recognized, and -have the same meaning as for `open-network-stream'. +Only :client-certificate, :nowait, and :coding keywords are +recognized, and have the same meaning as for +`open-network-stream'. For historical reasons PARAMETERS can also be a symbol, which is interpreted the same as passing a list containing :nowait and the value of that symbol. @@ -208,7 +209,8 @@ trust and key files, and priority string." (gnutls-boot-parameters :type 'gnutls-x509pki :keylist keylist - :hostname (puny-encode-domain host))))))) + :hostname (puny-encode-domain host)))) + :coding (plist-get parameters :coding)))) (if nowait process (gnutls-negotiate :process process diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el index 92efb6ba275..974ee0d3691 100644 --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -1,4 +1,4 @@ -;;; hmac-md5.el --- Compute HMAC-MD5. +;;; hmac-md5.el --- Compute HMAC-MD5. -*- lexical-binding:t -*- ;; Copyright (C) 1999, 2001, 2007-2020 Free Software Foundation, Inc. @@ -22,42 +22,8 @@ ;;; Commentary: -;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". -;; -;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) -;; => "9294727a3638bb1c13f48ef8158bfc9d" -;; -;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) -;; => "750c783e6ab0b503eaa86e310a5db738" -;; -;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) -;; => "56be34521d144c88dbb8c733f0e8b3f6" -;; -;; (encode-hex-string -;; (hmac-md5 -;; (make-string 50 ?\xcd) -;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) -;; => "697eaf0aca3a3aea3a75164746ffaa79" -;; -;; (encode-hex-string -;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995690efd4c" -;; -;; (encode-hex-string -;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key - Hash Key First" -;; (make-string 80 ?\xaa))) -;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" -;; (make-string 80 ?\xaa))) -;; => "6f630fad67cda0ee1fb1f562db3aa53e" +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1", +;; moved to lisp/test/net/hmac-md5-tests.el ;;; Code: diff --git a/lisp/net/imap.el b/lisp/net/imap.el index aa10f0291fd..a492dc8c798 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -136,7 +136,6 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -(require 'format-spec) (require 'utf7) (require 'rfc2104) ;; Hmm... digest-md5 is not part of Emacs. @@ -517,12 +516,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -583,12 +579,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -701,13 +694,10 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?g imap-shell-host - ?p (number-to-string port) - ?l imap-default-user))))) + (format-spec cmd `((?s . ,server) + (?g . ,imap-shell-host) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user)))))) (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index e42a7655ef3..700653250fb 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -727,7 +727,7 @@ an alist of attribute/value pairs." (setq record nil) (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) - (1+ numres)) + (setq numres (1+ numres))) (message "Parsing results... done") (nreverse result))))) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index e99d7a372c0..1c371f59870 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -113,6 +113,10 @@ values: `ssl' -- Equivalent to `tls'. `shell' -- A shell connection. +:coding is a symbol or a cons used to specify the coding systems +used to decode and encode the data which the process reads and +writes. See `make-network-process' for details. + :return-list specifies this function's return value. If omitted or nil, return a process object. A non-nil means to return (PROC . PROPS), where PROC is a process object and PROPS @@ -166,8 +170,8 @@ a greeting from the server. :nowait, if non-nil, says the connection should be made asynchronously, if possible. -:shell-command is a format-spec string that can be used if :type -is `shell'. It has two specs, %s for host and %p for port +:shell-command is a `format-spec' string that can be used if +:type is `shell'. It has two specs, %s for host and %p for port number. Example: \"ssh gateway nc %s %p\". :tls-parameters is a list that should be supplied if you're @@ -189,7 +193,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." :host (puny-encode-domain host) :service service :nowait (plist-get parameters :nowait) :tls-parameters - (plist-get parameters :tls-parameters)) + (plist-get parameters :tls-parameters) + :coding (plist-get parameters :coding)) (let ((work-buffer (or buffer (generate-new-buffer " *stream buffer*"))) (fun (cond ((and (eq type 'plain) @@ -249,7 +254,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) :service service - :nowait (plist-get parameters :nowait)))) + :nowait (plist-get parameters :nowait) + :coding (plist-get parameters :coding)))) (when (plist-get parameters :warn-unless-encrypted) (setq stream (nsm-verify-connection stream host service nil t))) (list stream @@ -270,7 +276,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) (stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) - :service service)) + :service service + :coding (plist-get parameters :coding))) (greeting (and (not (plist-get parameters :nogreeting)) (network-stream-get-response stream start eoc))) (capabilities (network-stream-command stream capability-command @@ -350,7 +357,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (setq stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) - :service service)) + :service service + :coding (plist-get parameters :coding))) (network-stream-get-response stream start eoc))) (unless (process-live-p stream) (error "Unable to negotiate a TLS connection with %s/%s" @@ -445,22 +453,25 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (network-stream-command stream capability-command eo-capa) 'tls))))))) -(declare-function format-spec "format-spec" (format spec)) -(declare-function format-spec-make "format-spec" (&rest pairs)) - (defun network-stream-open-shell (name buffer host service parameters) - (require 'format-spec) (let* ((capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) (start (with-current-buffer buffer (point))) + (coding (plist-get parameters :coding)) (stream (let ((process-connection-type nil)) (start-process name buffer shell-file-name shell-command-switch (format-spec (plist-get parameters :shell-command) - (format-spec-make - ?s host - ?p service)))))) + `((?s . ,host) + (?p . ,service))))))) + (when coding (if (consp coding) + (set-process-coding-system stream + (car coding) + (cdr coding)) + (set-process-coding-system stream + coding + coding))) (list stream (network-stream-get-response stream start eoc) (network-stream-command stream capability-command diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index eb61d7a6796..b8f1bccd788 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -363,7 +363,7 @@ description are marked as immortal." (const :tag "Title" title) (const :tag "Description" description) (const :tag "All" all)) - (string :tag "Regexp"))))) + (regexp :tag "Regexp"))))) :group 'newsticker-headline-processing) ;; ====================================================================== diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index e94947bc7f1..cc22427e6d1 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -311,9 +311,9 @@ See also: `network-security-protocol-checks' and `nsm-noninteractive'" (map-values results) "\n") "\n") - "\n* "))))) - (delete-process process) - (setq process nil))) + "\n* ")))))) + (delete-process process) + (setq process nil)) (run-hook-with-args 'nsm-tls-post-check-functions host port status settings results))) process) @@ -371,7 +371,7 @@ Reference: Sheffer, Holz, Saint-Andre (May 2015). \"Recommendations for Secure Use of Transport Layer Security (TLS) and Datagram Transport Layer Security (DTLS)\", \"(4.1. General Guidelines)\" -`https://tools.ietf.org/html/rfc7525\#section-4.1'" +`https://tools.ietf.org/html/rfc7525#section-4.1'" (let ((kx (plist-get status :key-exchange))) (and (string-match "^\\bRSA\\b" kx) (format-message @@ -468,7 +468,7 @@ Reference: GnuTLS authors (2018). \"GnuTLS Manual 4.3.3 Anonymous authentication\", -`https://www.gnutls.org/manual/gnutls.html\#Anonymous-authentication'" +`https://www.gnutls.org/manual/gnutls.html#Anonymous-authentication'" (let ((kx (plist-get status :key-exchange))) (and (string-match "\\bANON\\b" kx) (format-message @@ -603,7 +603,7 @@ References: full SHA-1\", `https://shattered.io/static/shattered.pdf' [2]: Chromium Security Education TLS/SSL. \"Deprecated and Removed Features (SHA-1 Certificate Signatures)\", -`https://www.chromium.org/Home/chromium-security/education/tls\#TOC-SHA-1-Certificate-Signatures' +`https://www.chromium.org/Home/chromium-security/education/tls#TOC-SHA-1-Certificate-Signatures' [3]: Jones J.C (2017). \"The end of SHA-1 on the Public Web\", `https://blog.mozilla.org/security/2017/02/23/the-end-of-sha-1-on-the-public-web/' [4]: Apple Support (2017). \"Move to SHA-256 signed certificates to @@ -964,6 +964,7 @@ protocol." (defun nsm-write-settings () (with-temp-file nsm-settings-file + (insert ";;;; -*- mode: lisp-data -*-\n") (insert "(\n") (dolist (setting nsm-permanent-host-settings) (insert " ") diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 60a6c12e6c7..cc406076c58 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -1,4 +1,4 @@ -;;; puny.el --- translate non-ASCII domain names to ASCII +;;; puny.el --- translate non-ASCII domain names to ASCII -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. @@ -35,7 +35,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." ;; The vast majority of domain names are not IDNA domain names, so ;; add a check first to avoid doing unnecessary work. - (if (string-match "\\'[[:ascii:]]+\\'" domain) + (if (string-match "\\`[[:ascii:]]+\\'" domain) domain (mapconcat 'puny-encode-string (split-string domain "[.]") "."))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index fff640bb675..1766e192f2d 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -254,7 +254,7 @@ Examples: (\"bitlbee\" bitlbee \"robert\" \"sekrit\") (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))" - :type '(alist :key-type (string :tag "Server") + :type '(alist :key-type (regexp :tag "Server") :value-type (choice (list :tag "NickServ" (const nickserv) (string :tag "Nick") @@ -359,9 +359,9 @@ If VAL is a coding system, it is used for both decoding and encoding messages. If VAL is a cons of coding systems, the car part is used for decoding, and the cdr part is used for encoding." - :type '(alist :key-type (choice (string :tag "Channel Regexp") - (cons (string :tag "Channel Regexp") - (string :tag "Server Regexp"))) + :type '(alist :key-type (choice (regexp :tag "Channel Regexp") + (cons (regexp :tag "Channel Regexp") + (regexp :tag "Server Regexp"))) :value-type (choice coding-system (cons (coding-system :tag "Decode") (coding-system :tag "Encode"))))) @@ -2421,7 +2421,7 @@ keywords when no KEYWORD is given." (concat "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "[" chars "]" "\\|" "[" chars punct "]+" "[" chars "]" "\\)")) @@ -2626,12 +2626,16 @@ the only argument." (and ;; nickserv (string= sender "NickServ") (string= target rcirc-nick) - (member message - (list - (format "You are now identified for \C-b%s\C-b." rcirc-nick) - (format "You are successfully identified as \C-b%s\C-b." rcirc-nick) - "Password accepted - you are now recognized." - ))) + (cl-member + message + (list + (format "You are now identified for \C-b%s\C-b." rcirc-nick) + (format "You are successfully identified as \C-b%s\C-b." + rcirc-nick) + "Password accepted - you are now recognized.") + ;; The nick may have a different case, so match + ;; case-insensitively (Bug#39345). + :test #'cl-equalp)) (and ;; quakenet (string= sender "Q") (string= target rcirc-nick) diff --git a/lisp/net/sasl-scram-sha256.el b/lisp/net/sasl-scram-sha256.el new file mode 100644 index 00000000000..e50a032c233 --- /dev/null +++ b/lisp/net/sasl-scram-sha256.el @@ -0,0 +1,59 @@ +;;; sasl-scram-sha256.el --- SCRAM-SHA-256 module for the SASL client framework -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> +;; Package: sasl + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Implement the SCRAM-SHA-256 mechanism from RFC 7677. + +;;; Code: + +(require 'cl-lib) +(require 'sasl) +(require 'hex-util) +(require 'rfc2104) +(require 'sasl-scram-rfc) + +;;; SCRAM-SHA-256 + +(defconst sasl-scram-sha-256-steps + '(sasl-scram-client-first-message + sasl-scram-sha-256-client-final-message + sasl-scram-sha-256-authenticate-server)) + +(defun sasl-scram-sha256 (object &optional start end binary) + (secure-hash 'sha256 object start end binary)) + +(defun sasl-scram-sha-256-client-final-message (client step) + (sasl-scram--client-final-message + ;; HMAC-SHA256 uses block length 64 and hash length 32; see RFC 4634. + 'sasl-scram-sha256 64 32 client step)) + +(defun sasl-scram-sha-256-authenticate-server (client step) + (sasl-scram--authenticate-server + 'sasl-scram-sha256 64 32 client step)) + +(put 'sasl-scram-sha256 'sasl-mechanism + (sasl-make-mechanism "SCRAM-SHA-256" sasl-scram-sha-256-steps)) + +(provide 'sasl-scram-sha256) + +;;; sasl-scram-sha256.el ends here diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index 4405c904cd3..ab118e1f982 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -35,8 +35,8 @@ ;;; Code: (defvar sasl-mechanisms - '("SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" - "NTLM")) + '("SCRAM-SHA-256" "SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" + "ANONYMOUS" "NTLM")) (defvar sasl-mechanism-alist '(("CRAM-MD5" sasl-cram) @@ -45,6 +45,7 @@ ("LOGIN" sasl-login) ("ANONYMOUS" sasl-anonymous) ("NTLM" sasl-ntlm) + ("SCRAM-SHA-256" sasl-scram-sha256) ("SCRAM-SHA-1" sasl-scram-rfc))) (defvar sasl-unique-id-function #'sasl-unique-id-function) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 241180d471a..a3f04968a27 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -135,7 +135,7 @@ same domain as the main data." This is used for cid: URLs, and the function is called with the cid: URL as the argument.") -(defvar shr-put-image-function 'shr-put-image +(defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") (defface shr-strike-through '((t :strike-through t)) @@ -185,13 +185,15 @@ and other things: (defvar shr-depth 0) (defvar shr-warning nil) (defvar shr-ignore-cache nil) -(defvar shr-target-id nil) (defvar shr-table-separator-length 1) (defvar shr-table-separator-pixel-width 0) (defvar shr-table-id nil) (defvar shr-current-font nil) (defvar shr-internal-bullet nil) +(defvar shr-target-id nil + "Target fragment identifier anchor.") + (defvar shr-map (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) @@ -365,25 +367,20 @@ If the URL is already at the front of the kill ring act like (shr-copy-url url))) (defun shr--current-link-region () - (let ((current (get-text-property (point) 'shr-url)) - start) - (save-excursion - ;; Go to the beginning. - (while (and (not (bobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char -1)) - (unless (equal (get-text-property (point) 'shr-url) current) - (forward-char 1)) - (setq start (point)) - ;; Go to the end. - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (list start (point))))) + "Return the start and end positions of the URL at point, if any. +Value is a pair of positions (START . END) if there is a non-nil +`shr-url' text property at point; otherwise nil." + (when (get-text-property (point) 'shr-url) + (let* ((end (or (next-single-property-change (point) 'shr-url) + (point-max))) + (beg (or (previous-single-property-change end 'shr-url) + (point-min)))) + (cons beg end)))) (defun shr--blink-link () - (let* ((region (shr--current-link-region)) - (overlay (make-overlay (car region) (cadr region)))) + "Briefly fontify URL at point with the face `shr-selected-link'." + (when-let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cdr region)))) (overlay-put overlay 'face 'shr-selected-link) (run-at-time 1 nil (lambda () (delete-overlay overlay))))) @@ -437,7 +434,7 @@ the URL of the image to the kill buffer instead." (if (not url) (message "No image under point") (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker)) t)))) @@ -463,7 +460,7 @@ size, and full-buffer size." (when (> (- (point) start) 2) (delete-region start (1- (point))))) (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker) (list (cons 'size (cond ((or (eq size 'default) @@ -493,7 +490,7 @@ size, and full-buffer size." ((fboundp function) (apply function dom args)) (t - (apply 'shr-generic dom args))))) + (apply #'shr-generic dom args))))) (defun shr-descend (dom) (let ((function @@ -531,13 +528,13 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when (and shr-target-id - (equal (dom-attr dom 'id) shr-target-id)) + (when-let* ((id (dom-attr dom 'id))) ;; If the element was empty, we don't have anything to put the ;; anchor on. So just insert a dummy character. (when (= start (point)) - (insert "*")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?*) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -730,9 +727,10 @@ size, and full-buffer size." (let ((gap-start (point)) (face (get-text-property (point) 'face))) ;; Extend the background to the end of the line. - (if face - (insert (propertize "\n" 'face (shr-face-background face))) - (insert "\n")) + (insert ?\n) + (when face + (put-text-property (1- (point)) (point) + 'face (shr-face-background face))) (shr-indent) (when (and (> (1- gap-start) (point-min)) (get-text-property (point) 'shr-url) @@ -838,7 +836,7 @@ size, and full-buffer size." ;; Always chop off anchors. (when (string-match "#.*" url) (setq url (substring url 0 (match-beginning 0)))) - ;; NB: <base href="" > URI may itself be relative to the document s URI + ;; NB: <base href=""> URI may itself be relative to the document's URI. (setq url (shr-expand-url url)) (let* ((parsed (url-generic-parse-url url)) (local (url-filename parsed))) @@ -935,12 +933,11 @@ size, and full-buffer size." (defun shr-indent () (when (> shr-indentation 0) - (insert - (if (not shr-use-fonts) - (make-string shr-indentation ?\s) - (propertize " " - 'display - `(space :width (,shr-indentation))))))) + (if (not shr-use-fonts) + (insert-char ?\s shr-indentation) + (insert ?\s) + (put-text-property (1- (point)) (point) + 'display `(space :width (,shr-indentation)))))) (defun shr-fontize-dom (dom &rest types) (let ((start (point))) @@ -987,16 +984,11 @@ the mouse click event." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + (external + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) (t - (if external - (progn - (funcall browse-url-secondary-browser-function url) - (shr--blink-link)) - (browse-url url (if new-window - (not browse-url-new-window-flag) - browse-url-new-window-flag))))))) + (browse-url url (xor new-window browse-url-new-window-flag)))))) (defun shr-save-contents (directory) "Save the contents from URL in a file." @@ -1005,7 +997,7 @@ the mouse click event." (if (not url) (message "No link under point") (url-retrieve (shr-encode-url url) - 'shr-store-contents (list url directory))))) + #'shr-store-contents (list url directory))))) (defun shr-store-contents (status url directory) (unless (plist-get status :error) @@ -1156,7 +1148,6 @@ width/height instead." ;; url-cache-extract autoloads url-cache. (declare-function url-cache-create-filename "url-cache" (url)) -(autoload 'browse-url-mail "browse-url") (defun shr-get-image-data (url) "Get image data for URL. @@ -1230,7 +1221,7 @@ START, and END. Note that START and END should be markers." (funcall shr-put-image-function image (buffer-substring start end)) (delete-region (point) end)))) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) start end) t t))))) @@ -1265,7 +1256,9 @@ START, and END. Note that START and END should be markers." (format "%s (%s)" iri title) iri)) 'follow-link t - 'mouse-face 'highlight)) + ;; Make separate regions not `eq' so that they'll get + ;; separate mouse highlights. + 'mouse-face (list 'highlight))) ;; Don't overwrite any keymaps that are already in the buffer (i.e., ;; image keymaps). (while (and start @@ -1438,7 +1431,7 @@ ones, in case fg and bg are nil." (shr-fontize-dom dom 'underline)) (defun shr-tag-code (dom) - (let ((shr-current-font 'default)) + (let ((shr-current-font 'fixed-pitch)) (shr-generic dom))) (defun shr-tag-tt (dom) @@ -1495,14 +1488,13 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (when (and shr-target-id - (equal (dom-attr dom 'name) shr-target-id)) - ;; We have a zero-length <a name="foo"> element, so just - ;; insert... something. + (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + ;; We have an empty element, so just insert... something. (when (= start (point)) - (shr-ensure-newline) - (insert " ")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?\s) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) @@ -1677,7 +1669,7 @@ The preference is a float determined from `shr-prefer-media-type'." (or alt ""))) (insert " ") (url-queue-retrieve - (shr-encode-url url) 'shr-image-fetched + (shr-encode-url url) #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) (list :width width :height height)) t @@ -2004,12 +1996,11 @@ BASE is the URL of the HTML being rendered." (cond ((null tbodies) dom) - ((= (length tbodies) 1) + ((null (cdr tbodies)) (car tbodies)) (t ;; Table with multiple tbodies. Convert into a single tbody. - `(tbody nil ,@(cl-reduce 'append - (mapcar 'dom-non-text-children tbodies))))))) + `(tbody nil ,@(mapcan #'dom-non-text-children tbodies)))))) (defun shr--fix-tbody (tbody) (nconc (list 'tbody (dom-attributes tbody)) @@ -2309,8 +2300,8 @@ flags that control whether to collect or render objects." (dolist (column row) (aset natural-widths i (max (aref natural-widths i) column)) (setq i (1+ i))))) - (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)) + (let ((extra (- (apply #'+ (append suggested-widths nil)) + (apply #'+ (append widths nil)) (* shr-table-separator-pixel-width (1+ (length widths))))) (expanded-columns 0)) ;; We have extra, unused space, so divide this space amongst the diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5cfcb81708f..a7a5047ed49 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -136,7 +136,7 @@ It is used for TCP/IP devices." (file-selinux-context . tramp-handle-file-selinux-context) (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-adb-handle-file-system-info) - (file-truename . tramp-adb-handle-file-truename) + (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -160,6 +160,8 @@ It is used for TCP/IP devices." (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -181,10 +183,9 @@ It is used for TCP/IP devices." "Invoke the ADB handler for OPERATION. First arg specifies the OPERATION, second arg is a list of ARGUMENTS to pass to the OPERATION." - (let ((fn (assoc operation tramp-adb-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) arguments)) - (tramp-run-real-handler operation arguments)))) + (if-let ((fn (assoc operation tramp-adb-file-name-handler-alist))) + (save-match-data (apply (cdr fn) arguments)) + (tramp-run-real-handler operation arguments))) ;;;###tramp-autoload (tramp--with-startup @@ -228,105 +229,6 @@ ARGUMENTS to pass to the OPERATION." (string-to-number (match-string 2)))) (* 1024 (string-to-number (match-string 3))))))))) -;; This is derived from `tramp-sh-handle-file-truename'. Maybe the -;; code could be shared? -(defun tramp-adb-handle-file-truename (filename) - "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". - (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) - ;; Quote properly. - (funcall - (if (tramp-compat-file-name-quoted-p filename) - #'tramp-compat-file-name-quote #'identity) - (with-parsed-tramp-file-name - (tramp-compat-file-name-unquote (expand-file-name filename)) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let (result) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (let* ((steps (split-string localname "/" 'omit)) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; otherwise - ;; they might think that Emacs is hung. Of course, - ;; correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string - ;; like "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (string-join (cons "" result) "/") - "/")) - (when (and is-dir (or (string-empty-p result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))) - - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (file-remote-p result) - (setq result (tramp-compat-file-name-quote result 'top))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result))))))) - (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) @@ -631,9 +533,6 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -650,6 +549,10 @@ But handle the case, if the \"test\" command is not available." (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -667,13 +570,16 @@ But handle the case, if the \"test\" command is not available." (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) -(defun tramp-adb-handle-set-file-modes (filename mode) +(defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) + ;; ADB shell does not support "chmod -h". + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (tramp-adb-send-command-and-check + v (format "chmod %o %s" mode localname))))) -(defun tramp-adb-handle-set-file-times (filename &optional time) +(defun tramp-adb-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -682,21 +588,22 @@ But handle the case, if the \"test\" command is not available." (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) time)) + (nofollow (if (eq flag 'nofollow) "-h" "")) (quoted-name (tramp-shell-quote-argument localname))) ;; Older versions of toybox 'touch' mishandle nanoseconds and/or ;; trailing "Z", so fall back on plain seconds if nanoseconds+Z ;; fails. Also, fall back on old POSIX 'touch -t' if 'touch -d' ;; (introduced in POSIX.1-2008) fails. (tramp-adb-send-command-and-check - v (format (concat "touch -d %s %s 2>/dev/null || " - "touch -d %s %s 2>/dev/null || " - "touch -t %s %s") + v (format (concat "touch -d %s %s %s 2>/dev/null || " + "touch -d %s %s %s 2>/dev/null || " + "touch -t %s %s %s") (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) - quoted-name + nofollow quoted-name (format-time-string "%Y-%m-%dT%H:%M:%S" time t) - quoted-name + nofollow quoted-name (format-time-string "%Y%m%d%H%M.%S" time t) - quoted-name))))) + nofollow quoted-name))))) (defun tramp-adb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -719,14 +626,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter v 0 (format "Copying %s to %s" filename newname) (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. @@ -739,46 +646,45 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-shell-quote-argument l2)) "Error copying %s to %s" filename newname)) - (let ((tmpfile (file-local-copy filename))) - - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. - (when (and (file-directory-p newname) - (tramp-compat-directory-name-p newname)) - (setq newname - (expand-file-name - (file-name-nondirectory filename) newname))) - - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - - ;; We must also flush the cache of the directory, - ;; because `file-attributes' reads the values from - ;; there. - (tramp-flush-file-properties v localname) - (when (tramp-adb-execute-adb-command - v "push" - (tramp-compat-file-name-unquote filename) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error - "Cannot copy `%s' `%s'" filename newname))))))))) + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name + (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v localname) + (when (tramp-adb-execute-adb-command + v "push" + (tramp-compat-file-name-unquote filename) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error + "Cannot copy `%s' `%s'" filename newname)))))))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -801,7 +707,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -809,8 +715,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v l1) @@ -846,7 +752,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -877,8 +783,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -895,14 +800,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; it. Call it in a subshell, in order to preserve working ;; directory. (condition-case nil - (progn - (setq ret - (if (tramp-adb-send-command-and-check - v - (format "(cd %s; %s)" - (tramp-shell-quote-argument localname) command)) - ;; Set return status accordingly. - 0 1)) + (unwind-protect + (setq ret (tramp-adb-send-command-and-check + v (format + "(cd %s; %s)" + (tramp-shell-quote-argument localname) command) + t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -918,6 +822,12 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (> ret 128)) + (setq ret (nth (- ret 128) (tramp-get-signal-strings)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -936,6 +846,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-adb-handle-make-process (&rest args) "Like `make-process' for Tramp files." (when args @@ -969,17 +881,29 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) (command - (format "cd %s && exec %s" + (format "cd %s && exec %s %s" (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) (tramp-process-connection-type @@ -1029,6 +953,18 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Read initial output. Remove the first line, ;; which is the command echo. (while @@ -1037,6 +973,23 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (not (re-search-forward "[\n]" nil t))) (tramp-accept-process-output p 0)) (delete-region (point-min) (point)) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the process + ;; is deleted. The temporary file will exist + ;; until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) ;; Return process. p)))) @@ -1053,7 +1006,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) @@ -1062,17 +1015,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (read (current-buffer))) ":" 'omit))) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-adb-get-device (vec) "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)))) @@ -1146,11 +1095,14 @@ This happens for Android >= 4.0." (while (re-search-forward "\r+$" nil t) (replace-match "" nil nil)))))) -(defun tramp-adb-send-command-and-check (vec command) +(defun tramp-adb-send-command-and-check (vec command &optional exit-status) "Run COMMAND and check its exit status. Sends `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just sends `echo $?'. Returns nil if -the exit status is not equal 0, and t otherwise." +the exit status is not equal 0, and t otherwise. + +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-adb-send-command vec (if command (format "%s; echo tramp_exit_status $?" command) @@ -1161,7 +1113,9 @@ the exit status is not equal 0, and t otherwise." vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index b9bf6180a5d..9502cc35300 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -109,7 +109,7 @@ (eval-when-compile (require 'cl-lib)) ;; Sometimes, compilation fails with "Variable binding depth exceeds -;; max-specpdl-size". +;; max-specpdl-size". Shall be fixed in Emacs 27. (eval-and-compile (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) @@ -279,7 +279,9 @@ It must be supported by libarchive(3).") (start-file-process . tramp-archive-handle-not-implemented) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-archive-handle-temporary-file-directory) - ;; `tramp-set-file-uid-gid' performed by default handler. + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -318,7 +320,10 @@ arguments to pass to the OPERATION." (let* ((filename (apply #'tramp-archive-file-name-for-operation operation args)) - (archive (tramp-archive-file-name-archive filename))) + (archive (tramp-archive-file-name-archive filename)) + ;; Sometimes, it fails with "Variable binding depth exceeds + ;; max-specpdl-size". Shall be fixed in Emacs 27. + (max-specpdl-size (* 2 max-specpdl-size))) ;; `filename' could be a quoted file name. Or the file ;; archive could be a directory, see Bug#30293. @@ -350,7 +355,7 @@ arguments to pass to the OPERATION." (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) - (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))) + (put #'tramp-archive-autoload-file-name-handler 'safe-magic t)))) ;;;###autoload (progn @@ -366,7 +371,7 @@ arguments to pass to the OPERATION." (tramp-register-archive-file-name-handler) ;; Mark `operations' the handler is responsible for. -(put 'tramp-archive-file-name-handler 'operations +(put #'tramp-archive-file-name-handler 'operations (mapcar #'car tramp-archive-file-name-handler-alist)) ;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. @@ -517,13 +522,16 @@ offered." (declare (debug (form symbolp body)) (indent 2)) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(cons - 'archive - (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cons + 'archive + (delete + 'hop + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))))) `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 62e25fa1f08..970e2eea0ac 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -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)) @@ -122,31 +139,32 @@ Returns DEFAULT if not set." (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let* ((hash (tramp-get-hash-table key)) - (value (when (hash-table-p hash) (gethash property hash)))) - (if ;; We take the value only if there is any, and - ;; `remote-file-name-inhibit-cache' indicates that it is still - ;; valid. Otherwise, DEFAULT is set. - (and (consp value) + (cached (and (hash-table-p hash) (gethash property hash))) + (cached-at (and (consp cached) (format-time-string "%T" (car cached)))) + (value default) + cache-used) + + (when ;; We take the value only if there is any, and + ;; `remote-file-name-inhibit-cache' indicates that it is + ;; still valid. Otherwise, DEFAULT is set. + (and (consp cached) (or (null remote-file-name-inhibit-cache) (and (integerp remote-file-name-inhibit-cache) (time-less-p - ;; `current-time' can be nil once we get rid of Emacs 24. - (current-time) - (time-add - (car value) - ;; `seconds-to-time' can be removed once we get - ;; rid of Emacs 24. - (seconds-to-time remote-file-name-inhibit-cache)))) + nil + (time-add (car cached) remote-file-name-inhibit-cache))) (and (consp remote-file-name-inhibit-cache) (time-less-p - remote-file-name-inhibit-cache (car value))))) - (setq value (cdr value)) - (setq value default)) + remote-file-name-inhibit-cache (car cached))))) + (setq value (cdr cached) + cache-used t)) - (tramp-message key 8 "%s %s %s" file property value) + (tramp-message + key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" + file property value remote-file-name-inhibit-cache cache-used cached-at) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -157,7 +175,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)) @@ -170,7 +188,7 @@ Returns VALUE." (tramp-message key 8 "%s %s %s" file property value) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -202,13 +220,11 @@ Returns VALUE." key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) file (tramp-file-name-hop key) nil) - (maphash - (lambda (property _value) - (when (string-match-p - "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" - property) - (tramp-flush-file-property key file property))) - (tramp-get-hash-table key))))) + (dolist (property (hash-table-keys (tramp-get-hash-table key))) + (when (string-match-p + "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" + property) + (tramp-flush-file-property key file property)))))) ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) @@ -239,14 +255,12 @@ Remove also properties of all files in subdirectories." #'directory-file-name (list directory))) (truename (tramp-get-file-property key directory "file-truename" nil))) (tramp-message key 8 "%s" directory) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) - (remhash key tramp-cache-data))) - tramp-cache-data) + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (tramp-file-name-p key) + (stringp (tramp-file-name-localname key)) + (string-match-p (regexp-quote directory) + (tramp-file-name-localname key))) + (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) @@ -292,8 +306,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) @@ -301,15 +316,19 @@ value is not set for the connection, returns DEFAULT." (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) (let* ((hash (tramp-get-hash-table key)) - (value - ;; If the key is an auxiliary process object, check whether - ;; the process is still alive. - (if (and (processp key) (not (process-live-p key))) - default - (if (hash-table-p hash) - (gethash property hash default) - default)))) - (tramp-message key 7 "%s %s" property value) + (cached (if (hash-table-p hash) + (gethash property hash tramp-cache-undefined) + tramp-cache-undefined)) + (value default) + cache-used) + + (when (and (not (eq cached tramp-cache-undefined)) + ;; If the key is an auxiliary process object, check + ;; whether the process is still alive. + (not (and (processp key) (not (process-live-p key))))) + (setq value cached + cache-used t)) + (tramp-message key 7 "%s %s; cache used: %s" property value cache-used) value)) ;;;###tramp-autoload @@ -317,19 +336,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-file-name-p key))) + (tramp-message key 7 "%s %s" property value) + value) ;;;###tramp-autoload (defun tramp-connection-property-p (key property) @@ -337,7 +359,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) @@ -352,8 +375,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-file-name-p key))) (tramp-message key 7 "%s" property)) ;;;###tramp-autoload @@ -370,12 +395,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)) - properties) - (when (hash-table-p hash) - (maphash (lambda (x _y) (push x properties)) hash)) - properties)) - (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-file-name-p key))) (remhash key tramp-cache-data)) ;;;###tramp-autoload @@ -386,20 +409,15 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) ;; Remove text properties from KEY and VALUE. - ;; `cl-struct-slot-*' functions exist since Emacs 25 only; we - ;; ignore errors. (when (tramp-file-name-p key) - ;; (dolist - ;; (slot - ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) - ;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) - ;; (setf (cl-struct-slot-value 'tramp-file-name slot key) - ;; (substring-no-properties - ;; (cl-struct-slot-value 'tramp-file-name slot key)))))) - (dotimes (i (length key)) - (when (stringp (elt key i)) - (setf (elt key i) (substring-no-properties (elt key i)))))) - (when (stringp key) + (dolist + (slot + (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) + (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) + (setf (cl-struct-slot-value 'tramp-file-name slot key) + (substring-no-properties + (cl-struct-slot-value 'tramp-file-name slot key)))))) + (when (stringp key) (setq key (substring-no-properties key))) (when (stringp value) (setq value (substring-no-properties value))) @@ -421,18 +439,18 @@ used to cache connection properties of the local machine." ;;;###tramp-autoload (defun tramp-list-connections () "Return all known `tramp-file-name' structs according to `tramp-cache'." - (let (result tramp-verbose) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (null (tramp-file-name-localname key)) - (tramp-connection-property-p key "process-buffer")) - (push key result))) - tramp-cache-data) - result)) + (let ((tramp-verbose 0)) + (delq nil (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (null (tramp-file-name-localname key)) + (tramp-connection-property-p key "process-buffer") + key)) + (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) @@ -464,15 +482,10 @@ used to cache connection properties of the local machine." ;; Dump it. (with-temp-file tramp-persistency-file-name (insert - ";; -*- emacs-lisp -*-" - ;; `time-stamp-string' might not exist in all Emacs flavors. - (condition-case nil - (progn - (format - " <%s %s>\n" - (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") - tramp-persistency-file-name)) - (error "\n")) + ;; Starting with Emacs 28, we could use `lisp-data'. + (format ";; -*- emacs-lisp -*- <%s %s>\n" + (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") + tramp-persistency-file-name) ";; Tramp connection history. Don't change this file.\n" ";; Run `M-x tramp-cleanup-all-connections' instead.\n\n" (with-output-to-string @@ -490,17 +503,14 @@ used to cache connection properties of the local machine." "Return a list of (user host) tuples allowed to access for METHOD. This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from connection history." - (let (res) - (maphash - (lambda (key _value) - (if (and (tramp-file-name-p key) - (string-equal method (tramp-file-name-method key)) - (not (tramp-file-name-localname key))) - (push (list (tramp-file-name-user key) - (tramp-file-name-host key)) - res))) - tramp-cache-data) - res)) + (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (string-equal method (tramp-file-name-method key)) + (not (tramp-file-name-localname key)) + (list (tramp-file-name-user key) + (tramp-file-name-host key)))) + (hash-table-keys tramp-cache-data))) ;; When "emacs -Q" has been called, both variables are nil. We do not ;; load the persistency file then, in order to have a clean test environment. @@ -514,7 +524,7 @@ for all methods. Resulting data are derived from connection history." tramp-cache-read-persistent-data) (condition-case err (with-temp-buffer - (insert-file-contents tramp-persistency-file-name) + (insert-file-contents-literally tramp-persistency-file-name) (let ((list (read (current-buffer))) (tramp-verbose 0) element key item) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 9d1025b9072..2805f6648ce 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -74,11 +74,13 @@ SYNTAX can be one of the symbols `default' (default), Each function is called with the current vector as argument.") ;;;###tramp-autoload -(defun tramp-cleanup-connection (vec &optional keep-debug keep-password) +(defun tramp-cleanup-connection + (vec &optional keep-debug keep-password keep-processes) "Flush all connection related objects. This includes password cache, file cache, connection cache, -buffers. KEEP-DEBUG non-nil preserves the debug buffer. -KEEP-PASSWORD non-nil preserves the password cache. +buffers, processes. KEEP-DEBUG non-nil preserves the debug +buffer. KEEP-PASSWORD non-nil preserves the password cache. +KEEP-PROCESSES non-nil preserves the asynchronous processes. When called interactively, a Tramp connection has to be selected." (interactive ;; When interactive, select the Tramp remote identification. @@ -107,21 +109,21 @@ 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) + (or (not keep-processes) + (eq key (tramp-get-process vec)))) + (tramp-flush-connection-properties key) + (delete-process key))) + ;; Remove buffers. (dolist (buf (list (get-buffer (tramp-buffer-name vec)) @@ -130,6 +132,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))) @@ -176,8 +184,9 @@ This includes password cache, file cache, connection cache, buffers." ;; Cancel timers. (cancel-function-timers 'tramp-timeout-session) - ;; Remove buffers. + ;; Remove processes and buffers. (dolist (name (tramp-list-tramp-buffers)) + (when (processp (get-buffer-process name)) (delete-process name)) (when (bufferp (get-buffer name)) (kill-buffer name))) ;; The end. @@ -358,7 +367,7 @@ The remote connection identified by SOURCE is flushed by ;; Append local file name if none is specified. (when (string-equal (file-remote-p target) target) - (setq target (concat target (file-remote-p source 'localname)))) + (setq target (concat target (tramp-file-local-name source)))) ;; Make them directory names. (setq source (directory-file-name source) target (directory-file-name target)) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 723b8cfa1e3..218594b551c 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,15 +23,15 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 27. This -;; package provides compatibility functions for Emacs 24, Emacs 25 and -;; Emacs 26. +;; Tramp's main Emacs version for development is Emacs 28. This +;; package provides compatibility functions for Emacs 25, Emacs 26 and +;; Emacs 27. ;;; Code: -;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not -;; autoloaded. So we declare it here in order to avoid recursive -;; load. This will be overwritten in tramp.el. +;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. +;; So we declare it here in order to avoid recursive load. This will +;; be overwritten in tramp.el. (defun tramp-unload-file-name-handlers () ".") (require 'auth-source) @@ -41,7 +41,9 @@ (require 'shell) (require 'subr-x) +;; `temporary-file-directory' as function is introduced with Emacs 26.1. (declare-function tramp-handle-temporary-file-directory "tramp") +(defvar tramp-temp-name-prefix) ;; For not existing functions, obsolete functions, or functions with a ;; changed argument list, there are compiler warnings. We want to @@ -51,6 +53,8 @@ `(when (functionp ,function) (with-no-warnings (funcall ,function ,@arguments)))) +(put #'tramp-compat-funcall 'tramp-suppress-trace t) + (defsubst tramp-compat-temporary-file-directory () "Return name of directory for temporary files. It is the default value of `temporary-file-directory'." @@ -58,15 +62,19 @@ It is the default value of `temporary-file-directory'." ;; into an infloop. (eval (car (get 'temporary-file-directory 'standard-value)))) +(defsubst tramp-compat-make-temp-name () + "Generate a local temporary file name (compat function)." + (make-temp-name + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) + (defsubst tramp-compat-make-temp-file (f &optional dir-flag) "Create a local temporary file (compat function). Add the extension of F, if existing." - (let* (file-name-handler-alist - (prefix (expand-file-name - (symbol-value 'tramp-temp-name-prefix) - (tramp-compat-temporary-file-directory))) - (extension (file-name-extension f t))) - (make-temp-file prefix dir-flag extension))) + (make-temp-file + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)) + dir-flag (file-name-extension f t))) ;; `temporary-file-directory' as function is introduced with Emacs 26.1. (defalias 'tramp-compat-temporary-file-directory-function @@ -74,31 +82,7 @@ Add the extension of F, if existing." #'temporary-file-directory #'tramp-handle-temporary-file-directory)) -(defun tramp-compat-process-running-p (process-name) - "Return t if system process PROCESS-NAME is running for `user-login-name'." - (when (stringp process-name) - (cond - ;; GNU Emacs 22 on w32. - ((fboundp 'w32-window-exists-p) - (tramp-compat-funcall 'w32-window-exists-p process-name process-name)) - - ;; GNU Emacs 23+. - ((and (fboundp 'list-system-processes) (fboundp 'process-attributes)) - (let (result) - (dolist (pid (tramp-compat-funcall 'list-system-processes) result) - (let ((attributes (process-attributes pid))) - (when (and (string-equal - (cdr (assoc 'user attributes)) (user-login-name)) - (let ((comm (cdr (assoc 'comm attributes)))) - ;; The returned command name could be truncated - ;; to 15 characters. Therefore, we cannot check - ;; for `string-equal'. - (and comm (string-match-p - (concat "^" (regexp-quote comm)) - process-name)))) - (setq result t))))))))) - -;; `file-attribute-*' are introduced in Emacs 25.1. +;; `file-attribute-*' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-attribute-type (if (fboundp 'file-attribute-type) @@ -180,31 +164,13 @@ and later, and is a float in Emacs 26 and earlier." This is a string of ten letters or dashes as in ls -l." (nth 8 attributes)))) -;; `format-message' is new in Emacs 25.1. -(unless (fboundp 'format-message) - (defalias 'format-message #'format)) - -;; `directory-name-p' is new in Emacs 25.1. -(defalias 'tramp-compat-directory-name-p - (if (fboundp 'directory-name-p) - #'directory-name-p - (lambda (name) - "Return non-nil if NAME ends with a directory separator character." - (let ((len (length name)) - (lastc ?.)) - (if (> len 0) - (setq lastc (aref name (1- len)))) - (or (= lastc ?/) - (and (memq system-type '(windows-nt ms-dos)) - (= lastc ?\\))))))) - ;; `file-missing' is introduced in Emacs 26.1. (defconst tramp-file-missing (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") ;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26. +;; `file-name-unquote' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-local-name (if (fboundp 'file-local-name) #'file-local-name @@ -214,7 +180,8 @@ It returns a file name which can be used directly as argument of `process-file', `start-file-process', or `shell-command'." (or (file-remote-p name 'localname) name)))) -;; `file-name-quoted-p' got a second argument in Emacs 27.1. +;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got +;; a second argument in Emacs 27.1. (defalias 'tramp-compat-file-name-quoted-p (if (and (fboundp 'file-name-quoted-p) @@ -256,7 +223,7 @@ NAME is unquoted." localname (if (= (length localname) 2) "/" (substring localname 2)))) (concat (file-remote-p name) localname))))) -;; `tramp-syntax' has changed its meaning in Emacs 26. We still +;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still ;; support old settings. (defsubst tramp-compat-tramp-syntax () "Return proper value of `tramp-syntax'." @@ -265,13 +232,6 @@ NAME is unquoted." ((eq tramp-syntax 'sep) 'separate) (t tramp-syntax))) -;; `cl-struct-slot-info' has been introduced with Emacs 25. -(defmacro tramp-compat-tramp-file-name-slots () - "Return a list of slot names." - (if (fboundp 'cl-struct-slot-info) - '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))) - '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots))))) - ;; The signature of `tramp-make-tramp-file-name' has been changed. ;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior ;; Emacs 26.1. We use `temporary-file-directory' as indicator. @@ -284,10 +244,9 @@ NAME is unquoted." #'exec-path (lambda () "List of directories to search programs to run in remote subprocesses." - (let ((handler (find-file-name-handler default-directory 'exec-path))) - (if handler - (funcall handler 'exec-path) - exec-path))))) + (if-let ((handler (find-file-name-handler default-directory 'exec-path))) + (funcall handler 'exec-path) + exec-path)))) ;; `time-equal-p' has appeared in Emacs 27.1. (defalias 'tramp-compat-time-equal-p @@ -322,16 +281,38 @@ A nil value for either argument stands for the current time." (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) +;; `file-modes', `set-file-modes' and `set-file-times' got argument +;; FLAG in Emacs 28.1. +(defalias 'tramp-compat-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) + #'file-modes + (lambda (filename &optional _flag) + (file-modes filename)))) + +(defalias 'tramp-compat-set-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) + #'set-file-modes + (lambda (filename mode &optional _flag) + (set-file-modes filename mode)))) + +(defalias 'tramp-compat-set-file-times + (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) + #'set-file-times + (lambda (filename &optional timestamp _flag) + (set-file-times filename timestamp)))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-loaddefs 'force) (unload-feature 'tramp-compat 'force))) +(provide 'tramp-compat) + ;;; TODO: ;; -;; * Starting with Emacs 25.1, replace `tramp-message-show-message' by -;; the reverse of `inhibit-message'. - -(provide 'tramp-compat) +;; * `func-arity' exists since Emacs 26.1. +;; +;; * Starting with Emacs 27.1, there's no need to escape open +;; parentheses with a backslash in docstrings anymore. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el new file mode 100644 index 00000000000..c9788fcff52 --- /dev/null +++ b/lisp/net/tramp-crypt.el @@ -0,0 +1,838 @@ +;;; tramp-crypt.el --- Tramp crypt utilities -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Access functions for crypted remote files. It uses encfs to +;; encrypt / decrypt the files on a remote directory. A remote +;; directory, which shall include crypted files, must be declared in +;; `tramp-crypt-directories' via command `tramp-crypt-add-directory'. +;; All files in that directory, including all subdirectories, are +;; stored there encrypted. This includes file names and directory +;; names. + +;; This package is just responsible for the encryption part. Copying +;; of the crypted files is still the responsibility of the remote file +;; name handlers. + +;; A password protected encfs configuration file is created the very +;; first time you access a crypted remote directory. It is kept in +;; your user directory "~/.emacs.d/" with the url-encoded directory +;; name as part of the basename, and ".encfs6.xml" as suffix. Do not +;; loose this file and the corresponding password; otherwise there is +;; no way to decrypt your crypted files. + +;; If the user option `tramp-crypt-save-encfs-config-remote' is +;; non-nil (the default), the encfs configuration file ".encfs6.xml" +;; is also kept in the crypted remote directory. It depends on you, +;; whether you regard the password protection of this file as +;; sufficient. + +;; If you use a remote file name with a quoted localname part, this +;; localname and the corresponding file will not be encrypted/ +;; decrypted. For example, if you have a crypted remote directory +;; "/nextcloud:user@host:/crypted_dir", the command +;; +;; C-x d /nextcloud:user@host:/crypted_dir +;; +;; will show the directory listing with the plain file names, and the +;; command +;; +;; C-x d /nextcloud:user@host:/:/crypted_dir +;; +;; will show the directory with the encrypted file names, and visiting +;; a file will show its crypted contents. However, it is highly +;; discouraged to mix crypted and not crypted files in the same +;; directory. + +;; If a remote directory shall not include crypted files anymore, it +;; must be indicated by the command `tramp-crypt-remove-directory'. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp) + +(autoload 'prop-match-beginning "text-property-search") +(autoload 'prop-match-end "text-property-search") +(autoload 'text-property-search-forward "text-property-search") + +(defconst tramp-crypt-method "crypt" + "Method name for crypted remote directories.") + +(defcustom tramp-crypt-encfs-program "encfs" + "Name of the encfs program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfsctl-program "encfsctl" + "Name of the encfsctl program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfs-option "--standard" + "Configuration option for encfs. +This could be either \"--standard\" or \"--paranoia\". The file +name IV chaining mode mode will always be disabled when +initializing a new crypted remote directory." + :group 'tramp + :version "28.1" + :type '(choice (const "--standard") + (const "--paranoia"))) + +;; We check only for encfs, assuming that encfsctl will be available +;; as well. The autoloaded value is nil, the check will run when +;; tramp-crypt.el is loaded by `tramp-crypt-add-directory'. It is a +;; common technique to let-bind this variable to nil in order to +;; suppress the file name operation of this package. +;;;###tramp-autoload +(defvar tramp-crypt-enabled nil + "Non-nil when encryption support is available.") +(setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program)) + +;;;###tramp-autoload +(defconst tramp-crypt-encfs-config ".encfs6.xml" + "Encfs configuration file name.") + +(defcustom tramp-crypt-save-encfs-config-remote t + "Whether to keep the encfs configuration file in the crypted remote directory." + :group 'tramp + :version "28.1" + :type 'booleanp) + +;;;###tramp-autoload +(defvar tramp-crypt-directories nil + "List of crypted remote directories.") + +;; It must be a `defsubst' in order to push the whole code into +;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. +;;;###tramp-autoload +(defsubst tramp-crypt-file-name-p (name) + "Return the crypted remote directory NAME belongs to. +If NAME doesn't belong to a crypted remote directory, retun nil." + (catch 'crypt-file-name-p + (and tramp-crypt-enabled (stringp name) + (not (tramp-compat-file-name-quoted-p name)) + (not (string-suffix-p tramp-crypt-encfs-config name)) + (dolist (dir tramp-crypt-directories) + (and (string-prefix-p + dir (file-name-as-directory (expand-file-name name))) + (throw 'crypt-file-name-p dir)))))) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-crypt-file-name-handler-alist + '((access-file . tramp-crypt-handle-access-file) + (add-name-to-file . tramp-handle-add-name-to-file) + ;; `byte-compiler-base-file-name' performed by default handler. + (copy-directory . tramp-handle-copy-directory) + (copy-file . tramp-crypt-handle-copy-file) + (delete-directory . tramp-crypt-handle-delete-directory) + (delete-file . tramp-crypt-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + ;; `directory-file-name' performed by default handler. + (directory-files . tramp-crypt-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-crypt-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-crypt-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-crypt-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . tramp-crypt-handle-file-ownership-preserved-p) + (file-readable-p . tramp-crypt-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . ignore) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-crypt-handle-file-system-info) + ;; `file-truename' performed by default handler. + (file-writable-p . tramp-crypt-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-crypt-handle-insert-directory) + ;; `insert-file-contents' performed by default handler. + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-crypt-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-crypt-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . tramp-crypt-handle-set-file-modes) + (set-file-selinux-context . ignore) + (set-file-times . tramp-crypt-handle-set-file-times) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . ignore) + (start-file-process . ignore) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-handle-temporary-file-directory) + ;; `tramp-get-remote-gid' performed by default handler. + ;; `tramp-get-remote-uid' performed by default handler. + (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-handle-write-region)) + "Alist of handler functions for crypt method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +(defsubst tramp-crypt-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for crypted remote files." + (let ((tfnfo (apply #'tramp-file-name-for-operation operation args))) + ;; `tramp-file-name-for-operation' returns already the first argument + ;; if it is remote. So we check a possible second argument. + (unless (tramp-crypt-file-name-p tfnfo) + (setq tfnfo (apply + #'tramp-file-name-for-operation operation + (cons (tramp-compat-temporary-file-directory) (cdr args))))) + tfnfo)) + +(defun tramp-crypt-run-real-handler (operation args) + "Invoke normal file name handler for OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (let* ((inhibit-file-name-handlers + `(tramp-crypt-file-name-handler + . + ,(and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;;;###tramp-autoload +(defun tramp-crypt-file-name-handler (operation &rest args) + "Invoke the crypted remote file related OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (if-let ((filename + (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))) + +;;;###tramp-autoload +(progn (defun tramp-register-crypt-file-name-handler () + "Add crypt file name handler to `file-name-handler-alist'." + (when (and tramp-crypt-enabled tramp-crypt-directories) + (add-to-list 'file-name-handler-alist + (cons tramp-file-name-regexp #'tramp-crypt-file-name-handler)) + (put #'tramp-crypt-file-name-handler 'safe-magic t)))) + +(tramp-register-file-name-handlers) + +;; Mark `operations' the handler is responsible for. +(put #'tramp-crypt-file-name-handler 'operations + (mapcar #'car tramp-crypt-file-name-handler-alist)) + + +;; File name conversions. + +(defun tramp-crypt-config-file-name (vec) + "Return the encfs config file name for VEC." + (expand-file-name + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config) + user-emacs-directory)) + +(defun tramp-crypt-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +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))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil))) + + ;; The following operations must be performed w/o + ;; `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. + (when (not (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 + "<chainedNameIV>1</chainedNameIV>" nil 'noerror) + (replace-match "<chainedNameIV>0</chainedNameIV>"))) + + ;; 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. +ARGS are the arguments. It returns t if ran successful, and nil otherwise." + (tramp-crypt-maybe-open-connection vec) + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (set-buffer-multibyte nil)) + (with-temp-buffer + (let* (;; Don't check for a proper method. + (non-essential t) + (default-directory (tramp-compat-temporary-file-directory)) + ;; We cannot add it to `process-environment', because + ;; `tramp-call-process-region' doesn't use it. + (encfs-config + (format "ENCFS6_CONFIG=%s" (tramp-crypt-config-file-name vec))) + (args (delq nil args))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format "EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when (zerop + (apply + #'tramp-call-process-region vec (point-min) (point-max) + "env" nil (tramp-get-connection-buffer vec) + nil encfs-config tramp-crypt-encfsctl-program + (car args) "--extpass=cat" (cdr args))) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))) + t)))) + +(defun tramp-crypt-do-encrypt-or-decrypt-file-name (op name) + "Return encrypted / decrypted NAME if NAME belongs to a crypted directory. +OP must be `encrypt' or `decrypt'. Raise an error if this fails. +Otherwise, return NAME." + (if-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p name)) + ;; It must be absolute for the cache. + (localname (substring name (1- (length dir)))) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + ;; Preserve trailing "/". + (funcall + (if (directory-name-p name) #'file-name-as-directory #'identity) + (concat + dir + (unless (string-equal localname "/") + (with-tramp-file-property + crypt-vec localname (concat (symbol-name op) "-file-name") + (unless (tramp-crypt-send-command + crypt-vec (if (eq op 'encrypt) "encode" "decode") + (tramp-compat-temporary-file-directory) localname) + (tramp-error + crypt-vec 'file-error "%s of file name %s failed." + (if (eq op 'encrypt) "Encoding" "Decoding") name)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (goto-char (point-min)) + (buffer-substring (point-min) (point-at-eol))))))) + ;; Nothing to do. + name)) + +(defsubst tramp-crypt-encrypt-file-name (name) + "Return encrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'encrypt name)) + +(defsubst tramp-crypt-decrypt-file-name (name) + "Return decrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'decrypt name)) + +(defun tramp-crypt-do-encrypt-or-decrypt-file (op root infile outfile) + "Encrypt / decrypt file INFILE to OUTFILE according to crypted directory ROOT. +Both files must be local files. OP must be `encrypt' or `decrypt'. +If OP ist `decrypt', the basename of INFILE must be an encrypted file name. +Raise an error if this fails." + (when-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p root)) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + (let ((coding-system-for-read + (if (eq op 'decrypt) 'binary coding-system-for-read)) + (coding-system-for-write + (if (eq op 'encrypt) 'binary coding-system-for-write))) + (unless (tramp-crypt-send-command + crypt-vec "cat" (and (eq op 'encrypt) "--reverse") + (file-name-directory infile) + (concat "/" (file-name-nondirectory infile))) + (tramp-error + crypt-vec 'file-error "%s of file %s failed." + (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (write-region nil nil outfile))))) + +(defsubst tramp-crypt-encrypt-file (root infile outfile) + "Encrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'encrypt root infile outfile)) + +(defsubst tramp-crypt-decrypt-file (root infile outfile) + "Decrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'decrypt root infile outfile)) + +;;;###tramp-autoload +(defun tramp-crypt-add-directory (name) + "Mark remote directory NAME for encryption. +Files in that directory and all subdirectories will be encrypted +before copying to, and decrypted after copying from that +directory. File names will be also encrypted." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (unless (and (tramp-tramp-file-p name) (file-directory-p name)) + (tramp-user-error nil "%s must be an existing remote directory." name)) + (when (tramp-compat-file-name-quoted-p name) + (tramp-user-error nil "%s must not be quoted." name)) + (setq name (file-name-as-directory (expand-file-name name))) + (unless (member name tramp-crypt-directories) + (setq tramp-crypt-directories (cons name tramp-crypt-directories))) + (tramp-register-file-name-handlers)) + +(defun tramp-crypt-remove-directory (name) + "Unmark remote directory NAME for encryption. +Existing files in that directory and its subdirectories will be +kept in their encrypted form." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (setq name (file-name-as-directory (expand-file-name name))) + (when (and (member name tramp-crypt-directories) + (delete + tramp-crypt-encfs-config + (directory-files name nil directory-files-no-dot-files-regexp)) + (yes-or-no-p + "There exist encrypted files, do you want to continue? ")) + (setq tramp-crypt-directories (delete name tramp-crypt-directories)) + (tramp-register-file-name-handlers))) + +;; `auth-source' requires a user. +(defun tramp-crypt-dissect-file-name (name) + "Return a `tramp-file-name' structure for NAME. +The structure consists of the `tramp-crypt-method' method, the +local user name, the hexlified directory NAME as host, and the +localname." + (save-match-data + (if-let ((dir (tramp-crypt-file-name-p name))) + (make-tramp-file-name + :method tramp-crypt-method :user (user-login-name) + :host (url-hexify-string dir)) + (tramp-user-error nil "Not a crypted remote directory: \"%s\"" name)))) + +(defun tramp-crypt-get-remote-dir (vec) + "Return the name of the crypted remote directory to be used for encfs." + (url-unhex-string (tramp-file-name-host vec))) + + +;; File name primitives. + +(defun tramp-crypt-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-regexp (concat (regexp-quote encrypt-filename) "\\'")) + tramp-crypt-enabled) + (condition-case err + (access-file encrypt-filename string) + (error + (when (and (eq (car err) 'file-missing) (stringp (cadr err)) + (string-match-p encrypt-regexp (cadr err))) + (setcar + (cdr err) + (replace-regexp-in-string encrypt-regexp filename (cadr err)))) + (signal (car err) (cdr err)))))) + +(defun tramp-crypt-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-crypt-handle-copy-file' and +`tramp-crypt-handle-rename-file'. It is an error if OP is +neither of `copy' and `rename'. FILENAME and NEWNAME must be +absolute file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (let ((t1 (tramp-crypt-file-name-p filename)) + (t2 (tramp-crypt-file-name-p newname)) + (encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-newname (tramp-crypt-encrypt-file-name newname)) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) + (delete-directory filename 'recursive))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (unless (file-exists-p filename) + (tramp-error + v tramp-file-missing + "%s file" msg-operation "No such file or directory" filename)) + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (if (and t1 t2 (string-equal t1 t2)) + ;; Both files are on the same crypted remote directory. + (let (tramp-crypt-enabled) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + + (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) + (tmpfile1 + (expand-file-name + (file-name-nondirectory encrypt-filename) tmpdir)) + (tmpfile2 + (expand-file-name + (file-name-nondirectory encrypt-newname) tmpdir)) + tramp-crypt-enabled) + (cond + ;; Source and target file are on a crypted remote directory. + ((and t1 t2) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + ;; Source file is on a crypted remote directory. + (t1 + (if (eq op 'copy) + (copy-file + encrypt-filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file encrypt-filename tmpfile1 t)) + (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) + (rename-file tmpfile2 newname ok-if-already-exists)) + ;; Target file is on a crypted remote directory. + (t2 + (if (eq op 'copy) + (copy-file + filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile1 t)) + (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2) + (rename-file tmpfile2 encrypt-newname ok-if-already-exists))) + (delete-directory tmpdir 'recursive)))))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))) + +(defun tramp-crypt-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-crypt-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-crypt-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (tramp-flush-directory-properties v localname) + (let (tramp-crypt-enabled) + (delete-directory + (tramp-crypt-encrypt-file-name directory) recursive trash)))) + +(defun tramp-crypt-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (delete-file (tramp-crypt-encrypt-file-name filename) trash)))) + +(defun tramp-crypt-handle-directory-files (directory &optional full match nosort) + "Like `directory-files' for Tramp files." + (unless (file-exists-p directory) + (tramp-error + (tramp-dissect-file-name directory) tramp-file-missing + "No such file or directory" directory)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let* (tramp-crypt-enabled + (result + (directory-files (tramp-crypt-encrypt-file-name directory) 'full))) + (setq result + (mapcar (lambda (x) (tramp-crypt-decrypt-file-name x)) result)) + (when match + (setq result + (delq + nil + (mapcar + (lambda (x) + (when (string-match-p match (substring x (length directory))) + x)) + result)))) + (unless full + (setq result + (mapcar + (lambda (x) + (replace-regexp-in-string + (concat "^" (regexp-quote directory)) "" x)) + result))) + (if nosort result (sort result #'string<))))) + +(defun tramp-crypt-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (let (tramp-crypt-enabled) + (file-attributes (tramp-crypt-encrypt-file-name filename) id-format))) + +(defun tramp-crypt-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-executable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (let* (completion-regexp-list + tramp-crypt-enabled + (directory (file-name-as-directory directory)) + (enc-dir (tramp-crypt-encrypt-file-name directory))) + (mapcar + (lambda (x) + (substring + (tramp-crypt-decrypt-file-name (concat enc-dir x)) + (length directory))) + (file-name-all-completions "" enc-dir))))) + +(defun tramp-crypt-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-readable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-ownership-preserved-p (filename &optional group) + "Like `file-ownership-preserved-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-ownership-preserved-p (tramp-crypt-encrypt-file-name filename) group))) + +(defun tramp-crypt-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (let (tramp-crypt-enabled) + ;; `file-system-info' exists since Emacs 27.1. + (tramp-compat-funcall + 'file-system-info (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-writable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files. +WILDCARD is not supported." + ;; This package has been added to Emacs 27.1. + (when (load "text-property-search" 'noerror 'nomessage) + (let (tramp-crypt-enabled) + (tramp-handle-insert-directory + (tramp-crypt-encrypt-file-name filename) + switches wildcard full-directory-p) + (let* ((filename (file-name-as-directory filename)) + (enc (tramp-crypt-encrypt-file-name filename)) + match string) + (goto-char (point-min)) + (while (setq match (text-property-search-forward 'dired-filename t t)) + (setq string + (buffer-substring + (prop-match-beginning match) (prop-match-end match)) + string (if (file-name-absolute-p string) + (tramp-crypt-decrypt-file-name string) + (substring + (tramp-crypt-decrypt-file-name (concat enc string)) + (length filename)))) + (delete-region (prop-match-beginning match) (prop-match-end match)) + (insert (propertize string 'dired-filename t))))))) + +(defun tramp-crypt-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (when (and (null parents) (file-exists-p dir)) + (tramp-error v 'file-already-exists "Directory already exists %s" dir)) + (let (tramp-crypt-enabled) + (make-directory (tramp-crypt-encrypt-file-name dir) parents)) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))))) + +(defun tramp-crypt-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-crypt-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) + (tramp-run-real-handler + #'rename-file (list filename newname ok-if-already-exists)))) + +(defun tramp-crypt-handle-set-file-modes (filename mode &optional flag) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-modes + (tramp-crypt-encrypt-file-name filename) mode flag)))) + +(defun tramp-crypt-handle-set-file-times (filename &optional time flag) + "Like `set-file-times' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-times + (tramp-crypt-encrypt-file-name filename) time flag)))) + +(defun tramp-crypt-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-set-file-uid-gid + (tramp-crypt-encrypt-file-name filename) uid gid)))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-crypt 'force))) + +(provide 'tramp-crypt) + +;;; TODO: + +;; * I suggest having a feature where the user can specify to always +;; use encryption for certain host names. So if you specify a host +;; name which is on that list (of names, or perhaps regexps?), tramp +;; would modify the request so as to do the encryption. (Richard Stallman) + +;;; tramp-crypt.el ends here diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 34a234c47f0..dce6edd19c4 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -49,11 +49,15 @@ ;; The user option `tramp-gvfs-methods' contains the list of supported ;; connection methods. Per default, these are "afp", "dav", "davs", -;; "gdrive", "nextcloud" and "sftp". +;; "gdrive", "media", "nextcloud" and "sftp". ;; "gdrive" and "nextcloud" connection methods require a respective ;; account in GNOME Online Accounts, with enabled "Files" service. +;; The "media" connection method is responsible for media devices, +;; like cell phones, tablets, cameras etc. The device must already be +;; connected via USB, before accessing it. + ;; Other possible connection methods are "ftp", "http", "https" and ;; "smb". When one of these methods is added to the list, the remote ;; access for that method is performed via GVFS instead of the native @@ -121,16 +125,19 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (or (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) + (or ;; Until Emacs 25, `process-attributes' could crash Emacs + ;; for some processes. Better we don't check. + (<= emacs-major-version 25) + (tramp-process-running-p "gvfs-fuse-daemon") + (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp") + '("afp" "dav" "davs" "gdrive" "media" "nextcloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "27.1" + :version "28.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") @@ -138,10 +145,12 @@ (const "gdrive") (const "http") (const "https") + (const "media") (const "nextcloud") (const "sftp") (const "smb")))) +;;;###tramp-autoload (defconst tramp-goa-methods '("gdrive" "nextcloud") "List of methods which require registration at GNOME Online Accounts.") @@ -151,15 +160,23 @@ (dolist (method tramp-goa-methods) (setq tramp-gvfs-methods (delete method tramp-gvfs-methods)))) -;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'. ;;;###tramp-autoload -(tramp--with-startup - (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" - user-mail-address) - (add-to-list 'tramp-default-user-alist - `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) - (add-to-list 'tramp-default-host-alist - '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))) +(defvar tramp-media-methods '("afc" "gphoto2" "mtp") + "List of GVFS methods which are covered by the \"media\" method. +They are checked during start up via +`tramp-gvfs-interface-remotevolumemonitor'.") + +(defsubst tramp-gvfs-service-volumemonitor (method) + "Return the well known name of the volume monitor responsible for METHOD." + (symbol-value + (intern-soft (format "tramp-gvfs-service-%s-volumemonitor" method)))) + +;; Remove media methods if not supported. +(when tramp-gvfs-enabled + (dolist (method tramp-media-methods) + (unless (member (tramp-gvfs-service-volumemonitor method) + (dbus-list-known-names :session)) + (setq tramp-media-methods (delete method tramp-media-methods))))) ;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -169,13 +186,15 @@ :type 'string) ;; Add the methods to `tramp-methods', in order to allow minibuffer -;; completion. +;; completion. Add defaults for `tramp-default-host-alist'. ;;;###tramp-autoload (when (featurep 'dbusbind) (tramp--with-startup - (dolist (elt tramp-gvfs-methods) - (unless (assoc elt tramp-methods) - (add-to-list 'tramp-methods (cons elt nil)))))) + (dolist (method tramp-gvfs-methods) + (unless (assoc method tramp-methods) + (add-to-list 'tramp-methods `(,method))) + (when (member method tramp-goa-methods) + (add-to-list 'tramp-default-host-alist `(,method nil "")))))) (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceding object path for own objects.") @@ -457,8 +476,209 @@ It has been changed in GVFS 1.14.") ;; </interface> ;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 24 and 25. -(cl-defstruct (tramp-goa-name (:type list) :named) method user host port) +;; in order to be compatible with Emacs 25. +(cl-defstruct (tramp-goa-account (:type list) :named) method user host port) + +;;;###tramp-autoload +(defconst tramp-gvfs-service-afc-volumemonitor "org.gtk.vfs.AfcVolumeMonitor" + "The well known name of the AFC volume monitor.") + +;; This one is not needed yet. +(defconst tramp-gvfs-service-goa-volumemonitor "org.gtk.vfs.GoaVolumeMonitor" + "The well known name of the GOA volume monitor.") + +;;;###tramp-autoload +(defconst tramp-gvfs-service-gphoto2-volumemonitor + "org.gtk.vfs.GPhoto2VolumeMonitor" + "The well known name of the GPhoto2 volume monitor.") + +;;;###tramp-autoload +(defconst tramp-gvfs-service-mtp-volumemonitor "org.gtk.vfs.MTPVolumeMonitor" + "The well known name of the MTP volume monitor.") + +(defconst tramp-gvfs-path-remotevolumemonitor + "/org/gtk/Private/RemoteVolumeMonitor" + "The object path of the remote volume monitor.") + +(defconst tramp-gvfs-interface-remotevolumemonitor + "org.gtk.Private.RemoteVolumeMonitor" + "The volume monitor interface.") + +;; <interface name='org.gtk.Private.RemoteVolumeMonitor'> +;; <method name="IsSupported"> +;; <arg type='b' name='is_supported' direction='out'/> +;; </method> +;; <method name="List"> +;; <arg type='a(ssssbbbbbbbbuasa{ss}sa{sv})' name='drives' direction='out'/> +;; <arg type='a(ssssssbbssa{ss}sa{sv})' name='volumes' direction='out'/> +;; <arg type='a(ssssssbsassa{sv})' name='mounts' direction='out'/> +;; </method> +;; <method name="CancelOperation"> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='b' name='was_cancelled' direction='out'/> +;; </method> +;; <method name="MountUnmount"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="VolumeMount"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='mount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DriveEject"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DrivePollForMedia"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; </method> +;; <method name="DriveStart"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DriveStop"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="MountOpReply"> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; <arg type='i' name='result' direction='in'/> +;; <arg type='s' name='user_name' direction='in'/> +;; <arg type='s' name='domain' direction='in'/> +;; <arg type='s' name='encoded_password' direction='in'/> +;; <arg type='i' name='password_save' direction='in'/> +;; <arg type='i' name='choice' direction='in'/> +;; <arg type='b' name='anonymous' direction='in'/> +;; </method> +;; <signal name="DriveChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveConnected"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveDisconnected"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveEjectButton"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveStopButton"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="VolumeChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="VolumeAdded"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="VolumeRemoved"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="MountChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountAdded"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountPreUnmount"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountRemoved"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountOpAskPassword"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='s' name='default_user'/> +;; <arg type='s' name='default_domain'/> +;; <arg type='u' name='flags'/> +;; </signal> +;; <signal name="MountOpAskQuestion"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='as' name='choices'/> +;; </signal> +;; <signal name="MountOpShowProcesses"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='ai' name='pid'/> +;; <arg type='as' name='choices'/> +;; </signal> +;; <signal name="MountOpShowUnmountProgress"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='x' name='time_left'/> +;; <arg type='x' name='bytes_left'/> +;; </signal> +;; <signal name="MountOpAborted"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; </signal> +;; </interface> + +;; STRUCT volume +;; STRING id +;; STRING name +;; STRING gicon_data +;; STRING symbolic_gicon_data +;; STRING uuid +;; STRING activation_uri +;; BOOLEAN can-mount +;; BOOLEAN should-automount +;; STRING drive-id +;; STRING mount-id +;; ARRAY identifiers +;; DICT +;; STRING key (unix-device, class, uuid, ...) +;; STRING value +;; STRING sort_key +;; ARRAY expansion +;; DICT +;; STRING key (always-call-mount, is-removable, ...) +;; VARIANT value (boolean?) + +;; The basic structure for media devices. We use a list :type, in +;; order to be compatible with Emacs 25. +(cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We ;; must use "gio <command>" tool instead. @@ -470,6 +690,7 @@ It has been changed in GVFS 1.14.") ("gvfs-monitor-file" . "monitor") ("gvfs-mount" . "mount") ("gvfs-move" . "move") + ("gvfs-rename" . "rename") ("gvfs-rm" . "remove") ("gvfs-set-attribute" . "set") ("gvfs-trash" . "trash")) @@ -600,6 +821,8 @@ It has been changed in GVFS 1.14.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -625,10 +848,9 @@ First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled (tramp-user-error nil "Package `tramp-gvfs' not supported")) - (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (when (featurep 'dbusbind) @@ -649,13 +871,12 @@ pass to the OPERATION." "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists. Return nil for null BYTE-ARRAY." ;; The byte array could be a variant. Take care. - (let ((byte-array - (if (and (consp byte-array) (atom (car byte-array))) - byte-array (car byte-array)))) - (and byte-array - (dbus-byte-array-to-string - (if (and (consp byte-array) (zerop (car (last byte-array)))) - (butlast byte-array) byte-array))))) + (when-let ((byte-array + (if (and (consp byte-array) (atom (car byte-array))) + byte-array (car byte-array)))) + (dbus-byte-array-to-string + (if (and (consp byte-array) (zerop (car (last byte-array)))) + (butlast byte-array) byte-array)))) (defun tramp-gvfs-stringify-dbus-message (message) "Convert a D-Bus MESSAGE into readable UTF8 strings, used for traces." @@ -680,6 +901,8 @@ The call will be traced by Tramp with trace level 6." (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result)) result)) +(put #'tramp-dbus-function 'tramp-suppress-trace t) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -689,14 +912,15 @@ it is an asynchronous call, with `ignore' as callback function. The other arguments have the same meaning as with `dbus-call-method' or `dbus-call-method-asynchronously'." + (declare (indent 2) (debug t)) `(let ((func (if ,synchronous #'dbus-call-method #'dbus-call-method-asynchronously)) (args (append (list ,bus ,service ,path ,interface ,method) (if ,synchronous (list ,@args) (list 'ignore ,@args))))) - (tramp-dbus-function ,vec func args))) + ;; We use `dbus-ignore-errors', because this macro is also called + ;; when loading. + (dbus-ignore-errors (tramp-dbus-function ,vec func args)))) -(put 'with-tramp-dbus-call-method 'lisp-indent-function 2) -(put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) (defmacro with-tramp-dbus-get-all-properties @@ -704,6 +928,7 @@ or `dbus-call-method-asynchronously'." "Return all properties of INTERFACE. The call will be traced by Tramp with trace level 6." ;; Check, that interface exists at object path. Retrieve properties. + (declare (indent 1) (debug t)) `(when (member ,interface (tramp-dbus-function @@ -712,8 +937,6 @@ The call will be traced by Tramp with trace level 6." (tramp-dbus-function ,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface)))) -(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1) -(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) (defvar tramp-gvfs-dbus-event-vector nil @@ -728,6 +951,10 @@ is no information where to trace the message.") (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) (add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error) +(add-hook 'tramp-gvfs-unload-hook + (lambda () + (remove-hook 'dbus-event-error-functions + #'tramp-gvfs-dbus-event-error))) ;; File name primitives. @@ -758,11 +985,15 @@ file names." (copy-directory filename newname keep-date t) (when (eq op 'rename) (delete-directory filename 'recursive))) - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (equal-remote (tramp-equal-remote filename newname)) - (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move")) - (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + (let* ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (equal-remote (tramp-equal-remote filename newname)) + (gvfs-operation + (cond + ((eq op 'copy) "gvfs-copy") + (equal-remote "gvfs-rename") + (t "gvfs-move"))) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) @@ -772,7 +1003,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and equal-remote @@ -833,8 +1064,8 @@ file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -1281,7 +1512,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; If the user is different from what we guess to be ;; the user, we don't know. Let's check, whether ;; access is restricted explicitly. - (and (/= (tramp-gvfs-get-remote-uid v 'integer) + (and (/= (tramp-get-remote-uid v 'integer) (tramp-compat-file-attribute-user-id (file-attributes filename 'integer))) (not @@ -1301,10 +1532,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) - (when (and (stringp size) (stringp used) (stringp free)) - (list (string-to-number size) - (- (string-to-number size) (string-to-number used)) - (string-to-number free)))))) + (when (or size used free) + (list (string-to-number (or size "0")) + (string-to-number (or free "0")) + (- (string-to-number (or size "0")) + (string-to-number (or used "0")))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1330,8 +1562,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -1341,78 +1573,110 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-run-real-handler #'rename-file (list filename newname ok-if-already-exists)))) -(defun tramp-gvfs-handle-set-file-modes (filename mode) +(defun tramp-gvfs-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::mode" (number-to-string mode)))) + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint32" + (tramp-gvfs-url-file-name filename) "unix::mode" (number-to-string mode)))) -(defun tramp-gvfs-handle-set-file-times (filename &optional time) +(defun tramp-gvfs-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) - (let ((time - (if (or (null time) + (tramp-gvfs-send-command + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint64" + (tramp-gvfs-url-file-name filename) "time::modified" + (format-time-string + "%s" (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) - time))) - (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint64" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "time::modified" (format-time-string "%s" time))))) + time))))) + +(defun tramp-gvfs-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (if (equal id-format 'string) + (tramp-file-name-user vec) + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-user-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format))))) + +(defun tramp-gvfs-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-group-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format)))) -(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid) +(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (when (natnump uid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::uid" (number-to-string uid))) + (tramp-gvfs-url-file-name filename) "unix::uid" (number-to-string uid))) (when (natnump gid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + (tramp-gvfs-url-file-name filename) "unix::gid" (number-to-string gid))))) ;; File name conversions. +(defun tramp-gvfs-activation-uri (filename) + "Return activation URI to be used in gio commands." + (if (tramp-tramp-file-p filename) + (with-parsed-tramp-file-name filename nil + ;; Ensure that media devices are cached. + (when (string-equal method "media") + (tramp-get-media-device v)) + (with-tramp-connection-property v "activation-uri" + (setq localname "/") + (when (string-equal "gdrive" method) + (setq method "google-drive")) + (when (string-equal "nextcloud" method) + (setq method "davs" + localname + (concat (tramp-gvfs-get-remote-prefix v) localname))) + (when (string-equal "media" method) + (when-let + ((media (tramp-get-connection-property v "media-device" nil))) + (setq method (tramp-media-device-method media) + host (tramp-media-device-host media) + port (tramp-media-device-port media)))) + (when (and user domain) + (setq user (concat domain ";" user))) + (url-recreate-url + (url-parse-make-urlobj + method (and user (url-hexify-string user)) + nil (and host (url-hexify-string host)) + (if (stringp port) (string-to-number port) port) + localname nil nil t)))) + ;; Local URI. + (url-recreate-url + (url-parse-make-urlobj "file" nil nil nil nil nil nil nil t)))) + (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - ;; "/" must NOT be hexified. (setq filename (tramp-compat-file-name-unquote filename)) - (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) - result) - (setq - result - (url-recreate-url - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (when (string-equal "gdrive" method) - (setq method "google-drive")) - (when (string-equal "nextcloud" method) - (setq method "davs" - localname - (concat (tramp-gvfs-get-remote-prefix v) localname))) - (when (and user domain) - (setq user (concat domain ";" user))) - (url-parse-make-urlobj - method (and user (url-hexify-string user)) - nil (and host (url-hexify-string host)) - (if (stringp port) (string-to-number port) port) - (and localname (url-hexify-string localname)) nil nil t)) - (url-parse-make-urlobj - "file" nil nil nil nil - (url-hexify-string (file-truename filename)) nil nil t)))) + (let* (;; "/" must NOT be hexified. + (url-unreserved-chars (cons ?/ url-unreserved-chars)) + (result + (concat (substring (tramp-gvfs-activation-uri filename) 0 -1) + (url-hexify-string (tramp-file-local-name filename))))) (when (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (tramp-message v 10 "remote file `%s' is URL `%s'" filename result))) + (tramp-message + (tramp-dissect-file-name filename) 10 + "remote file `%s' is URL `%s'" filename result)) result)) (defun tramp-gvfs-object-path (filename) @@ -1424,6 +1688,14 @@ If FILE-SYSTEM is non-nil, return file system attributes." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) +(defun tramp-gvfs-url-host (url) + "Return the host name part of URL, a string. +We cannot use `url-host', because `url-generic-parse-url' returns +a downcased host name only." + (and (stringp url) + (string-match "^[[:alnum:]]+://\\([^/:]+\\)" url) + (match-string 1 url))) + ;; D-Bus GVFS functions. @@ -1490,8 +1762,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (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. @@ -1564,11 +1835,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices nil) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user domain host port "") nil @@ -1654,11 +1936,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices vec) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) @@ -1683,8 +1976,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (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. @@ -1696,11 +1988,16 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (defun tramp-gvfs-mount-spec (vec) "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." - (let* ((method (tramp-file-name-method vec)) + (let* ((media (tramp-get-media-device vec)) + (method (if media + (tramp-media-device-method media) + (tramp-file-name-method vec))) (user (tramp-file-name-user vec)) (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) + (host (if media + (tramp-media-device-host media) (tramp-file-name-host vec))) + (port (if media + (tramp-media-device-port media) (tramp-file-name-port vec))) (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) @@ -1751,42 +2048,41 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) +(defun tramp-gvfs-handler-volumeadded-volumeremoved (_dbus-name _id volume) + "Signal handler for the \"org.gtk.Private.RemoteVolumeMonitor.VolumeAdded\" \ +and \"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals." + (ignore-errors + (let* ((signal-name (dbus-event-member-name last-input-event)) + (uri (url-generic-parse-url (nth 5 volume))) + (method (url-type uri)) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri))))) + (when (member method tramp-media-methods) + (tramp-message + vec 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message volume)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties media) + (tramp-get-media-devices nil))))) + +(when tramp-gvfs-enabled + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeAdded" + #'tramp-gvfs-handler-volumeadded-volumeremoved) + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeRemoved" + #'tramp-gvfs-handler-volumeadded-volumeremoved)) + ;; Connection functions. -(defun tramp-gvfs-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((user (tramp-file-name-user vec)) - (localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - ((and (equal id-format 'string) user)) - (localname - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defun tramp-gvfs-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - (localname - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil - "Indication, that remote uid and gid determination is in progress.") - (defun tramp-gvfs-get-remote-prefix (vec) "The prefix of the remote connection VEC. This is relevant for GNOME Online Accounts." @@ -1794,7 +2090,7 @@ This is relevant for GNOME Online Accounts." ;; Ensure that GNOME Online Accounts are cached. (when (member (tramp-file-name-method vec) tramp-goa-methods) (tramp-get-goa-accounts vec)) - (tramp-get-connection-property (tramp-make-goa-name vec) "prefix" "/"))) + (tramp-get-connection-property (tramp-get-goa-account vec) "prefix" "/"))) (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -1843,7 +2139,7 @@ connection if a previous connection has died for some reason." ;; Ensure that GNOME Online Accounts are cached. (tramp-get-goa-accounts vec) (when (tramp-get-connection-property - (tramp-make-goa-name vec) "FilesDisabled" t) + (tramp-get-goa-account vec) "FilesDisabled" t) (tramp-user-error vec "There is no Online Account `%s'" (tramp-make-tramp-file-name vec 'noloc)))) @@ -1926,16 +2222,7 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (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. - (unless tramp-gvfs-get-remote-uid-gid-in-progress - (let ((tramp-gvfs-get-remote-uid-gid-in-progress t)) - (tramp-gvfs-get-remote-uid vec 'integer) - (tramp-gvfs-get-remote-gid vec 'integer) - (tramp-gvfs-get-remote-uid vec 'string) - (tramp-gvfs-get-remote-gid vec 'string)))) + (tramp-get-connection-process vec) "connected" t))))) (defun tramp-gvfs-gio-tool-p (vec) "Check, whether the gio tool is available." @@ -1968,12 +2255,12 @@ is applied, and it returns t if the return code is zero." (and (tramp-flush-file-properties vec "/") nil))))) -;; D-Bus GNOME Online Accounts functions. +;; GNOME Online Accounts functions. -(defun tramp-make-goa-name (vec) - "Transform VEC into a `tramp-goa-name' structure." +(defun tramp-get-goa-account (vec) + "Transform VEC into a `tramp-goa-account' structure." (when (tramp-file-name-p vec) - (make-tramp-goa-name + (make-tramp-goa-account :method (tramp-file-name-method vec) :user (tramp-file-name-user vec) :host (tramp-file-name-host vec) @@ -1981,12 +2268,12 @@ is applied, and it returns t if the return code is zero." (defun tramp-get-goa-accounts (vec) "Retrieve GNOME Online Accounts, and cache them. -The hash key is a `tramp-goa-name' structure. The value is an +The hash key is a `tramp-goa-account' structure. The value is an alist of the properties of `tramp-goa-interface-account' and -`tramp-goa-interface-files' of the corresponding GNOME online -account. Additionally, a property \"prefix\" is added. +`tramp-goa-interface-files' of the corresponding GNOME Online +Account. Additionally, a property \"prefix\" is added. VEC is used only for traces." - (with-tramp-connection-property (tramp-make-goa-name vec) "goa-accounts" + (with-tramp-connection-property nil "goa-accounts" (dolist (object-path (mapcar @@ -2012,15 +2299,15 @@ VEC is used only for traces." (cdr (assoc "ProviderType" account-properties)) '("google" "owncloud")) (string-match tramp-goa-identity-regexp identity)) - (setq key (make-tramp-goa-name + (setq key (make-tramp-goa-account :method (cdr (assoc "ProviderType" account-properties)) :user (match-string 1 identity) :host (match-string 2 identity) :port (match-string 3 identity))) - (when (string-equal (tramp-goa-name-method key) "google") - (setf (tramp-goa-name-method key) "gdrive")) - (when (string-equal (tramp-goa-name-method key) "owncloud") - (setf (tramp-goa-name-method key) "nextcloud")) + (when (string-equal (tramp-goa-account-method key) "google") + (setf (tramp-goa-account-method key) "gdrive")) + (when (string-equal (tramp-goa-account-method key) "owncloud") + (setf (tramp-goa-account-method key) "nextcloud")) ;; Cache all properties. (dolist (prop (nconc account-properties files-properties)) (tramp-set-connection-property key (car prop) (cdr prop))) @@ -2036,6 +2323,80 @@ VEC is used only for traces." ;; Mark, that goa accounts have been cached. "cached")) +(defun tramp-parse-goa-accounts (service) + "Return a list of (user host) tuples allowed to access. +It checks for registered GNOME Online Accounts." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-goa-account-p key) + (string-equal service (tramp-goa-account-method key)) + (list (tramp-goa-account-user key) + (tramp-goa-account-host key)))) + (hash-table-keys tramp-cache-data))) + + +;; Media devices functions. + +(defun tramp-get-media-device (vec) + "Transform VEC into a `tramp-media-device' structure. +Check, that respective cache values do exist." + (if-let ((media (tramp-get-connection-property vec "media-device" nil)) + (prop (tramp-get-connection-property media "vector" nil))) + media + (tramp-get-media-devices vec) + (tramp-get-connection-property vec "media-device" nil))) + +(defun tramp-get-media-devices (vec) + "Retrieve media devices, and cache them. +The hash key is a `tramp-media-device' structure. +VEC is used only for traces." + (let (devices) + (dolist (method tramp-media-methods) + (dolist (volume (cadr (with-tramp-dbus-call-method vec t + :session (tramp-gvfs-service-volumemonitor method) + tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "List"))) + (let* ((uri (url-generic-parse-url (nth 5 volume))) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri) + (number-to-string (url-portspec uri)))))) + (push (tramp-file-name-host vec) devices) + (tramp-set-connection-property vec "activation-uri" (nth 5 volume)) + (tramp-set-connection-property vec "media-device" media) + (tramp-set-connection-property media "vector" vec)))) + + ;; Adapt default host name, supporting /media:: when possible. + (setq tramp-default-host-alist + (append + `(("media" nil ,(if (= (length devices) 1) (car devices) ""))) + (delete + (assoc "media" tramp-default-host-alist) + tramp-default-host-alist))))) + +(defun tramp-parse-media-names (service) + "Return a list of (user host) tuples allowed to access. +It checks for mounted media devices." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-media-device-p key) + (string-equal service (tramp-media-device-method key)) + (tramp-get-connection-property key "vector" nil) + (list nil (tramp-file-name-host + (tramp-get-connection-property key "vector" nil))))) + (hash-table-keys tramp-cache-data))) + ;; D-Bus zeroconf functions. @@ -2080,39 +2441,62 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (list user host))) result)))) -;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods. (when tramp-gvfs-enabled - ;; Suppress D-Bus error messages. - (let (tramp-gvfs-dbus-event-vector) + ;; Suppress D-Bus error messages and Tramp traces. + (let ((tramp-verbose 0) + tramp-gvfs-dbus-event-vector fun) + ;; Add completion functions for services announced by DNS-SD. + ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types. (zeroconf-init tramp-gvfs-zeroconf-domain) - (if (zeroconf-list-service-types) - (progn - (tramp-set-completion-function - "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp"))) - (tramp-set-completion-function - "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp") - (tramp-zeroconf-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp"))))) - - (when (executable-find "avahi-browse") + (when (setq fun (or (and (zeroconf-list-service-types) + #'tramp-zeroconf-parse-device-names) + (and (executable-find "avahi-browse") + #'tramp-gvfs-parse-device-names))) + (when (member "afp" tramp-gvfs-methods) + (tramp-set-completion-function + "afp" `((,fun "_afpovertcp._tcp")))) + (when (member "dav" tramp-gvfs-methods) + (tramp-set-completion-function + "dav" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "davs" tramp-gvfs-methods) + (tramp-set-completion-function + "davs" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "ftp" tramp-gvfs-methods) (tramp-set-completion-function - "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp"))) + "ftp" `((,fun "_ftp._tcp")))) + (when (member "http" tramp-gvfs-methods) (tramp-set-completion-function - "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "http" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "https" tramp-gvfs-methods) (tramp-set-completion-function - "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "https" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "sftp" tramp-gvfs-methods) (tramp-set-completion-function - "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp") - (tramp-gvfs-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) + "sftp" `((,fun "_sftp-ssh._tcp") + (,fun "_ssh._tcp") + (,fun "_workstation._tcp")))) + (when (member "smb" tramp-gvfs-methods) + (tramp-set-completion-function + "smb" `((,fun "_smb._tcp"))))) + + ;; Add completion functions for GNOME Online Accounts. + (tramp-get-goa-accounts nil) + (dolist (method tramp-goa-methods) + (when (member method tramp-gvfs-methods) + (tramp-set-completion-function + method `((tramp-parse-goa-accounts ,(format "_%s._tcp" method)))))) + + ;; Add completion functions for media devices. + (tramp-get-media-devices nil) + (tramp-set-completion-function + "media" + (mapcar + (lambda (method) `(tramp-parse-media-names ,(format "_%s._tcp" method))) + tramp-media-methods)))) (add-hook 'tramp-unload-hook (lambda () @@ -2125,7 +2509,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." ;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. ;; ;; * Host name completion for existing mount points (afp-server, -;; smb-server, google-drive, nextcloud) or via smb-network or network. +;; smb-server) or via smb-network or network. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 9f539850139..3701bfc22c9 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -135,6 +135,8 @@ (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -157,10 +159,9 @@ Operations not mentioned here will be handled by the default Emacs primitives.") "Invoke the rclone handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (tramp--with-startup @@ -220,7 +221,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and t1 (not (tramp-rclone-file-name-p filename))) @@ -271,8 +272,8 @@ file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -429,8 +430,8 @@ file names." (defun tramp-rclone-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -458,7 +459,7 @@ file names." ;; to cache a nil result. (or (tramp-get-connection-property (tramp-get-connection-process vec) "mounted" nil) - (let* ((default-directory temporary-file-directory) + (let* ((default-directory (tramp-compat-temporary-file-directory)) (mount (shell-command-to-string "mount -t fuse.rclone"))) (tramp-message vec 6 "%s" "mount -t fuse.rclone") (tramp-message vec 6 "\n%s" mount) @@ -478,7 +479,19 @@ file names." (with-tramp-connection-property (tramp-get-connection-process vec) "rclone-pid" (catch 'pid - (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (dolist + (pid + ;; Until Emacs 25, `process-attributes' could + ;; crash Emacs for some processes. So we use + ;; "pidof", which might not work everywhere. + (if (<= emacs-major-version 25) + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (mapcar + #'string-to-number + (split-string + (shell-command-to-string "pidof rclone")))) + (list-system-processes))) (and (string-match-p (regexp-quote (format "rclone mount %s:" (tramp-file-name-host vec))) @@ -564,7 +577,7 @@ connection if a previous connection has died for some reason." ,(tramp-rclone-mount-point vec) ;; This could be nil. ,(tramp-get-method-parameter vec 'tramp-mount-args)))) - (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname))) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) (tramp-cleanup-connection vec 'keep-debug 'keep-password)) ;; Mark it as connected. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index af97328b3d3..89e5dc9e658 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -481,6 +481,7 @@ The string is used in `tramp-methods'.") ;; Darwin: /usr/bin:/bin:/usr/sbin:/sbin ;; IRIX64: /usr/bin ;; QNAP QTS: --- +;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin ;;;###tramp-autoload (defcustom tramp-remote-path '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" @@ -491,8 +492,8 @@ The string is used in `tramp-methods'.") For every remote host, this variable will be set buffer local, keeping the list of existing directories on that host. -You can use `~' in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with `~' will be ignored. +You can use \"~\" in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with \"~\" will be ignored. `Default Directories' represent the list of directories given by the command \"getconf PATH\". It is recommended to use this @@ -537,12 +538,13 @@ based on the Tramp and Emacs versions, and should not be set here." ;;;###tramp-autoload (defcustom tramp-sh-extra-args - '(("/bash\\'" . "-norc -noprofile") + '(("/bash\\'" . "-noediting -norc -noprofile") ("/zsh\\'" . "-f +Z -V")) "Alist specifying extra arguments to pass to the remote shell. Entries are (REGEXP . ARGS) where REGEXP is a regular expression matching the shell file name and ARGS is a string specifying the -arguments. +arguments. These arguments shall disable line editing, see +`tramp-open-shell'. This variable is only used when Tramp needs to start up another shell for tilde expansion. The extra arguments should typically prevent the @@ -866,8 +868,12 @@ Escape sequence %s is replaced with name of Perl binary.") "Perl program to use for decoding a file. Escape sequence %s is replaced with name of Perl binary.") +(defconst tramp-hexdump-encode "%h -v -e '16/1 \" %%02x\" \"\\n\"'" + "`hexdump' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + (defconst tramp-awk-encode - "od -v -t x1 -A n | busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" b16 = \"0123456789abcdef\" @@ -897,11 +903,25 @@ END { } printf tail }'" - "Awk program to use for encoding a file. + "`awk' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-hexdump-awk-encode + (format "%s | %s" tramp-hexdump-encode tramp-awk-encode) + "`hexdump' / `awk' pipe to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-encode "%o -v -t x1 -A n" + "`od' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-awk-encode + (format "%s | %s" tramp-od-encode tramp-awk-encode) + "`od' / `awk' pipe to use for encoding a file. This string is passed to `format', so percent characters need to be doubled.") (defconst tramp-awk-decode - "busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" } @@ -926,12 +946,6 @@ BEGIN { "Awk program to use for decoding a file. This string is passed to `format', so percent characters need to be doubled.") -(defconst tramp-awk-coding-test - "test -c /dev/zero && \ -od -v -t x1 -A n </dev/null && \ -busybox awk '{}' </dev/null" - "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") - (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do @@ -1025,6 +1039,8 @@ of command line.") (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) @@ -1051,9 +1067,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1104,8 +1118,7 @@ component is used as the target of the symlink." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -1142,59 +1155,9 @@ component is used as the target of the symlink." (tramp-shell-quote-argument localname))))) ;; Do it yourself. - (t (let ((steps (split-string localname "/" 'omit)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/") - 'nohop)))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message - v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - (setq steps - (append - (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result (string-join (cons "" result) "/") "/")) - (when (string-empty-p result) (setq result "/"))))) + (t (setq + result + (tramp-file-local-name (tramp-handle-file-truename filename))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1263,8 +1226,8 @@ component is used as the target of the symlink." (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." (let (symlinkp dirp - res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) + res-inode res-filemodes res-numlinks + res-uid res-gid res-size res-symlink-target) (tramp-message vec 5 "file attributes with ls: %s" localname) ;; We cannot send all three commands combined, it could exceed ;; NAME_MAX or PATH_MAX. Happened on macOS, for example. @@ -1368,18 +1331,11 @@ component is used as the target of the symlink." (format (eval-when-compile (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we - ;; add a space. Apostrophes in the stat output are masked as + ;; Apostrophes in the stat output are masked as ;; `tramp-stat-marker', in order to make a proper shell escape ;; of them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) + "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |" + " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')")) (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) @@ -1390,7 +1346,8 @@ component is used as the target of the symlink." (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) - tramp-stat-quoted-marker))) + tramp-stat-quoted-marker) + 'noerror)) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -1468,17 +1425,24 @@ of." ;; only if that agrees with the buffer's record. (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) -(defun tramp-sh-handle-set-file-modes (filename mode) +(defun tramp-sh-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - ;; FIXME: extract the proper text from chmod's stderr. - (tramp-barf-unless-okay - v - (format "chmod %o %s" mode (tramp-shell-quote-argument localname)) - "Error while changing file's mode %s" filename))) + ;; We need "chmod -h" when the flag is set. + (when (or (not (eq flag 'nofollow)) + (not (file-symlink-p filename)) + (tramp-get-remote-chmod-h v)) + (tramp-flush-file-properties v localname) + ;; FIXME: extract the proper text from chmod's stderr. + (tramp-barf-unless-okay + v + (format + "chmod %s %o %s" + (if (and (eq flag 'nofollow) (tramp-get-remote-chmod-h v)) "-h" "") + mode (tramp-shell-quote-argument localname)) + "Error while changing file's mode %s" filename)))) -(defun tramp-sh-handle-set-file-times (filename &optional time) +(defun tramp-sh-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) @@ -1491,13 +1455,34 @@ of." time))) (tramp-send-command-and-check v (format - "env TZ=UTC %s %s %s" + "env TZ=UTC %s %s %s %s" (tramp-get-remote-touch v) (if (tramp-get-connection-property v "touch-t" nil) (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t)) "") + (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-uid-with-python vec id-format))))) + +(defun tramp-sh-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-gid-with-python vec id-format))))) + (defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." ;; Modern Unices allow chown only for root. So we might need @@ -1521,7 +1506,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) @@ -1570,7 +1555,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) @@ -1700,8 +1685,10 @@ of." (defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group) "Like `file-ownership-preserved-p' for Tramp files." (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-ownership-preserved-p" - (let ((attributes (file-attributes filename))) + (with-tramp-file-property + v localname + (format "file-ownership-preserved-p%s" (if group "-group" "")) + (let ((attributes (file-attributes filename 'integer))) ;; Return t if the file doesn't exist, since it's true that no ;; information would be lost by an (attempted) delete and create. (or (null attributes) @@ -1948,7 +1935,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; scp or rsync DTRT. (progn (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (setq dirname (directory-file-name (expand-file-name dirname)) newname (directory-file-name (expand-file-name newname))) @@ -1961,7 +1948,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (unless (file-directory-p (file-name-directory newname)) (make-directory (file-name-directory newname) parents)) (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname keep-date)) + 'copy dirname newname 'ok-if-already-exists keep-date)) ;; We must do it file-wise. (tramp-run-real-handler @@ -1978,8 +1965,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -2030,7 +2017,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -2057,7 +2044,7 @@ file names." (tramp-method-out-of-band-p v1 length) (tramp-method-out-of-band-p v2 length)) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; No shortcut was possible. So we copy the file ;; first. If the operation was `rename', we go back @@ -2070,7 +2057,7 @@ file names." ;; source and target file. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))))) + op filename newname ok-if-already-exists keep-date)))))) ;; One file is a Tramp file, the other one is local. ((or t1 t2) @@ -2085,11 +2072,11 @@ file names." ;; corresponding copy-program can be invoked. ((tramp-method-out-of-band-p v length) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; Use the inline method via a Tramp buffer. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) + op filename newname ok-if-already-exists keep-date)))) (t ;; One of them must be a Tramp file. @@ -2111,7 +2098,8 @@ file names." (with-parsed-tramp-file-name newname v2 (tramp-flush-file-properties v2 v2-localname)))))))) -(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-via-buffer + (op filename newname ok-if-already-exists keep-date) "Use an Emacs buffer to copy or rename a file. First arg OP is either `copy' or `rename' and indicates the operation. FILENAME is the source file, NEWNAME the target file. @@ -2139,10 +2127,11 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (insert-file-contents-literally filename))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) ;; If the operation was `rename', delete the original file. @@ -2171,8 +2160,8 @@ the uid and gid from FILENAME." v 'file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) - (localname1 (tramp-compat-file-local-name filename)) - (localname2 (tramp-compat-file-local-name newname)) + (localname1 (tramp-file-local-name filename)) + (localname2 (tramp-file-local-name newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) (when (and (eq op 'copy) (file-directory-p filename)) @@ -2296,10 +2285,12 @@ the uid and gid from FILENAME." ;; Set the time and mode. Mask possible errors. (ignore-errors (when keep-date - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes)))))) -(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-out-of-band + (op filename newname ok-if-already-exists keep-date) "Invoke `scp' program to copy. The method used must be an out-of-band method." (let* ((t1 (tramp-tramp-file-p filename)) @@ -2322,9 +2313,9 @@ The method used must be an out-of-band method." (unwind-protect (progn (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile keep-date) + op filename tmpfile ok-if-already-exists keep-date) (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname keep-date)) + 'rename tmpfile newname ok-if-already-exists keep-date)) ;; Save exit. (ignore-errors (if dir-flag @@ -2498,10 +2489,11 @@ The method used must be an out-of-band method." ;; Handle KEEP-DATE argument. (when (and keep-date (not copy-keep-date)) - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless (and keep-date copy-keep-date) @@ -2714,7 +2706,7 @@ The method used must be an out-of-band method." (when (file-symlink-p filename) (goto-char (search-backward "->" beg 'noerror))) (search-backward - (if (tramp-compat-directory-name-p filename) + (if (directory-name-p filename) "." (file-name-nondirectory filename)) beg 'noerror) @@ -2724,12 +2716,11 @@ The method used must be an out-of-band method." (goto-char (point-min)) ;; First find the line to put it on. (when (re-search-forward "^\\([[:space:]]*total\\)" nil t) - (let ((available (get-free-disk-space "."))) - (when available - ;; Replace "total" with "total used", to avoid confusion. - (replace-match "\\1 used in directory") - (end-of-line) - (insert " available " available)))) + (when-let ((available (get-free-disk-space "."))) + ;; Replace "total" with "total used", to avoid confusion. + (replace-match "\\1 used in directory") + (end-of-line) + (insert " available " available))) (goto-char (point-max))))))) @@ -2796,8 +2787,11 @@ the result will be a local, non-Tramp, file name." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-sh-handle-make-process (&rest args) - "Like `make-process' for Tramp files." + "Like `make-process' for Tramp files. +STDERR can also be a file name." (when args (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((name (plist-get args :name)) @@ -2829,14 +2823,23 @@ the result will be a local, non-Tramp, file name." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - (stderr (and stderr (get-buffer-create stderr))) - (tmpstderr (and stderr (tramp-make-tramp-temp-file v))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -2877,6 +2880,11 @@ the result will be a local, non-Tramp, file name." (setq uenv (cons elt uenv))))))) (command (when (stringp program) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) (format "cd %s && %s exec %s %s env %s %s" (tramp-shell-quote-argument localname) (if uenv @@ -2965,21 +2973,35 @@ the result will be a local, non-Tramp, file name." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Provide error buffer. This shows only ;; initial error messages; messages arriving - ;; later on shall be inserted by `auto-revert'. - ;; The temporary file will still be existing. - ;; TODO: Write a sentinel, which deletes the - ;; temporary file. - (when tmpstderr - ;; We must flush them here already; otherwise - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + ;; later on will be inserted when the process is + ;; deleted. The temporary file will exist until + ;; the process is deleted. + (when (bufferp stderr) (with-current-buffer stderr - (insert-file-contents - (tramp-make-tramp-file-name v tmpstderr) 'visit) - (auto-revert-mode))) + (insert-file-contents-literally remote-tmpstderr)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (when (file-exists-p remote-tmpstderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace)) + (delete-file remote-tmpstderr))))) ;; Return process. p))) @@ -3012,6 +3034,11 @@ the result will be a local, non-Tramp, file name." (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) (setq uenv (cons elt uenv)))))) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) (when env (setq command (format @@ -3028,7 +3055,7 @@ the result will be a local, non-Tramp, file name." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input 'nohop)) @@ -3059,8 +3086,7 @@ the result will be a local, non-Tramp, file name." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -3078,13 +3104,12 @@ the result will be a local, non-Tramp, file name." ;; directory. (condition-case nil (unwind-protect - (setq ret - (if (tramp-send-command-and-check - v (format "cd %s && %s" - (tramp-shell-quote-argument localname) - command) - t t) - 0 1)) + (setq ret (tramp-send-command-and-check + v (format + "cd %s && %s" + (tramp-shell-quote-argument localname) command) + t t t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -3102,6 +3127,12 @@ the result will be a local, non-Tramp, file name." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (>= ret 128)) + (setq ret (nth (- ret 128) (tramp-get-signal-strings)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -3122,7 +3153,7 @@ the result will be a local, non-Tramp, file name." (append (tramp-get-remote-path (tramp-dissect-file-name default-directory)) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -3236,7 +3267,8 @@ the result will be a local, non-Tramp, file name." #'write-region (list start end localname append 'no-message lockname)) - (let* ((modes (save-excursion (tramp-default-file-modes filename))) + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) ;; We use this to save the value of ;; `last-coding-system-used' after writing the tmp ;; file. At the end of the function, we set @@ -3258,7 +3290,8 @@ the result will be a local, non-Tramp, file name." ;; If `append' is non-nil, we copy the file locally, and let ;; the native `write-region' implementation do the job. - (when append (copy-file filename tmpfile 'ok)) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the ;; visited file modtime data to be clobbered from the temp @@ -3468,8 +3501,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-handle-vc-registered (file) "Like `vc-registered' for Tramp files." (when vc-handled-backends - (let ((tramp-message-show-message - (and (not revert-buffer-in-progress-p) tramp-message-show-message)) + (let ((inhibit-message (or revert-buffer-in-progress-p inhibit-message)) (temp-message (unless revert-buffer-in-progress-p ""))) (with-temp-message temp-message (with-parsed-tramp-file-name file nil @@ -3528,27 +3560,30 @@ the result will be a local, non-Tramp, file name." ;; calls shall be answered from the file cache. We unset ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' ;; in order to keep the cache. - (let ((vc-handled-backends vc-handled-backends) + (let ((vc-handled-backends (copy-sequence vc-handled-backends)) 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) + (when (and + (memq 'Bzr vc-handled-backends) + (or (not (require 'vc-bzr nil 'noerror)) (not (with-tramp-connection-property v vc-bzr-program (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) + 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) + (when (and + (memq 'Git vc-handled-backends) + (or (not (require 'vc-git nil 'noerror)) (not (with-tramp-connection-property v vc-git-program (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) + 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) + (when (and + (memq 'Hg vc-handled-backends) + (or (not (require 'vc-hg nil 'noerror)) (not (with-tramp-connection-property v vc-hg-program (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) + v vc-hg-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Hg vc-handled-backends))) ;; Run. (tramp-with-demoted-errors @@ -3559,10 +3594,9 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-file-name-handler (operation &rest args) "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." - (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload @@ -3921,7 +3955,7 @@ hosts, or files, disagree." First arg VEC specifies the connection, PROGNAME is the program to search for, and DIRLIST gives the list of directories to search. If IGNORE-TILDE is non-nil, directory names starting -with `~' will be ignored. If IGNORE-PATH is non-nil, searches +with \"~\" will be ignored. If IGNORE-PATH is non-nil, searches only in DIRLIST. Returns the absolute file name of PROGNAME, if found, and nil otherwise. @@ -3947,8 +3981,8 @@ This function expects to be in the right *tramp* buffer." ;; Remove all ~/foo directories from dirlist. (let (newdl d) (while dirlist - (setq d (car dirlist)) - (setq dirlist (cdr dirlist)) + (setq d (car dirlist) + dirlist (cdr dirlist)) (unless (char-equal ?~ (aref d 0)) (setq newdl (cons d newdl)))) (setq dirlist (nreverse newdl)))) @@ -3983,21 +4017,22 @@ variable PATH." (format "PATH=%s; export PATH" (string-join (tramp-get-remote-path vec) ":"))) (pipe-buf - (or (with-tramp-connection-property vec "pipe-buf" - (tramp-send-command-and-read - vec "getconf PIPE_BUF / 2>/dev/null || echo nil" 'noerror)) - 4096)) + (with-tramp-connection-property vec "pipe-buf" + (tramp-send-command-and-read + vec "getconf PIPE_BUF / 2>/dev/null || echo 4096" 'noerror))) tmpfile) (tramp-message vec 5 "Setting $PATH environment variable") (if (< (length command) pipe-buf) (tramp-send-command vec command) ;; Use a temporary file. - (setq tmpfile - (tramp-make-tramp-file-name vec (tramp-make-tramp-temp-file vec))) - (write-region command nil tmpfile) - (tramp-send-command - vec (format ". %s" (tramp-compat-file-local-name tmpfile))) - (delete-file tmpfile)))) + (setq tmpfile (tramp-make-tramp-temp-file vec)) + (tramp-send-command vec (format + "cat >%s <<'%s'\n%s\n%s" + (tramp-shell-quote-argument tmpfile) + tramp-end-of-heredoc + command tramp-end-of-heredoc)) + (tramp-send-command vec (format ". %s" tmpfile)) + (tramp-send-command vec (format "rm -f %s" tmpfile))))) ;; ------------------------------------------------------------ ;; -- Communication with external shell -- @@ -4072,7 +4107,28 @@ file exists and nonzero exit status otherwise." (with-tramp-progress-reporter vec 5 (format-message "Opening remote shell `%s'" shell) ;; Find arguments for this shell. - (let ((extra-args (tramp-get-sh-extra-args shell))) + (let ((extra-args (tramp-get-sh-extra-args shell)) + (p (tramp-get-connection-process vec))) + ;; The readline library can disturb Tramp. For example, the + ;; very recent version of libedit, the *BSD implementation of + ;; readline, confuses Tramp. So we disable line editing. Since + ;; $EDITRC is not supported on all target systems, we must move + ;; ~/.editrc temporarily somewhere else. For bash and zsh we + ;; have disabled this already during shell invocation, see + ;; `tramp-sh-extra-args' (Bug#39399). + ;; The shell prompt might not be set yet, so we must read any + ;; prompt via `tramp-barf-if-no-shell-prompt'. + (unless extra-args + (tramp-send-command vec "rm -f ~/.editrc.tramp" t t) + (tramp-barf-if-no-shell-prompt p 10 "Couldn't find remote shell prompt") + (tramp-send-command + vec "test -e ~/.editrc && mv -f ~/.editrc ~/.editrc.tramp" t t) + (tramp-barf-if-no-shell-prompt p 10 "Couldn't find remote shell prompt") + (tramp-send-command vec "echo 'edit off' >~/.editrc" t t) + (tramp-barf-if-no-shell-prompt + p 10 "Couldn't find remote shell prompt")) + ;; It is useful to set the prompt in the following command + ;; because some people have a setting for $PS1 which /bin/sh ;; doesn't know about and thus /bin/sh will display a strange ;; prompt. For example, if $PS1 has "${CWD}" in the value, then ;; ksh will display the current working directory but /bin/sh @@ -4095,7 +4151,7 @@ file exists and nonzero exit status otherwise." "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")) tramp-terminal-type - emacs-version tramp-version ; INSIDE_EMACS + (or (getenv "INSIDE_EMACS") emacs-version) tramp-version (or (getenv-internal "ENV" tramp-remote-process-environment) "") (if (stringp tramp-histfile-override) (format "HISTFILE=%s" @@ -4106,6 +4162,11 @@ file exists and nonzero exit status otherwise." (tramp-shell-quote-argument tramp-end-of-output) shell (or extra-args "")) t) + ;; Reset ~/.editrc. + (unless extra-args + (tramp-send-command vec "rm -f ~/.editrc" t) + (tramp-send-command + vec "test -e ~/.editrc.tramp && mv -f ~/.editrc.tramp ~/.editrc" t)) ;; Check proper HISTFILE setting. We give up when not working. (when (and (stringp tramp-histfile-override) (file-name-directory tramp-histfile-override)) @@ -4123,45 +4184,47 @@ file exists and nonzero exit status otherwise." (defun tramp-find-shell (vec) "Open a shell on the remote host which groks tilde expansion." - (with-current-buffer (tramp-get-buffer vec) - (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) - shell) - (setq shell - (with-tramp-connection-property vec "remote-shell" - ;; CCC: "root" does not exist always, see my QNAP TS-459. - ;; Which check could we apply instead? - (tramp-send-command vec "echo ~root" t) - (if (or (string-match-p "^~root$" (buffer-string)) - ;; The default shell (ksh93) of OpenSolaris and - ;; Solaris is buggy. We've got reports for - ;; "SunOS 5.10" and "SunOS 5.11" so far. - (string-match-p - (eval-when-compile - (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) - (tramp-get-connection-property vec "uname" ""))) - - (or (tramp-find-executable - vec "bash" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "ksh" (tramp-get-remote-path vec) t t) - ;; Maybe it works at least for some other commands. - (prog1 - default-shell - (tramp-message - vec 2 + ;; If we are in `make-process', we don't need another shell. + (unless (tramp-get-connection-property vec "process-name" nil) + (with-current-buffer (tramp-get-buffer vec) + (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) + shell) + (setq shell + (with-tramp-connection-property vec "remote-shell" + ;; CCC: "root" does not exist always, see my QNAP + ;; TS-459. Which check could we apply instead? + (tramp-send-command vec "echo ~root" t) + (if (or (string-match-p "^~root$" (buffer-string)) + ;; The default shell (ksh93) of OpenSolaris + ;; and Solaris is buggy. We've got reports + ;; for "SunOS 5.10" and "SunOS 5.11" so far. + (string-match-p (eval-when-compile - (concat - "Couldn't find a remote shell which groks tilde " - "expansion, using `%s'")) - default-shell))) + (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) + (tramp-get-connection-property vec "uname" ""))) + + (or (tramp-find-executable + vec "bash" (tramp-get-remote-path vec) t t) + (tramp-find-executable + vec "ksh" (tramp-get-remote-path vec) t t) + ;; Maybe it works at least for some other commands. + (prog1 + default-shell + (tramp-message + vec 2 + (eval-when-compile + (concat + "Couldn't find a remote shell which groks tilde " + "expansion, using `%s'")) + default-shell))) - default-shell))) + default-shell))) - ;; Open a new shell if needed. - (unless (string-equal shell default-shell) - (tramp-message - vec 5 "Starting remote shell `%s' for tilde expansion" shell) - (tramp-open-shell vec shell))))) + ;; Open a new shell if needed. + (unless (string-equal shell default-shell) + (tramp-message + vec 5 "Starting remote shell `%s' for tilde expansion" shell) + (tramp-open-shell vec shell)))))) ;; Utility functions. @@ -4216,11 +4279,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 @@ -4383,7 +4450,7 @@ and end of region, and are expected to replace the region contents with the encoded or decoded results, respectively.") (defconst tramp-remote-coding-commands - `((b64 "base64" "base64 -d -i") + '((b64 "base64" "base64 -d -i") ;; "-i" is more robust with older base64 from GNU coreutils. ;; However, I don't know whether all base64 versions do supports ;; this option. @@ -4394,8 +4461,9 @@ with the encoded or decoded results, respectively.") (b64 "recode data..base64" "recode base64..data") (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) (b64 tramp-perl-encode tramp-perl-decode) - ;; This is painful slow, so we put it on the end. - (b64 tramp-awk-encode tramp-awk-decode ,tramp-awk-coding-test) + ;; These are painfully slow, so we put them on the end. + (b64 tramp-hexdump-awk-encode tramp-awk-decode) + (b64 tramp-od-awk-encode tramp-awk-decode) (uu "uuencode xxx" "uudecode -o /dev/stdout" "test -c /dev/stdout") (uu "uuencode xxx" "uudecode -o -") (uu "uuencode xxx" "uudecode -p") @@ -4421,6 +4489,8 @@ Perl or Shell implementation for this functionality. This program will be transferred to the remote host, and it is available as shell function with the same name. A \"%t\" format specifier in the variable value denotes a temporary file. +\"%a\", \"%h\" and \"%o\" format specifiers are replaced by the +respective `awk', `hexdump' and `od' commands. The optional TEST command can be used for further tests, whether ENCODING and DECODING are applicable.") @@ -4439,8 +4509,8 @@ Goes through the list `tramp-local-coding-commands' and (catch 'wont-work-local (let ((format (nth 0 litem)) (remote-commands tramp-remote-coding-commands)) - (setq loc-enc (nth 1 litem)) - (setq loc-dec (nth 2 litem)) + (setq loc-enc (nth 1 litem) + loc-dec (nth 2 litem)) ;; If the local encoder or decoder is a string, the ;; corresponding command has to work locally. (if (not (stringp loc-enc)) @@ -4462,20 +4532,15 @@ Goes through the list `tramp-local-coding-commands' and (setq ritem (pop remote-commands)) (catch 'wont-work-remote (when (equal format (nth 0 ritem)) - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq rem-test (nth 3 ritem)) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + rem-test (nth 3 ritem)) ;; Check the remote test command if exists. (when (stringp rem-test) (tramp-message vec 5 "Checking remote test command `%s'" rem-test) (unless (tramp-send-command-and-check vec rem-test t) (throw 'wont-work-remote nil))) - ;; Check if remote perl exists when necessary. - (when (and (symbolp rem-enc) - (string-match-p "perl" (symbol-name rem-enc)) - (not (tramp-get-remote-perl vec))) - (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be ;; called remotely with null input and output. This makes ;; sure there are no syntax errors and the command is really @@ -4485,10 +4550,36 @@ Goes through the list `tramp-local-coding-commands' and ;; redirecting "mimencode" output to /dev/null, then as root ;; it might change the permissions of /dev/null! (unless (stringp rem-enc) - (let ((name (symbol-name rem-enc))) + (let ((name (symbol-name rem-enc)) + (value (symbol-value rem-enc))) + ;; Check if remote perl exists when necessary. + (and (string-match-p "perl" name) + (not (tramp-get-remote-perl vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote awk exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%a" value) + (not (tramp-get-remote-awk vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote hexdump exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%h" value) + (not (tramp-get-remote-hexdump vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote od exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%o" value) + (not (tramp-get-remote-od vec)) + (throw 'wont-work-remote nil)) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-enc) name) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) + (tramp-maybe-send-script vec value name) (setq rem-enc name))) (tramp-message vec 5 @@ -4503,17 +4594,22 @@ Goes through the list `tramp-local-coding-commands' and tmpfile) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) (when (string-match-p "\\(^\\|[^%]\\)%t" value) - (setq tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-get-remote-tmpdir vec))) + (setq tmpfile (tramp-make-tramp-temp-name vec) value (format-spec value (format-spec-make - ?t (tramp-compat-file-local-name tmpfile))))) + ?t (tramp-file-local-name tmpfile))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4531,9 +4627,9 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq found t))))))) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + found t))))))) (when found ;; Set connection properties. Since the commands are risky @@ -4796,8 +4892,8 @@ If there is just some editing, retry it after 5 seconds." vec 5 "Cannot timeout session, trying it again in %s seconds." 5) (run-at-time 5 nil 'tramp-timeout-session vec)) (tramp-message - vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname)) - (tramp-cleanup-connection vec 'keep-debug))) + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) + (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes))) (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -4818,11 +4914,8 @@ connection if a previous connection has died for some reason." (not (tramp-file-name-equal-p vec (car tramp-current-connection))) (time-less-p - ;; `current-time' can be removed once we get rid of Emacs 24. - (time-since (or (cdr tramp-current-connection) (current-time))) - ;; `seconds-to-time' can be removed once we get rid - ;; of Emacs 24. - (seconds-to-time (or tramp-connection-min-time-diff 0)))) + (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 @@ -4833,11 +4926,9 @@ connection if a previous connection has died for some reason." ;; try to send a command from time to time, then look again ;; whether the process is really alive. (condition-case nil - ;; `seconds-to-time' can be removed once we get rid of Emacs 24. - (when (and (time-less-p (seconds-to-time 60) - (time-since - (tramp-get-connection-property - p "last-cmd-time" (seconds-to-time 0)))) + (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) @@ -4951,11 +5042,8 @@ 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" - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (tramp-get-process vec) "temp-file" + (tramp-compat-make-temp-name))) spec r-shell) ;; Add arguments for asynchronous processes. @@ -5116,7 +5204,7 @@ function waits for output unless NOOUTPUT is set." found))) (defun tramp-send-command-and-check - (vec command &optional subshell dont-suppress-err) + (vec command &optional subshell dont-suppress-err exit-status) "Run COMMAND and check its exit status. Send `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just send `echo $?'. Return t if the exit @@ -5124,7 +5212,9 @@ status is 0, and nil otherwise. If the optional argument SUBSHELL is non-nil, the command is executed in a subshell, ie surrounded by parentheses. If -DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." +DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null. +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-send-command vec (concat (if subshell "( " "") @@ -5138,7 +5228,9 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) @@ -5171,7 +5263,10 @@ raises an error." command marker (buffer-string)))))) ;; Read the expression. (condition-case nil - (prog1 (read (current-buffer)) + (prog1 + (let ((signal-hook-function + (unless noerror signal-hook-function))) + (read (current-buffer))) ;; Error handling. (when (re-search-forward "\\S-" (point-at-eol) t) (error nil))) @@ -5324,7 +5419,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)) @@ -5579,10 +5674,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-message vec 5 "Finding a suitable `touch' command") (let ((result (tramp-find-executable vec "touch" (tramp-get-remote-path vec))) - (tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + (tmpfile (tramp-make-tramp-temp-name vec))) ;; Busyboxes do support the "-t" option only when they have been ;; built with the DESKTOP config option. Let's check it. (when result @@ -5594,7 +5686,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (tramp-compat-file-local-name tmpfile)))) + (tramp-file-local-name tmpfile)))) (delete-file tmpfile)) result))) @@ -5697,27 +5789,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "import os; print (os.getuid())" "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) -(defun tramp-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-uid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-uid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-uid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) - (defun tramp-get-remote-gid-with-id (vec id-format) "Implement `tramp-get-remote-gid' for Tramp files using `id'." (tramp-send-command-and-read @@ -5748,26 +5819,59 @@ ID-FORMAT valid values are `string' and `integer'." "import os; print (os.getgid())" "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) -(defun tramp-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-gid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-gid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-gid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) +(defun tramp-get-remote-busybox (vec) + "Determine remote `busybox' command." + (with-tramp-connection-property vec "busybox" + (tramp-message vec 5 "Finding a suitable `busybox' command") + (tramp-find-executable vec "busybox" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-awk (vec) + "Determine remote `awk' command." + (with-tramp-connection-property vec "awk" + (tramp-message vec 5 "Finding a suitable `awk' command") + (or (tramp-find-executable vec "awk" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "awk"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " {} </dev/null")) + command))))) + +(defun tramp-get-remote-hexdump (vec) + "Determine remote `hexdump' command." + (with-tramp-connection-property vec "hexdump" + (tramp-message vec 5 "Finding a suitable `hexdump' command") + (or (tramp-find-executable vec "hexdump" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "hexdump"))) + (and busybox + (tramp-send-command-and-check vec (concat command " </dev/null")) + command))))) + +(defun tramp-get-remote-od (vec) + "Determine remote `od' command." + (with-tramp-connection-property vec "od" + (tramp-message vec 5 "Finding a suitable `od' command") + (or (tramp-find-executable vec "od" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "od"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " -A n </dev/null")) + command))))) + +(defun tramp-get-remote-chmod-h (vec) + "Check whether remote `chmod' supports nofollow argument." + (with-tramp-connection-property vec "chmod-h" + (tramp-message vec 5 "Finding a suitable `chmod' command with nofollow") + (let ((tmpfile (tramp-make-tramp-temp-name vec))) + (prog1 + (tramp-send-command-and-check + vec + (format + "ln -s foo %s && chmod -h %s 0777" + (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile))) + (delete-file tmpfile))))) (defun tramp-get-env-with-u-option (vec) "Check, whether the remote `env' command supports the -u option." @@ -5786,10 +5890,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. @@ -5807,11 +5910,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) @@ -5889,9 +5990,6 @@ function cell is returned to be applied on a buffer." ;; likely to produce long command lines, and some shells choke on ;; long command lines. ;; -;; * Don't search for perl5 and perl. Instead, only search for perl and -;; then look if it's the right version (with `perl -v'). -;; ;; * When editing a remote CVS controlled file as a different user, VC ;; gets confused about the file locking status. Try to find out why ;; the workaround doesn't work. diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index bf77ab9dee8..947e6a767c7 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -75,12 +75,23 @@ ;;;###tramp-autoload (defcustom tramp-smb-conf "/dev/null" - "Path of the smb.conf file. -If it is nil, no smb.conf will be added to the `tramp-smb-program' + "Path of the \"smb.conf\" file. +If it is nil, no \"smb.conf\" will be added to the `tramp-smb-program' call, letting the SMB client use the default one." :group 'tramp :type '(choice (const nil) (file :must-match t))) +;;;###tramp-autoload +(defcustom tramp-smb-options nil + "List of additional options. +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") + (defvar tramp-smb-version nil "Version string of the SMB client.") @@ -135,6 +146,7 @@ call, letting the SMB client use the default one." "NT_STATUS_HOST_UNREACHABLE" "NT_STATUS_IMAGE_ALREADY_LOADED" "NT_STATUS_INVALID_LEVEL" + "NT_STATUS_INVALID_PARAMETER" "NT_STATUS_INVALID_PARAMETER_MIX" "NT_STATUS_IO_TIMEOUT" "NT_STATUS_LOGON_FAILURE" @@ -281,6 +293,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -329,10 +343,9 @@ This can be used to disable echo etc." "Invoke the SMB related OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-smb-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) @@ -420,16 +433,12 @@ pass to the OPERATION." v tramp-file-missing "Copying directory" "No such file or directory" dirname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (cond ;; We must use a local temporary directory. ((and t1 t2) - (let ((tmpdir - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (let ((tmpdir (tramp-compat-make-temp-name))) (unwind-protect (progn (make-directory tmpdir) @@ -457,11 +466,9 @@ pass to the OPERATION." (localname (file-name-as-directory (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E"))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -471,6 +478,10 @@ pass to the OPERATION." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (if t1 ;; Source is remote. @@ -539,10 +550,11 @@ pass to the OPERATION." ;; Handle KEEP-DATE argument. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes dirname)))) + (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless keep-date @@ -581,47 +593,47 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." tramp-file-missing "Copying file" "No such file or directory" filename)) - (let ((tmpfile (file-local-copy filename))) - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (tramp-compat-directory-name-p newname)) - (setq newname - (expand-file-name (file-name-nondirectory filename) newname))) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - (unless (tramp-smb-get-share v) - (tramp-error - v 'file-error "Target `%s' must contain a share name" newname)) - (unless (tramp-smb-send-command - v (format "put \"%s\" \"%s\"" - (tramp-compat-file-name-unquote filename) - (tramp-smb-get-localname v))) - (tramp-error - v 'file-error "Cannot copy `%s' to `%s'" filename newname)))))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (tramp-smb-get-share v) + (tramp-error + v 'file-error "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v (format "put \"%s\" \"%s\"" + (tramp-compat-file-name-unquote filename) + (tramp-smb-get-localname v))) + (tramp-error + v 'file-error "Cannot copy `%s' to `%s'" filename newname))))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive _trash) "Like `delete-directory' for Tramp files." @@ -692,11 +704,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (delete nil (mapcar (lambda (x) (when (string-match-p match x) x)) result)))) - ;; Append directory. + ;; Prepend directory. (when full (setq result (mapcar - (lambda (x) (format "%s/%s" directory x)) + (lambda (x) (format "%s/%s" (directory-file-name directory) x)) result))) ;; Sort them if necessary. (unless nosort (setq result (sort result #'string-lessp))) @@ -760,7 +772,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E"))) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -770,6 +783,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -1003,7 +1020,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq filename (expand-file-name filename)) (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (tramp-compat-directory-name-p filename) + (when (and (directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) (if full-directory-p @@ -1188,9 +1205,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1244,7 +1259,7 @@ component is used as the target of the symlink." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -1357,7 +1372,7 @@ component is used as the target of the symlink." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -1414,7 +1429,8 @@ component is used as the target of the symlink." "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string)))) + "\n" "," acl-string))) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1424,6 +1440,10 @@ component is used as the target of the symlink." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -1468,15 +1488,17 @@ component is used as the target of the symlink." (tramp-flush-connection-property v "process-name") (tramp-flush-connection-property v "process-buffer"))))))) -(defun tramp-smb-handle-set-file-modes (filename mode) +(defun tramp-smb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-properties v localname) - (unless (tramp-smb-send-command - v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename))))) + ;; smbclient chmod does not support nofollow. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (when (tramp-smb-get-cifs-capabilities v) + (tramp-flush-file-properties v localname) + (unless (tramp-smb-send-command + v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename)))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -1557,9 +1579,6 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1579,6 +1598,10 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Cannot write `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -1844,7 +1867,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) @@ -1861,8 +1884,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 \"/\"")))) @@ -1924,11 +1946,9 @@ If ARGUMENT is non-nil, use it as argument for ;; connection timeout. (with-current-buffer buf (goto-char (point-min)) - ;; `seconds-to-time' can be removed once we get rid of Emacs 24. - (when (and (time-less-p (seconds-to-time 60) - (time-since - (tramp-get-connection-property - p "last-cmd-time" (seconds-to-time 0)))) + (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) @@ -1949,6 +1969,7 @@ If ARGUMENT is non-nil, use it as argument for (host (tramp-file-name-host vec)) (domain (tramp-file-name-domain vec)) (port (tramp-file-name-port vec)) + (options tramp-smb-options) args) (cond @@ -1967,6 +1988,10 @@ If ARGUMENT is non-nil, use it as argument for (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (when argument (setq args (append args (list argument)))) @@ -1994,7 +2019,7 @@ If ARGUMENT is non-nil, use it as argument for (set-process-query-on-exit-flag p nil) (condition-case err - (let (tramp-message-show-message) + (let ((inhibit-message t)) ;; Play login scenario. (tramp-process-actions p vec nil @@ -2132,7 +2157,5 @@ Removes smb prompt. Returns nil if an error message has appeared." ;; ;; * Try to remove the inclusion of dummy "" directory. Seems to be at ;; several places, especially in `tramp-smb-handle-insert-directory'. -;; -;; * Ignore case in file names. ;;; tramp-smb.el ends here diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 08188cefde3..05242ffd970 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -132,6 +132,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -153,10 +155,9 @@ See `tramp-actions-before-shell' for more info.") "Invoke the SUDOEDIT handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (tramp--with-startup @@ -248,7 +249,7 @@ absolute file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and (file-remote-p filename) (not t1)) @@ -265,10 +266,8 @@ absolute file names." v 0 (format "%s %s to %s" msg-operation filename newname) (unless (tramp-sudoedit-send-command v sudoedit-operation - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename)) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name newname))) + (tramp-unquote-file-local-name filename) + (tramp-unquote-file-local-name newname)) (tramp-error v 'file-error "Error %s `%s' `%s'" msg-operation filename newname)))) @@ -284,7 +283,8 @@ absolute file names." ;; Set the time and mode. Mask possible errors. (when keep-date (ignore-errors - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes))) ;; Handle `preserve-extended-attributes'. We ignore possible @@ -305,8 +305,8 @@ absolute file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -375,7 +375,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) @@ -466,19 +466,21 @@ the result will be a local, non-Tramp, file name." (tramp-sudoedit-send-command v "test" "-r" (tramp-compat-file-name-unquote localname))))) -(defun tramp-sudoedit-handle-set-file-modes (filename mode) +(defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (unless (tramp-sudoedit-send-command - v "chmod" (format "%o" mode) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) + ;; It is unlikely that "chmod -h" works. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (unless (tramp-sudoedit-send-command + v "chmod" (format "%o" mode) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename))))) (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) @@ -524,7 +526,7 @@ the result will be a local, non-Tramp, file name." (string-to-number (match-string 2))) (string-to-number (match-string 3))))))))) -(defun tramp-sudoedit-handle-set-file-times (filename &optional time) +(defun tramp-sudoedit-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -537,14 +539,14 @@ the result will be a local, non-Tramp, file name." (tramp-sudoedit-send-command v "env" "TZ=UTC" "touch" "-t" (format-time-string "%Y%m%d%H%M.%S" time t) + (if (eq flag 'nofollow) "-h" "") (tramp-compat-file-name-unquote localname))))) (defun tramp-sudoedit-handle-file-truename (filename) "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -615,9 +617,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -646,8 +646,8 @@ component is used as the target of the symlink." (defun tramp-sudoedit-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -691,21 +691,19 @@ component is used as the target of the symlink." (tramp-flush-file-property v localname "file-selinux-context")) t))))) -(defun tramp-sudoedit-get-remote-uid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-u") - (tramp-sudoedit-send-command-string vec "id" "-un")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-u") + (tramp-sudoedit-send-command-string vec "id" "-un"))) -(defun tramp-sudoedit-get-remote-gid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-g") - (tramp-sudoedit-send-command-string vec "id" "-gn")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-g") + (tramp-sudoedit-send-command-string vec "id" "-gn"))) (defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -713,22 +711,22 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-sudoedit-send-command v "chown" (format "%d:%d" - (or uid (tramp-sudoedit-get-remote-uid v 'integer)) - (or gid (tramp-sudoedit-get-remote-gid v 'integer))) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename))))) + (or uid (tramp-get-remote-uid v 'integer)) + (or gid (tramp-get-remote-gid v 'integer))) + (tramp-unquote-file-local-name filename)))) (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (with-parsed-tramp-file-name filename nil - (let ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-gid v 'integer))) - (modes (tramp-default-file-modes filename))) + (let* ((uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer))) + (flag (and (eq mustbenew 'excl) 'nofollow)) + (modes (tramp-default-file-modes filename flag))) (prog1 (tramp-handle-write-region start end filename append visit lockname mustbenew) @@ -742,7 +740,7 @@ ID-FORMAT valid values are `string' and `integer'." (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) - (set-file-modes filename modes))))) + (tramp-compat-set-file-modes filename modes flag))))) ;; Internal functions. @@ -787,14 +785,7 @@ connection if a previous connection has died for some reason." (tramp-set-connection-local-variables vec) ;; Mark it as connected. - (tramp-set-connection-property p "connected" t)) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (tramp-sudoedit-get-remote-uid vec 'integer) - (tramp-sudoedit-get-remote-gid vec 'integer) - (tramp-sudoedit-get-remote-uid vec 'string) - (tramp-sudoedit-get-remote-gid vec 'string))) + (tramp-set-connection-property p "connected" t)))) (defun tramp-sudoedit-send-command (vec &rest args) "Send commands ARGS to connection VEC. diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el index 6a044e58840..f368f72a8dc 100644 --- a/lisp/net/tramp-uu.el +++ b/lisp/net/tramp-uu.el @@ -94,8 +94,3 @@ (provide 'tramp-uu) ;;; tramp-uu.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 4f3249d966a..1566162feaf 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.4.3 -;; Package-Requires: ((emacs "24.4")) +;; Version: 2.5.0-pre +;; Package-Requires: ((emacs "25.1")) ;; Package-Type: multi ;; URL: https://savannah.gnu.org/projects/tramp @@ -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 ;; @@ -63,6 +64,7 @@ ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function file-notify-rm-watch "filenotify") (declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) @@ -744,7 +746,7 @@ to be set, depending on VALUE." tramp-postfix-host-format (tramp-build-postfix-host-format) tramp-postfix-host-regexp (tramp-build-postfix-host-regexp) tramp-remote-file-name-spec-regexp - (tramp-build-remote-file-name-spec-regexp) + (tramp-build-remote-file-name-spec-regexp) tramp-file-name-structure (tramp-build-file-name-structure) tramp-file-name-regexp (tramp-build-file-name-regexp) tramp-completion-file-name-regexp @@ -1258,7 +1260,7 @@ calling HANDLER.") ;; data structure. ;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 24 and 25. +;; in order to be compatible with Emacs 25. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1306,9 +1308,10 @@ entry does not exist, return nil." ;; We use the cached property. (tramp-get-connection-property vec hash-entry nil) ;; Use the static value from `tramp-methods'. - (let ((methods-entry - (assoc param (assoc (tramp-file-name-method vec) tramp-methods)))) - (when methods-entry (cadr methods-entry)))))) + (when-let ((methods-entry + (assoc + param (assoc (tramp-file-name-method vec) tramp-methods)))) + (cadr methods-entry))))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-file-name-unquote-localname (vec) @@ -1347,6 +1350,11 @@ of `process-file', `start-file-process', or `shell-command'." (match-string (nth 4 tramp-file-name-structure) name)) (tramp-compat-file-local-name name))) +;; The localname can be quoted with "/:". Extract this. +(defun tramp-unquote-file-local-name (name) + "Return unquoted localname of NAME." + (tramp-compat-file-name-unquote (tramp-file-local-name name))) + (defun tramp-find-method (method user host) "Return the right method string to use depending on USER and HOST. This is METHOD, if non-nil. Otherwise, do a lookup in @@ -1363,8 +1371,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or host "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lmethod (nth 2 item)) - (setq choices nil))) + (setq lmethod (nth 2 item) + choices nil))) lmethod) tramp-default-method))) ;; We must mark, whether a default value has been used. @@ -1384,8 +1392,8 @@ This is USER, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or host ""))) - (setq luser (nth 2 item)) - (setq choices nil))) + (setq luser (nth 2 item) + choices nil))) luser) tramp-default-user))) ;; We must mark, whether a default value has been used. @@ -1405,8 +1413,8 @@ This is HOST, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lhost (nth 2 item)) - (setq choices nil))) + (setq lhost (nth 2 item) + choices nil))) lhost) tramp-default-host))) ;; We must mark, whether a default value has been used. @@ -1468,7 +1476,7 @@ default values are used." :method method :user user :domain domain :host host :port port :localname localname :hop hop)) ;; The method must be known. - (unless (or nodefault (tramp-completion-mode-p) + (unless (or nodefault non-essential (string-equal method tramp-default-method-marker) (assoc method tramp-methods)) (tramp-user-error @@ -1592,7 +1600,7 @@ necessary only. This function will be used in file name completion." tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host) tramp-postfix-host-format)) - (when localname localname))) + localname)) (defun tramp-get-buffer (vec &optional dont-create) "Get the connection buffer to be used for VEC. @@ -1625,6 +1633,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 @@ -1648,7 +1665,7 @@ version, the function does nothing." "Set connection-local variables in the current buffer. If connection-local variables are not supported by this Emacs version, the function does nothing." - (when (file-remote-p default-directory) + (when (tramp-tramp-file-p default-directory) ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. (tramp-compat-funcall 'hack-connection-local-variables-apply @@ -1744,29 +1761,10 @@ ARGUMENTS to actually emit the message (if applicable)." (setq btf (nth 1 (backtrace-frame btn))) (if (not btf) (setq fn "") - (when (symbolp btf) - (setq fn (symbol-name btf)) - (unless - (and - (string-match-p "^tramp" fn) - (not - (string-match-p - (eval-when-compile - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-funcall" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message" - "tramp-signal-hook-function" - "tramp-user-error") - t) - "$")) - fn))) - (setq fn nil))) + (and (symbolp btf) (setq fn (symbol-name btf)) + (or (not (string-match-p "^tramp" fn)) + (get btf 'tramp-suppress-trace)) + (setq fn nil)) (setq btn (1+ btn)))) ;; The following code inserts filename and line number. Should ;; be inactive by default, because it is time consuming. @@ -1781,11 +1779,11 @@ ARGUMENTS to actually emit the message (if applicable)." ;; The message. (insert (apply #'format-message fmt-string arguments)))) -(defvar tramp-message-show-message (null noninteractive) - "Show Tramp message in the minibuffer. -This variable is used to suppress progress reporter output, and -to disable messages from `tramp-error'. Those messages are -visible anyway, because an error is raised.") +(put #'tramp-debug-message 'tramp-suppress-trace t) + +(defvar tramp-inhibit-progress-reporter nil + "Show Tramp progress reporter in the minibuffer. +This variable is used to disable concurrent progress reporter messages.") (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -1802,8 +1800,9 @@ 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. - (when (and tramp-message-show-message (<= level 3)) + ;; 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 @@ -1835,6 +1834,8 @@ applicable)." (concat (format "(%d) # " level) fmt-string) arguments)))))) +(put #'tramp-message 'tramp-suppress-trace t) + (defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This @@ -1845,13 +1846,16 @@ function is meant for debugging purposes." vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) +(put #'tramp-backtrace 'tramp-suppress-trace t) + (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 (tramp-message-show-message signal-hook-function) + (let ((inhibit-message t) + signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments ;; FMT-STRING could be just a file name, as in @@ -1869,6 +1873,8 @@ FMT-STRING and ARGUMENTS." (signal signal (list (substring-no-properties (apply #'format-message fmt-string arguments)))))) +(put #'tramp-error 'tramp-suppress-trace t) + (defsubst tramp-error-with-buffer (buf vec-or-proc signal fmt-string &rest arguments) "Emit an error, and show BUF. @@ -1886,13 +1892,13 @@ an input event arrives. The other arguments are passed to `tramp-error'." (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. (when (and buf - tramp-message-show-message (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + inhibit-message) ;; `tramp-error' does not show messages. So we must do it ;; ourselves. (apply #'message fmt-string arguments) @@ -1904,19 +1910,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +(put #'tramp-error-with-buffer 'tramp-suppress-trace t) + ;; 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 tramp-message-show-message - (not (zerop tramp-verbose)) + (when (and (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (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) @@ -1926,18 +1934,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (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 (debug (symbolp body)) - (indent 2)) + (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)))) +(put #'tramp-with-demoted-errors 'tramp-suppress-trace t) + ;; This function provides traces in case of errors not triggered by ;; Tramp functions. (defun tramp-signal-hook-function (error-symbol data) @@ -1949,6 +1960,8 @@ the resulting error message." (car tramp-current-connection) error-symbol "%s" (mapconcat (lambda (x) (format "%s" x)) data " ")))) +(put #'tramp-signal-hook-function 'tramp-suppress-trace t) + (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -1965,12 +1978,14 @@ Remaining args are Lisp expressions to be evaluated (inside an implicit If VAR is nil, then we bind `v' to the structure and `method', `user', `domain', `host', `port', `localname', `hop' to the components." + (declare (indent 2) (debug (form symbolp body))) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(tramp-compat-tramp-file-name-slots)))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))) `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, @@ -1979,8 +1994,6 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (ignore ,@(mapcar #'car bindings)) ,@body))) -(put 'with-parsed-tramp-file-name 'lisp-indent-function 2) -(put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defun tramp-progress-reporter-update (reporter &optional value suffix) @@ -1991,25 +2004,28 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) - "Execute BODY, spinning a progress reporter with MESSAGE. + "Execute BODY, spinning a progress reporter with MESSAGE in interactive mode. If LEVEL does not fit for visible messages, there are only traces without a visible progress reporter." (declare (indent 3) (debug t)) - `(progn + `(if (or noninteractive inhibit-message) + (progn ,@body) (tramp-message ,vec ,level "%s..." ,message) (let ((cookie "failed") (tm - ;; We start a pulsing progress reporter after 3 seconds. - (when (and tramp-message-show-message - ;; Display only when there is a minimum level. - (<= ,level (min tramp-verbose 3))) - (let ((pr (make-progress-reporter ,message nil nil))) - (when pr - (run-at-time - 3 0.1 #'tramp-progress-reporter-update pr)))))) + ;; We start a pulsing progress reporter after 3 + ;; seconds. Display only when there is a minimum level. + (when-let ((pr (and (<= ,level (min tramp-verbose 3)) + (make-progress-reporter ,message nil nil)))) + (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) (unwind-protect ;; Execute the body. - (prog1 (progn ,@body) (setq cookie "done")) + (prog1 + ;; Suppress concurrent progress reporter messages. + (let ((tramp-inhibit-progress-reporter + (or tramp-inhibit-progress-reporter tm))) + ,@body) + (setq cookie "done")) ;; Stop progress reporter. (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) @@ -2020,6 +2036,7 @@ without a visible progress reporter." (defmacro with-tramp-file-property (vec file property &rest body) "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. FILE must be a local file name on a connection identified via VEC." + (declare (indent 3) (debug t)) `(if (file-name-absolute-p ,file) (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) (when (eq value 'undef) @@ -2031,12 +2048,11 @@ FILE must be a local file name on a connection identified via VEC." value) ,@body)) -(put 'with-tramp-file-property 'lisp-indent-function 3) -(put 'with-tramp-file-property 'edebug-form-spec t) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) (defmacro with-tramp-connection-property (key property &rest body) "Check in Tramp for property PROPERTY, otherwise execute BODY and set." + (declare (indent 2) (debug t)) `(let ((value (tramp-get-connection-property ,key ,property 'undef))) (when (eq value 'undef) ;; We cannot pass ,@body as parameter to @@ -2046,8 +2062,6 @@ FILE must be a local file name on a connection identified via VEC." (tramp-set-connection-property ,key ,property value)) value)) -(put 'with-tramp-connection-property 'lisp-indent-function 2) -(put 'with-tramp-connection-property 'edebug-form-spec t) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) @@ -2066,6 +2080,9 @@ letter into the file name. This function removes it." ;;; Config Manipulation Functions: +(defconst tramp-dns-sd-service-regexp "^_[-[:alnum:]]+\\._tcp$" + "DNS-SD service regexp.") + (defun tramp-set-completion-function (method function-list) "Set the list of completion functions for METHOD. FUNCTION-LIST is a list of entries of the form (FUNCTION FILE). @@ -2098,10 +2115,10 @@ Example: (zerop (tramp-call-process v "reg" nil nil nil "query" (nth 1 (car v)))))) - ;; Zeroconf service type. + ;; DNS-SD service type. ((string-match-p - "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v)))) - ;; Configuration file. + tramp-dns-sd-service-regexp (nth 1 (car v)))) + ;; Configuration file or empty string. (t (file-exists-p (nth 1 (car v)))))) (setq r (delete (car v) r))) (setq v (cdr v))) @@ -2139,11 +2156,13 @@ For definition of that list see `tramp-set-completion-function'." (defvar tramp-devices 0 "Keeps virtual device numbers.") -(defun tramp-default-file-modes (filename) +(defun tramp-default-file-modes (filename &optional flag) "Return file modes of FILENAME as integer. -If the file modes of FILENAME cannot be determined, return the -value of `default-file-modes', without execute permissions." - (or (file-modes filename) +If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a +symbolic link. If the file modes of FILENAME cannot be +determined, return the value of `default-file-modes', without +execute permissions." + (or (tramp-compat-file-modes filename flag) (logand (default-file-modes) #o0666))) (defun tramp-replace-environment-variables (filename) @@ -2174,6 +2193,7 @@ arguments to pass to the OPERATION." tramp-vc-file-name-handler tramp-completion-file-name-handler tramp-archive-file-name-handler + tramp-crypt-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . @@ -2239,7 +2259,7 @@ Must be handled by the callers." file-newer-than-file-p rename-file)) (cond ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + ((file-name-absolute-p (nth 1 args)) (nth 1 args)) (t default-directory))) ;; FILE DIRECTORY resp FILE1 FILE2. ((eq operation 'expand-file-name) @@ -2267,13 +2287,13 @@ Must be handled by the callers." exec-path make-process)) default-directory) ;; PROC. - ((member operation - '(file-notify-rm-watch - ;; Emacs 25+ only. - file-notify-valid-p)) + ((member operation '(file-notify-rm-watch file-notify-valid-p)) (when (processp (nth 0 args)) (with-current-buffer (process-buffer (nth 0 args)) default-directory))) + ;; VEC. + ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) + (tramp-make-tramp-file-name (nth 0 args))) ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) @@ -2390,7 +2410,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (cons operation args)) (tramp-run-real-handler operation args)) ((eq result 'suppress) - (let (tramp-message-show-message) + (let ((inhibit-message t)) (tramp-message v 1 "Suppress received in operation %s" (cons operation args)) @@ -2419,18 +2439,21 @@ Fall back to normal file name handler if no Tramp file name handler exists." (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler for OPERATION and ARGS. Falls back to normal file name handler if no Tramp file name handler exists." - (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) - (if (and fn tramp-mode) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let + ((fn (and tramp-mode + (assoc operation tramp-completion-file-name-handler-alist)))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) - (if tramp-mode - (let ((default-directory temporary-file-directory)) - (load "tramp" 'noerror 'nomessage))) + (when tramp-mode + ;; We cannot use `tramp-compat-temporary-file-directory' here due + ;; to autoload. + (let ((default-directory temporary-file-directory)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2442,7 +2465,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) - (put 'tramp-autoload-file-name-handler 'safe-magic t))) + (put #'tramp-autoload-file-name-handler 'safe-magic t))) ;;;###autoload (tramp-register-autoload-file-name-handlers) @@ -2478,34 +2501,36 @@ remote file names." (tramp-unload-file-name-handlers) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler' and - ;; `tramp-archive-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler', + ;; `tramp-archive-file-name-handler' and + ;; `tramp-crypt-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp #'tramp-file-name-handler)) - (put 'tramp-file-name-handler 'safe-magic t) + (put #'tramp-file-name-handler 'safe-magic t) + + (tramp-register-crypt-file-name-handler) (add-to-list 'file-name-handler-alist (cons tramp-completion-file-name-regexp #'tramp-completion-file-name-handler)) - (put 'tramp-completion-file-name-handler 'safe-magic t) + (put #'tramp-completion-file-name-handler 'safe-magic t) ;; Mark `operations' the handler is responsible for. - (put 'tramp-completion-file-name-handler 'operations + (put #'tramp-completion-file-name-handler 'operations (mapcar #'car tramp-completion-file-name-handler-alist)) (when (bound-and-true-p tramp-archive-enabled) (add-to-list 'file-name-handler-alist (cons tramp-archive-file-name-regexp #'tramp-archive-file-name-handler)) - (put 'tramp-archive-file-name-handler 'safe-magic t)) + (put #'tramp-archive-file-name-handler 'safe-magic t)) ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) - (let ((entry (rassoc fnh file-name-handler-alist))) - (when entry - (setq file-name-handler-alist - (cons entry (delete entry file-name-handler-alist))))))) + (when-let ((entry (rassoc fnh file-name-handler-alist))) + (setq file-name-handler-alist + (cons entry (delete entry file-name-handler-alist)))))) (tramp--with-startup (tramp-register-file-name-handlers)) @@ -2517,7 +2542,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (add-to-list 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) ;; Mark `operations' the handler is responsible for. - (put 'tramp-file-name-handler + (put #'tramp-file-name-handler 'operations (delete-dups (append @@ -2558,24 +2583,11 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;; File name handler functions for completion mode: -;;;###autoload -(defvar tramp-completion-mode nil - "If non-nil, external packages signal that they are in file name completion.") -(make-obsolete-variable 'tramp-completion-mode 'non-essential "26.1") - -(defun tramp-completion-mode-p () - "Check, whether method / user name / host name completion is active." - (or - ;; Signal from outside. - non-essential - ;; This variable has been obsoleted in Emacs 26. - tramp-completion-mode)) - (defun tramp-connectable-p (vec-or-filename) "Check, whether it is possible to connect the remote host w/o side-effects. This is true, if either the remote host is already connected, or if we are not in completion mode." - (let (tramp-verbose + (let ((tramp-verbose 0) (vec (cond ((tramp-file-name-p vec-or-filename) vec-or-filename) @@ -2585,7 +2597,7 @@ not in completion mode." ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. (and vec (process-live-p (get-process (tramp-buffer-name vec)))) - (not (tramp-completion-mode-p))))) + (not non-essential)))) ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of @@ -2864,7 +2876,7 @@ User is always nil." (let ((default-directory (tramp-compat-temporary-file-directory))) (when (file-readable-p filename) (with-temp-buffer - (insert-file-contents filename) + (insert-file-contents-literally filename) (goto-char (point-min)) (cl-loop while (not (eobp)) collect (funcall function)))))) @@ -2876,7 +2888,7 @@ Either user or host may be nil." (defun tramp-parse-rhosts-group () "Return a (user host) tuple allowed to access. Either user or host may be nil." - (let ((result) + (let (result (regexp (concat "^\\(" tramp-host-regexp "\\)" @@ -2961,7 +2973,7 @@ Host is always \"localhost\"." (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (regexp (concat "^\\(" tramp-user-regexp "\\):"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list (match-string 1) "localhost"))) @@ -2983,7 +2995,7 @@ Host is always \"localhost\"." (defun tramp-parse-etc-group-group () "Return a (group host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (split (split-string (buffer-substring (point) (point-at-eol)) ":"))) (when (member (user-login-name) (split-string (nth 3 split) "," 'omit)) (setq result (list (nth 0 split) "localhost"))) @@ -3020,7 +3032,7 @@ User is always nil." (defun tramp-parse-putty-group (registry) "Return a (user host) tuple allowed to access. User is always nil." - (let ((result) + (let (result (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list nil (match-string 1)))) @@ -3199,12 +3211,13 @@ User is always nil." (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) -(defun tramp-handle-file-modes (filename) +(defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." - ;; Starting with Emacs 25.1, `when-let' can be used. - (let ((attrs (file-attributes (or (file-truename filename) filename)))) - (when attrs - (tramp-mode-string-to-int (tramp-compat-file-attribute-modes attrs))))) + (when-let ((attrs (file-attributes filename)) + (mode-string (tramp-compat-file-attribute-modes attrs))) + (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) + (file-modes (file-truename filename)) + (tramp-mode-string-to-int mode-string)))) ;; Localname manipulation functions that grok Tramp localnames... (defun tramp-handle-file-name-as-directory (file) @@ -3247,7 +3260,7 @@ User is always nil." ;; lower case letters. This avoids us to create a ;; temporary file. (while (and (string-match-p - "[a-z]" (tramp-compat-file-local-name candidate)) + "[a-z]" (tramp-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3257,8 +3270,7 @@ User is always nil." ;; to Emacs 26+ like `file-name-case-insensitive-p', ;; so there is no compatibility problem calling it. (unless - (string-match-p - "[a-z]" (tramp-compat-file-local-name candidate)) + (string-match-p "[a-z]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3271,7 +3283,7 @@ User is always nil." (file-exists-p (concat (file-remote-p candidate) - (upcase (tramp-compat-file-local-name candidate)))) + (upcase (tramp-file-local-name candidate)))) ;; Cleanup. (when tmpfile (delete-file tmpfile))))))))))) @@ -3323,21 +3335,18 @@ User is always nil." (cond ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) - (t (time-less-p (tramp-compat-file-attribute-modification-time - (file-attributes file2)) - (tramp-compat-file-attribute-modification-time - (file-attributes file1)))))) + (t (time-less-p + (tramp-compat-file-attribute-modification-time (file-attributes file2)) + (tramp-compat-file-attribute-modification-time + (file-attributes file1)))))) (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." (and (file-exists-p filename) ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. - (ignore-errors - (eq ?- - (aref - (tramp-compat-file-attribute-modes (file-attributes filename)) - 0))))) + (when-let ((attr (file-attributes filename))) + (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3376,8 +3385,7 @@ User is always nil." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -3389,6 +3397,8 @@ User is always nil." ;; something is wrong; otherwise they might think that Emacs ;; is hung. Of course, correctness has to come first. (numchase-limit 20) + ;; Unquoting could enable encryption. + tramp-crypt-enabled symlink-target) (with-parsed-tramp-file-name result v1 ;; We cache only the localname. @@ -3413,7 +3423,7 @@ User is always nil." (tramp-error v1 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (tramp-compat-file-local-name (directory-file-name result))))))))) + (tramp-file-local-name (directory-file-name result))))))))) (defun tramp-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -3448,7 +3458,7 @@ User is always nil." "Like `insert-directory' for Tramp files." (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (tramp-compat-directory-name-p filename) + (when (and (directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) ;; Check, whether directory is accessible. @@ -3458,7 +3468,7 @@ User is always nil." (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (let (ls-lisp-use-insert-directory-program start) ;; Silence byte compiler. - ls-lisp-use-insert-directory-program + (ignore ls-lisp-use-insert-directory-program) (tramp-run-real-handler #'insert-directory (list filename switches wildcard full-directory-p)) @@ -3509,6 +3519,9 @@ User is always nil." ;; copy this part. This works only for the shell file ;; name handlers. (when (and (or beg end) + ;; Direct actions aren't possible for + ;; crypted directories. + (null tramp-crypt-enabled) (tramp-get-method-parameter v 'tramp-login-program)) (setq remote-copy (tramp-make-tramp-temp-file v)) @@ -3582,8 +3595,8 @@ User is always nil." ;; Save exit. (progn (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) + (setq buffer-file-name filename + buffer-read-only (not (file-writable-p filename))) (set-visited-file-modtime) (set-buffer-modified-p nil)) (when (and (stringp local-copy) @@ -3617,7 +3630,8 @@ User is always nil." v tramp-file-missing "Cannot load nonexistent file `%s'" file)) (if (not (file-exists-p file)) nil - (let ((tramp-message-show-message (not nomessage))) + (let ((signal-hook-function (unless noerror signal-hook-function)) + (inhibit-message (or inhibit-message nomessage))) (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) (unwind-protect @@ -3645,10 +3659,16 @@ support symbolic links." (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) (command (substring command 0 asynchronous)) current-buffer-p + (output-buffer-p output-buffer) (output-buffer (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) + ((bufferp output-buffer) + (setq current-buffer-p (eq (current-buffer) output-buffer)) + output-buffer) + ((stringp output-buffer) + (setq current-buffer-p + (eq (buffer-name (current-buffer)) output-buffer)) + (get-buffer-create output-buffer)) (output-buffer (setq current-buffer-p t) (current-buffer)) @@ -3660,13 +3680,19 @@ support symbolic links." (cond ((bufferp error-buffer) error-buffer) ((stringp error-buffer) (get-buffer-create error-buffer)))) + (error-file + (and error-buffer + (with-parsed-tramp-file-name default-directory nil + (tramp-make-tramp-file-name + v (tramp-make-tramp-temp-file v))))) (bname (buffer-name output-buffer)) (p (get-buffer-process output-buffer)) + (dir default-directory) buffer) ;; The following code is taken from `shell-command', slightly ;; adapted. Shouldn't it be factored out? - (when p + (when (and (integerp asynchronous) p) (cond ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. @@ -3698,22 +3724,25 @@ support symbolic links." (rename-uniquely)) (setq output-buffer (get-buffer-create bname))))) - (setq buffer (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer - (tramp-make-tramp-file-name - v (tramp-make-tramp-temp-file v)))) - output-buffer)) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) + (unless output-buffer-p (with-current-buffer output-buffer + (setq default-directory dir))) + + (setq buffer (if error-file (list output-buffer error-file) output-buffer)) + + (with-current-buffer output-buffer + (when current-buffer-p + (barf-if-buffer-read-only) + (push-mark nil t)) + ;; `shell-command-save-pos-or-erase' has been introduced with + ;; Emacs 27.1. + (if (fboundp 'shell-command-save-pos-or-erase) + (tramp-compat-funcall + 'shell-command-save-pos-or-erase current-buffer-p) (setq buffer-read-only nil) (erase-buffer))) - (if (and (not current-buffer-p) (integerp asynchronous)) + (if (integerp asynchronous) (let ((tramp-remote-process-environment ;; `async-shell-command-width' has been introduced with ;; Emacs 27.1. @@ -3726,42 +3755,69 @@ support symbolic links." ;; Run the process. (setq p (start-file-process-shell-command (buffer-name output-buffer) buffer command)) - ;; Display output. - (with-current-buffer output-buffer - (display-buffer output-buffer '(nil (allow-no-window . t))) - (setq mode-line-process '(":%s")) - (shell-mode) - (set-process-sentinel p #'shell-command-sentinel) - (set-process-filter p #'comint-output-filter)))) + ;; Insert error messages if they were separated. + (when error-file + (with-current-buffer error-buffer + (insert-file-contents-literally error-file))) + (if (process-live-p p) + ;; Display output. + (with-current-buffer output-buffer + (setq mode-line-process '(":%s")) + (unless (eq major-mode 'shell-mode) + (shell-mode)) + (set-process-filter p #'comint-output-filter) + (set-process-sentinel p #'shell-command-sentinel) + (when error-file + (add-function + :after (process-sentinel p) + (lambda (_proc _string) + (with-current-buffer error-buffer + (insert-file-contents-literally + error-file nil nil nil 'replace)) + (delete-file error-file)))) + (display-buffer output-buffer '(nil (allow-no-window . t)))) + + (when error-file + (delete-file error-file))))) (prog1 ;; Run the process. (process-file-shell-command command nil buffer nil) ;; Insert error messages if they were separated. - (when (listp buffer) + (when error-file (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) + (insert-file-contents-literally error-file)) + (delete-file error-file)) (if current-buffer-p ;; This is like exchange-point-and-mark, but doesn't ;; activate the mark. It is cleaner to avoid activation, ;; even though the command loop would deactivate the mark ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) + (progn + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) + (current-buffer)))) + ;; `shell-command-set-point-after-cmd' has been + ;; introduced with Emacs 27.1. + (if (fboundp 'shell-command-set-point-after-cmd) + (tramp-compat-funcall + 'shell-command-set-point-after-cmd))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) (defun tramp-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - ;; `make-process' knows the `:file-handler' argument since Emacs 27.1 only. + "Like `start-file-process' for Tramp files. +BUFFER might be a list, in this case STDERR is separated." + ;; `make-process' knows the `:file-handler' argument since Emacs + ;; 27.1 only. Therefore, we invoke it via `tramp-file-name-handler'. (tramp-file-name-handler 'make-process :name name - :buffer buffer + :buffer (if (consp buffer) (car buffer) buffer) :command (and program (cons program args)) + ;; `shell-command' adds an errfile to `buffer'. + :stderr (when (consp buffer) (cadr buffer)) :noquery nil :file-handler t)) @@ -3862,7 +3918,14 @@ of." (tramp-error v 'file-already-exists filename)) (let ((tmpfile (tramp-compat-make-temp-file filename)) - (modes (save-excursion (tramp-default-file-modes filename)))) + (modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + (uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -3881,15 +3944,18 @@ of." (error (delete-file tmpfile) (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) + v 'file-error "Couldn't write region to `%s'" filename))) - (tramp-flush-file-properties v localname) + (tramp-flush-file-properties v localname) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; Set the ownership. + (tramp-set-file-uid-gid filename uid gid)) ;; The end. (when (and (null noninteractive) @@ -3943,7 +4009,7 @@ of." "Call `file-notify-rm-watch'." (unless (process-live-p proc) (tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-compat-funcall 'file-notify-rm-watch proc))) + (file-notify-rm-watch proc))) ;;; Functions for establishing connection: @@ -4044,6 +4110,8 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." (unless (process-live-p proc) + ;; There might be pending output. + (while (tramp-accept-process-output proc 0)) (throw 'tramp-action 'process-died))) (defun tramp-action-out-of-band (proc vec) @@ -4083,9 +4151,9 @@ See `tramp-process-actions' for the format of ACTIONS." (while (tramp-accept-process-output proc 0)) (setq todo actions) (while todo - (setq item (pop todo)) - (setq pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item)))) - (setq action (nth 1 item)) + (setq item (pop todo) + pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item))) + action (nth 1 item)) (tramp-message vec 5 "Looking for regexp \"%s\" from remote shell" pattern) (when (tramp-check-for-regexp proc pattern) @@ -4135,9 +4203,8 @@ performed successfully. Any other value means an error." (catch 'tramp-action (tramp-process-one-action proc vec actions))))) (while (not exit) - (setq exit - (catch 'tramp-action - (tramp-process-one-action proc vec actions))))) + (setq exit (catch 'tramp-action + (tramp-process-one-action proc vec actions))))) (with-current-buffer (tramp-get-connection-buffer vec) (widen) (tramp-message vec 6 "\n%s" (buffer-string))) @@ -4176,18 +4243,21 @@ performed successfully. Any other value means an error." (defun tramp-accept-process-output (proc &optional timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set -for process communication also." +for process communication also. +If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." (with-current-buffer (process-buffer proc) (let ((inhibit-read-only t) last-coding-system-used result) - ;; JUST-THIS-ONE is set due to Bug#12145. - (tramp-message - proc 10 "%s %s %s %s\n%s" - proc timeout (process-status proc) - (with-local-quit - (setq result (accept-process-output proc timeout nil t))) - (buffer-string)) + ;; JUST-THIS-ONE is set due to Bug#12145. `with-local-quit' + ;; returns t in order to report success. + (if (with-local-quit + (setq result (accept-process-output proc timeout nil t)) t) + (tramp-message + proc 10 "%s %s %s %s\n%s" + proc timeout (process-status proc) result (buffer-string)) + ;; Propagate quit. + (keyboard-quit)) result))) (defun tramp-search-regexp (regexp) @@ -4362,7 +4432,7 @@ would yield t. On the other hand, the following check results in nil: (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\") If both files are local, the function returns t." - (or (and (null (file-remote-p file1)) (null (file-remote-p file2))) + (or (and (null (tramp-tramp-file-p file1)) (null (tramp-tramp-file-p file2))) (and (tramp-tramp-file-p file1) (tramp-tramp-file-p file2) (string-equal (file-remote-p file1) (file-remote-p file2))))) @@ -4455,9 +4525,9 @@ This is used to map a mode number to a permission string.") (suid (> (logand (ash mode -9) 4) 0)) (sgid (> (logand (ash mode -9) 2) 0)) (sticky (> (logand (ash mode -9) 1) 0))) - (setq user (tramp-file-mode-permissions user suid "s")) - (setq group (tramp-file-mode-permissions group sgid "s")) - (setq other (tramp-file-mode-permissions other sticky "t")) + (setq user (tramp-file-mode-permissions user suid "s") + group (tramp-file-mode-permissions group sgid "s") + other (tramp-file-mode-permissions other sticky "t")) (concat type user group other))) (defun tramp-file-mode-permissions (perm suid suid-text) @@ -4487,16 +4557,15 @@ If FILENAME is remote, a file name handler is called." (when (and modes (not (zerop (logand modes #o2000)))) (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) - (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) - (if handler - (funcall handler #'tramp-set-file-uid-gid filename uid gid) - ;; On W32 systems, "chown" does not work. - (unless (memq system-type '(ms-dos windows-nt)) - (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-call-process - nil "chown" nil nil nil (format "%d:%d" uid gid) - (tramp-unquote-shell-quote-argument filename))))))) + (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) + (funcall handler #'tramp-set-file-uid-gid filename uid gid) + ;; On W32 systems, "chown" does not work. + (unless (memq system-type '(ms-dos windows-nt)) + (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-call-process + nil "chown" nil nil nil (format "%d:%d" uid gid) + (tramp-unquote-shell-quote-argument filename)))))) (defun tramp-get-local-uid (id-format) "The uid of the local user, in ID-FORMAT. @@ -4562,12 +4631,8 @@ be granted." (concat "file-attributes-" suffix) nil) (file-attributes (tramp-make-tramp-file-name vec) (intern suffix)))) - (remote-uid - (tramp-get-connection-property - vec (concat "uid-" suffix) nil)) - (remote-gid - (tramp-get-connection-property - vec (concat "gid-" suffix) nil)) + (remote-uid (tramp-get-remote-uid vec (intern suffix))) + (remote-gid (tramp-get-remote-gid vec (intern suffix))) (unknown-id (if (string-equal suffix "string") tramp-unknown-id-string tramp-unknown-id-integer))) @@ -4601,6 +4666,32 @@ be granted." (tramp-compat-file-attribute-group-id file-attr)))))))))))) +(defun tramp-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "uid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-uid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + +(defun tramp-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "gid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-gid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise. This handles also chrooted environments, which are not regarded as local." @@ -4615,15 +4706,15 @@ This handles also chrooted environments, which are not regarded as local." ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. (tramp-get-method-parameter vec 'tramp-login-program) + ;; Direct actions aren't possible for crypted directories. + (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) - ;; This is defined in tramp-sh.el. Let's assume this is - ;; loaded already. - (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer)))))) + (zerop (tramp-get-remote-uid vec 'integer)))))) (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." @@ -4632,22 +4723,25 @@ This handles also chrooted environments, which are not regarded as local." (tramp-make-tramp-file-name vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) - (tramp-compat-file-local-name dir)) + (tramp-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) +(defun tramp-make-tramp-temp-name (vec) + "Generate a temporary file name on the remote host identified by VEC." + (make-temp-name + (expand-file-name tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))) + (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." - (let ((prefix (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))) - result) + (let (result) (while (not result) ;; `make-temp-file' would be the natural choice for ;; implementation. But it calls `write-region' internally, ;; which also needs a temporary file - we would end in an ;; infinite loop. - (setq result (make-temp-name prefix)) + (setq result (tramp-make-tramp-temp-name vec)) (if (file-exists-p result) (setq result nil) ;; This creates the file by side effect. @@ -4655,7 +4749,7 @@ Return the local name of the temporary file." (set-file-modes result #o0700))) ;; Return the local part. - (with-parsed-tramp-file-name result nil localname))) + (tramp-file-local-name result))) (defun tramp-delete-temp-file-function () "Remove temporary files related to current buffer." @@ -4682,7 +4776,7 @@ this file, if that variable is non-nil." (let ((system-type (if (and (stringp tramp-auto-save-directory) - (file-remote-p tramp-auto-save-directory)) + (tramp-tramp-file-p tramp-auto-save-directory)) 'not-windows system-type)) (auto-save-file-name-transforms @@ -4820,11 +4914,29 @@ verbosity of 6." (tramp-message vec 6 "%s" result) result)) +(defun tramp-process-running-p (process-name) + "Return t if system process PROCESS-NAME is running for `user-login-name'." + (when (stringp process-name) + (catch 'result + (dolist (pid (list-system-processes)) + (when-let ((attributes (process-attributes pid)) + (comm (cdr (assoc 'comm attributes)))) + (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) + ;; The returned command name could be truncated to 15 + ;; characters. Therefore, we cannot check for `string-equal'. + (string-prefix-p comm process-name) + (throw 'result t))))))) + (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." - (let* ((case-fold-search t) + (let* (;; If `auth-sources' contains "~/.authinfo.gpg", and + ;; `exec-path' contains a relative file name like ".", it + ;; could happen that the "gpg" command is not found. So we + ;; adapt `default-directory'. (Bug#39389, Bug#39489) + (default-directory (tramp-compat-temporary-file-directory)) + (case-fold-search t) (key (tramp-make-tramp-file-name ;; In tramp-sh.el, we must use "password-vector" due to ;; multi-hop. @@ -4976,10 +5088,12 @@ name of a process or buffer, or nil to default to the current buffer." (tramp-error proc 'error "Process %s is not active" proc) (tramp-message proc 5 "Interrupt process %s with pid %s" proc pid) ;; 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 'vector) - (format "kill -2 -%d" pid)) + (format "(\\kill -2 -%d || \\kill -2 %d) 2>/dev/null" pid pid)) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. (while (tramp-accept-process-output proc 0)) @@ -4993,6 +5107,23 @@ name of a process or buffer, or nil to default to the current buffer." (lambda () (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(defun tramp-get-signal-strings () + "Strings to return by `process-file' in case of signals." + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil "signal-strings" + (let (result) + (if (and (stringp shell-file-name) (executable-find shell-file-name)) + (dotimes (i 128) + (push + (if (= i 19) 1 ;; SIGSTOP + (call-process + shell-file-name nil nil nil "-c" (format "kill -%d $$" i))) + result)) + (dotimes (i 128) + (push (format "Signal %d" i) result))) + ;; Due to Bug#41287, we cannot add this to the `dotimes' clause. + (reverse result)))) + ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' @@ -5034,16 +5165,5 @@ name of a process or buffer, or nil to default to the current buffer." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. -;; -;; * Get rid of `shell-command'. In its primary implementation, it -;; uses `process-file-shell-command' and -;; `start-file-process-shell-command', which is sufficient due to -;; connection-local `shell-file-name'. - ;;; tramp.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index dacdd44102f..8d21133b3b1 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -35,11 +35,8 @@ ;; Emacs version check is defined in macro AC_EMACS_INFO of ;; aclocal.m4; should be changed only there. -;; Needed for Emacs 24. -(defvar inhibit-message) - ;;;###tramp-autoload -(defconst tramp-version "2.4.3.27.1" +(defconst tramp-version "2.5.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -51,6 +48,7 @@ ;; Suppress message from `emacs-repository-get-branch'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. @@ -64,6 +62,7 @@ ;; Suppress message from `emacs-repository-get-version'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) (and (stringp dir) (file-directory-p dir) @@ -71,9 +70,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "24.4")) +(let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.4.3.27.1 is not fit for %s" + (format "Tramp 2.5.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) @@ -102,8 +101,3 @@ (provide 'trampver) ;;; trampver.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 6edd03c39cc..8bb156199c5 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -1,4 +1,4 @@ -;;; webjump.el --- programmable Web hotlist +;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc. @@ -323,8 +323,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (defun webjump-read-url-choice (what urls &optional default) ;; Note: Convert this to use `webjump-read-choice' someday. - (let* ((completions (mapcar (function (lambda (n) (cons n n))) - urls)) + (let* ((completions (mapcar (lambda (n) (cons n n)) urls)) (input (completing-read (concat what ;;(if default " (RET for default)" "") ": ") |