diff options
Diffstat (limited to 'lisp/net')
41 files changed, 4736 insertions, 2972 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..e7dad48cf4a 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1,4 +1,4 @@ -;;; browse-url.el --- pass a URL to a WWW browser +;;; browse-url.el --- pass a URL to a WWW browser -*- lexical-binding: t; -*- ;; Copyright (C) 1995-2020 Free Software Foundation, Inc. @@ -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 @@ -414,35 +425,20 @@ Passing an interactive argument to \\[browse-url], or specific browser commands reverses the effect of this variable." :type 'boolean) -(defcustom browse-url-mosaic-program "xmosaic" - "The name by which to invoke Mosaic (or mMosaic)." - :type 'string - :version "20.3") - -(make-obsolete-variable 'browse-url-mosaic-program nil "25.1") - -(defcustom browse-url-mosaic-arguments nil - "A list of strings to pass to Mosaic as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1") - -(defcustom browse-url-mosaic-pidfile "~/.mosaicpid" - "The name of the pidfile created by Mosaic." - :type 'string) - -(make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1") - (defcustom browse-url-conkeror-program "conkeror" "The name by which to invoke Conkeror." :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 @@ -483,22 +479,6 @@ Used by the `browse-url-of-file' command." "Hook run after `browse-url-of-file' has asked a browser to load a file." :type 'hook) -(defcustom browse-url-CCI-port 3003 - "Port to access XMosaic via CCI. -This can be any number between 1024 and 65535 but must correspond to -the value set in the browser." - :type 'integer) - -(make-obsolete-variable 'browse-url-CCI-port nil "25.1") - -(defcustom browse-url-CCI-host "localhost" - "Host to access XMosaic via CCI. -This should be the host name of the machine running XMosaic with CCI -enabled. The port number should be set in `browse-url-CCI-port'." - :type 'string) - -(make-obsolete-variable 'browse-url-CCI-host nil "25.1") - (defvar browse-url-temp-file-name nil) (make-variable-buffer-local 'browse-url-temp-file-name) @@ -595,6 +575,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) + "Call `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) + "Call `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) + "Call `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 @@ -729,8 +819,8 @@ narrowed." (browse-url-of-file file-name)))) (defun browse-url-delete-temp-file (&optional temp-file-name) - ;; Delete browse-url-temp-file-name from the file system - ;; If optional arg TEMP-FILE-NAME is non-nil, delete it instead + "Delete `browse-url-temp-file-name' from the file system. +If optional arg TEMP-FILE-NAME is non-nil, delete it instead." (let ((file-name (or temp-file-name browse-url-temp-file-name))) (if (and file-name (file-exists-p file-name)) (delete-file file-name)))) @@ -768,16 +858,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 +878,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 +888,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 +907,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-prompt "Browser kind" 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 +981,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 () @@ -928,8 +1040,6 @@ instead of `browse-url-new-window-flag'." ;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon) ((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-chrome-program) 'browse-url-chrome) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) @@ -937,6 +1047,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 +1070,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 +1115,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 +1187,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 +1229,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 +1248,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 +1266,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 +1305,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 +1353,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 +1379,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,88 +1405,7 @@ used instead of `browse-url-new-window-flag'." '("--newwin")) (list "--raise" url)))) -;; --- Mosaic --- - -;;;###autoload -(defun browse-url-mosaic (url &optional new-window) - "Ask the XMosaic WWW browser to load URL. - -Default to the URL around or before point. The strings in variable -`browse-url-mosaic-arguments' are also passed to Mosaic and the -program is invoked according to the variable -`browse-url-mosaic-program'. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Mosaic window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "Mosaic URL: ")) - (let ((pidfile (expand-file-name browse-url-mosaic-pidfile)) - pid) - (if (file-readable-p pidfile) - (with-temp-buffer - (insert-file-contents pidfile) - (setq pid (read (current-buffer))))) - (if (and (integerp pid) (zerop (signal-process pid 0))) ; Mosaic running - (progn - (with-temp-buffer - (insert (if (browse-url-maybe-new-window new-window) - "newwin\n" - "goto\n") - url "\n") - (with-file-modes ?\700 - (if (file-exists-p - (setq pidfile (format "/tmp/Mosaic.%d" pid))) - (delete-file pidfile)) - ;; https://debbugs.gnu.org/17428. Use O_EXCL. - (write-region nil nil pidfile nil 'silent nil 'excl))) - ;; Send signal SIGUSR to Mosaic - (message "Signaling Mosaic...") - (signal-process pid 'SIGUSR1) - ;; Or you could try: - ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid)) - (message "Signaling Mosaic...done")) - ;; Mosaic not running - start it - (message "Starting %s..." browse-url-mosaic-program) - (apply 'start-process "xmosaic" nil browse-url-mosaic-program - (append browse-url-mosaic-arguments (list url))) - (message "Starting %s...done" browse-url-mosaic-program)))) - -;; --- Mosaic using CCI --- - -;;;###autoload -(defun browse-url-cci (url &optional new-window) - "Ask the XMosaic WWW browser to load URL. -Default to the URL around or before point. - -This function only works for XMosaic version 2.5 or later. You must -select `CCI' from XMosaic's File menu, set the CCI Port Address to the -value of variable `browse-url-CCI-port', and enable `Accept requests'. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new browser window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "Mosaic URL: ")) - (open-network-stream "browse-url" " *browse-url*" - browse-url-CCI-host browse-url-CCI-port) - ;; Todo: start browser if fails - (process-send-string "browse-url" - (concat "get url (" url ") output " - (if (browse-url-maybe-new-window new-window) - "new" - "current") - "\r\n")) - (process-send-string "browse-url" "disconnect\r\n") - (delete-process "browse-url")) +(function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external) ;; --- Conkeror --- ;;;###autoload @@ -1375,6 +1426,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 +1444,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 +1470,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 +1486,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 +1505,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 +1581,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 +1630,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 +1643,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 +1664,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 +1676,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 +1687,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 +1711,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..5afc7f111f8 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -51,11 +51,10 @@ (unless (boundp 'dbus-debug) (defvar dbus-debug nil)) -;; Pacify byte compiler. -(eval-when-compile (require 'cl-lib)) - (require 'xml) +;;; D-Bus constants. + (defconst dbus-service-dbus "org.freedesktop.DBus" "The bus name used to talk to the bus itself.") @@ -65,7 +64,8 @@ (defconst dbus-path-local (concat dbus-path-dbus "/Local") "The object path used in local/in-process-generated messages.") -;; Default D-Bus interfaces. + +;;; Default D-Bus interfaces. (defconst dbus-interface-dbus "org.freedesktop.DBus" "The interface exported by the service `dbus-service-dbus'.") @@ -148,7 +148,41 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter ;; </signal> ;; </interface> -;; Emacs defaults. + +;;; Default D-Bus errors. + +(defconst dbus-error-dbus "org.freedesktop.DBus.Error" + "The namespace for default error names. +See /usr/include/dbus-1.0/dbus/dbus-protocol.h.") + +(defconst dbus-error-failed (concat dbus-error-dbus ".Failed") + "A generic error; \"something went wrong\" - see the error message for more.") + +(defconst dbus-error-access-denied (concat dbus-error-dbus ".AccessDenied") + "Security restrictions don't allow doing what you're trying to do.") + +(defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs") + "Invalid arguments passed to a method call.") + +(defconst dbus-error-property-read-only + (concat dbus-error-dbus ".PropertyReadOnly") + "Property you tried to set is read-only.") + +(defconst dbus-error-unknown-interface + (concat dbus-error-dbus ".UnknownInterface") + "Interface you invoked a method on isn't known by the object.") + +(defconst dbus-error-unknown-method (concat dbus-error-dbus ".UnknownMethod") + "Method name you invoked isn't known by the object you invoked it on.") + +(defconst dbus-error-unknown-object (concat dbus-error-dbus ".UnknownObject") + "Object you invoked a method on isn't known.") + +(defconst dbus-error-unknown-property (concat dbus-error-dbus ".UnknownProperty") + "Property you tried to access isn't known by the object.") + + +;;; Emacs defaults. (defconst dbus-service-emacs "org.gnu.Emacs" "The well known service name of Emacs.") @@ -160,7 +194,8 @@ shall be subdirectories of this path.") (defconst dbus-interface-emacs "org.gnu.Emacs" "The interface namespace used by Emacs.") -;; D-Bus constants. + +;;; Basic D-Bus message functions. (defmacro dbus-ignore-errors (&rest body) "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. @@ -169,19 +204,13 @@ 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 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 +330,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 +367,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 +431,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 +479,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,11 +495,12 @@ 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) +(defun dbus-method-error-internal (bus service serial error-name &rest args) "Return error message for message SERIAL on the D-Bus BUS. +ERROR-NAME must belong to the \"org.freedesktop.DBus.Error\" namespace. This is an internal function, it shall not be used outside dbus.el." (or (featurep 'dbusbind) @@ -486,8 +512,8 @@ 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 - bus service serial args)) + (apply #'dbus-message-internal dbus-message-type-error + bus service serial error-name args)) ;;; Hash table of registered functions. @@ -553,12 +579,13 @@ placed in the queue. ;; Add Peer handler. (dbus-register-method - bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register) + 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) @@ -597,7 +624,7 @@ queue of this service." (maphash (lambda (key value) - (unless (equal :serial (car key)) + (unless (eq :serial (car key)) (dolist (elt value) (ignore-errors (when (and (equal bus (cadr key)) (string-equal service (cadr elt))) @@ -681,7 +708,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 +737,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 +753,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 +761,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 +775,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)))) @@ -788,10 +812,18 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the interface offered by SERVICE. It must provide METHOD. HANDLER is a Lisp function to be called when a method call is -received. It must accept the input arguments of METHOD. The return -value of HANDLER is used for composing the returning D-Bus message. -If HANDLER returns a reply message with an empty argument list, -HANDLER must return the symbol `:ignore'. +received. It must accept the input arguments of METHOD. The +return value of HANDLER is used for composing the returning D-Bus +message. If HANDLER returns a reply message with an empty +argument list, HANDLER must return the symbol `:ignore' in order +to distinguish it from nil (the boolean false). + +If HANDLER detects an error, it shall return the list `(:error +ERROR-NAME ERROR-MESSAGE)'. ERROR-NAME is a namespaced string +which characterizes the error type, and ERROR-MESSAGE is a free +text string. Alternatively, any Emacs signal `dbus-error' in +HANDLER raises a D-Bus error message with the error name +\"org.freedesktop.DBus.Error.Failed\". When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not registered. This means that other D-Bus clients have no way of @@ -893,9 +925,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 +933,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 +957,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 +969,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. @@ -1014,22 +1041,26 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (signal 'dbus-error (nthcdr 9 event))) ;; Apply the handler. (setq result (apply (nth 8 event) (nthcdr 9 event))) - ;; Return a message when it is a message call. + ;; Return an (error) message when it is a message call. (when (= dbus-message-type-method-call (nth 2 event)) (dbus-ignore-errors - (if (eq result :ignore) - (dbus-method-return-internal - (nth 1 event) (nth 4 event) (nth 3 event)) - (apply 'dbus-method-return-internal - (nth 1 event) (nth 4 event) (nth 3 event) - (if (consp result) result (list result))))))) + (if (eq (car-safe result) :error) + (apply #'dbus-method-error-internal + (nth 1 event) (nth 4 event) (nth 3 event) (cdr result)) + (if (eq result :ignore) + (dbus-method-return-internal + (nth 1 event) (nth 4 event) (nth 3 event)) + (apply #'dbus-method-return-internal + (nth 1 event) (nth 4 event) (nth 3 event) + (if (consp result) result (list result)))))))) ;; Error handling. (dbus-error ;; Return an error message when it is a message call. (when (= dbus-message-type-method-call (nth 2 event)) (dbus-ignore-errors (dbus-method-error-internal - (nth 1 event) (nth 4 event) (nth 3 event) (cadr err)))) + (nth 1 event) (nth 4 event) (nth 3 event) dbus-error-failed + (error-message-string err)))) ;; Propagate D-Bus error messages. (run-hook-with-args 'dbus-event-error-functions event err) (when dbus-debug @@ -1119,10 +1150,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. @@ -1167,7 +1197,8 @@ check whether SERVICE is already running, you can instead write "Default handler for the \"org.freedesktop.DBus.Peer\" interface. It will be registered for all objects created by `dbus-register-service'." (let* ((last-input-event last-input-event) - (method (dbus-event-member-name last-input-event))) + (method (dbus-event-member-name last-input-event)) + (path (dbus-event-path-name last-input-event))) (cond ;; "Ping" does not return an output parameter. ((string-equal method "Ping") @@ -1177,11 +1208,27 @@ It will be registered for all objects created by `dbus-register-service'." (signal 'dbus-error (list - (format "%s.GetMachineId not implemented" dbus-interface-peer))))))) + (format "%s.GetMachineId not implemented" dbus-interface-peer)))) + (t `(:error ,dbus-error-unknown-method + ,(format-message + "No such method \"%s.%s\" at path \"%s\"" + dbus-interface-peer method path)))))) ;;; 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 +1244,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 +1274,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 +1293,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 +1302,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 +1317,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 +1333,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 +1349,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 +1359,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 +1373,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,61 +1387,55 @@ 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) - "Return signature of a `method' or `signal' represented by NAME as a string. + "Return signature of a `method', `property' or `signal' represented by NAME. If NAME is a `method', DIRECTION can be either \"in\" or \"out\". If DIRECTION is nil, \"in\" is assumed. -If NAME is a `signal', and DIRECTION is non-nil, DIRECTION must -be \"out\"." +If NAME is a `signal' or a `property', DIRECTION is ignored." ;; For methods, we use "in" as default direction. (let ((object (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)))) - (when (and (string-equal - "method" (dbus-introspect-get-attribute object "name")) - (not (stringp direction))) + (when (and (eq 'method (car object)) (not (stringp direction))) (setq direction "in")) ;; In signals, no direction is given. - (when (string-equal "signal" (dbus-introspect-get-attribute object "name")) + (when (eq 'signal (car object)) (setq direction nil)) ;; Collect the signatures. - (mapconcat - (lambda (x) - (let ((arg (dbus-introspect-get-argument - bus service path interface name x))) - (if (or (not (stringp direction)) - (string-equal - direction - (dbus-introspect-get-attribute arg "direction"))) - (dbus-introspect-get-attribute arg "type") - ""))) - (dbus-introspect-get-argument-names bus service path interface name) - ""))) + (if (eq 'property (car object)) + (dbus-introspect-get-attribute object "type") + (mapconcat + (lambda (x) + (let ((arg (dbus-introspect-get-argument + bus service path interface name x))) + (if (or (not (stringp direction)) + (string-equal + direction + (dbus-introspect-get-attribute arg "direction"))) + (dbus-introspect-get-attribute arg "type") + ""))) + (dbus-introspect-get-argument-names bus service path interface name) + "")))) ;;; D-Bus properties. @@ -1442,7 +1443,7 @@ be \"out\"." (defun dbus-get-property (bus service path interface property) "Return the value of PROPERTY of INTERFACE. It will be checked at BUS, SERVICE, PATH. The result can be any -valid D-Bus value, or nil if there is no PROPERTY." +valid D-Bus value, or nil if there is no PROPERTY, or PROPERTY cannot be read." (dbus-ignore-errors ;; "Get" returns a variant, so we must use the `car'. (car @@ -1450,17 +1451,23 @@ valid D-Bus value, or nil if there is no PROPERTY." bus service path dbus-interface-properties "Get" :timeout 500 interface property)))) -(defun dbus-set-property (bus service path interface property value) +(defun dbus-set-property (bus service path interface property &rest args) "Set value of PROPERTY of INTERFACE to VALUE. -It will be checked at BUS, SERVICE, PATH. When the value is -successfully set return VALUE. Otherwise, return nil." +It will be checked at BUS, SERVICE, PATH. VALUE can be preceded +by a TYPE symbol. When the value is successfully set return +VALUE. Otherwise, return nil. + +\(dbus-set-property BUS SERVICE PATH INTERFACE PROPERTY [TYPE] VALUE)" (dbus-ignore-errors ;; "Set" requires a variant. (dbus-call-method bus service path dbus-interface-properties - "Set" :timeout 500 interface property (list :variant value)) - ;; Return VALUE. - (dbus-get-property bus service path interface property))) + "Set" :timeout 500 interface property (cons :variant args)) + ;; Return VALUE. The property could have the `:write' access type, + ;; so we ignore errors in `dbus-get-property'. + (dbus-ignore-errors + (or (dbus-get-property bus service path interface property) + (if (symbolp (car args)) (cadr args) (car args)))))) (defun dbus-get-all-properties (bus service path interface) "Return all properties of INTERFACE at BUS, SERVICE, PATH. @@ -1469,17 +1476,34 @@ 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-get-this-registered-property (bus _service path interface property) + "Return PROPERTY entry of `dbus-registered-objects-table'. +Filter out not matching PATH." + ;; Remove entries not belonging to this case. + (seq-filter + (lambda (item) + (string-equal path (nth 2 item))) + (gethash (list :property bus interface property) + dbus-registered-objects-table))) + +(defun dbus-get-other-registered-properties + (bus _service path interface property) + "Return PROPERTY entry of `dbus-registered-objects-table'. +Filter out matching PATH." + ;; Remove matching entries. + (seq-remove + (lambda (item) + (string-equal path (nth 2 item))) + (gethash (list :property bus interface property) + dbus-registered-objects-table))) (defun dbus-register-property - (bus service path interface property access value - &optional emits-signal dont-register-service) + (bus service path interface property access &rest args) "Register PROPERTY on the D-Bus BUS. BUS is either a Lisp symbol, `:system' or `:session', or a string @@ -1493,14 +1517,16 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the name of the interface used at PATH, PROPERTY is the name of the property of INTERFACE. ACCESS indicates, whether the property can be changed by other services via D-Bus. It must be either -the symbol `:read' or `:readwrite'. VALUE is the initial value -of the property, it can be of any valid type (see -`dbus-call-method' for details). +the symbol `:read', `:write' or `:readwrite'. + +VALUE is the initial value of the property, it can be of any +valid type (see `dbus-call-method' for details). VALUE can be +preceded by a TYPE symbol. If PROPERTY already exists on PATH, it will be overwritten. For properties with access type `:read' this is the only way to -change their values. Properties with access type `:readwrite' -can be changed by `dbus-set-property'. +change their values. Properties with access type `:write' or +`:readwrite' can be changed by `dbus-set-property'. The interface \"org.freedesktop.DBus.Properties\" is added to PATH, including a default handler for the \"Get\", \"GetAll\" and @@ -1513,46 +1539,72 @@ not registered. This means that other D-Bus clients have no way of noticing the newly registered property. When interfaces are constructed incrementally by adding single methods or properties at a time, DONT-REGISTER-SERVICE can be used to prevent other -clients from discovering the still incomplete interface." - (unless (member access '(:read :readwrite)) - (signal 'wrong-type-argument (list "Access type invalid" access))) - - ;; Add handlers for the three property-related methods. - (dbus-register-method - bus service path dbus-interface-properties "Get" - 'dbus-property-handler 'dont-register) - (dbus-register-method - bus service path dbus-interface-properties "GetAll" - 'dbus-property-handler 'dont-register) - (dbus-register-method - bus service path dbus-interface-properties "Set" - 'dbus-property-handler 'dont-register) - - ;; Register SERVICE. - (unless (or dont-register-service (member service (dbus-list-names bus))) - (dbus-register-service bus service)) - - ;; Send the PropertiesChanged signal. - (when emits-signal - (dbus-send-signal - bus service path dbus-interface-properties "PropertiesChanged" - `((:dict-entry ,property (:variant ,value))) - '(:array))) - - ;; Create a hash table entry. We use nil for the unique name, - ;; because the property might be accessed from anybody. - (let ((key (list :property bus interface property)) - (val - (list - (list - nil service path - (cons - (if emits-signal (list access :emits-signal) (list access)) - value))))) - (puthash key val dbus-registered-objects-table) - - ;; Return the object. - (list key (list service path)))) +clients from discovering the still incomplete interface. + +\(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \ +[TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)" + (let ((type (when (symbolp (car args)) (pop args))) + (value (pop args)) + (emits-signal (pop args)) + (dont-register-service (pop args))) + (unless (member access '(:read :write :readwrite)) + (signal 'wrong-type-argument (list "Access type invalid" access))) + (unless type + (setq type + (cond + ((memq value '(t nil)) :boolean) + ((natnump value) :uint32) + ((fixnump value) :int32) + ((floatp value) :double) + ((stringp value) :string) + (t + (signal 'wrong-type-argument (list "Value type invalid" value)))))) + + ;; Add handlers for the three property-related methods. + (dbus-register-method + bus service path dbus-interface-properties "Get" + #'dbus-property-handler 'dont-register) + (dbus-register-method + bus service path dbus-interface-properties "GetAll" + #'dbus-property-handler 'dont-register) + (dbus-register-method + bus service path dbus-interface-properties "Set" + #'dbus-property-handler 'dont-register) + + ;; Register SERVICE. + (unless (or dont-register-service (member service (dbus-list-names bus))) + (dbus-register-service bus service)) + + ;; Send the PropertiesChanged signal. + (when emits-signal + (dbus-send-signal + bus service path dbus-interface-properties "PropertiesChanged" + (if (member access '(:read :readwrite)) + `(:array + (:dict-entry + ,property + ,(if type (list :variant type value) (list :variant value)))) + '(:array: :signature "{sv}")) + (if (eq access :write) + `(:array ,property) + '(:array)))) + + ;; Create a hash table entry. We use nil for the unique name, + ;; because the property might be accessed from anybody. + (let ((key (list :property bus interface property)) + (val + (cons + (list + nil service path + (cons + (if emits-signal (list access :emits-signal) (list access)) + (if type (list type value) (list value)))) + (dbus-get-other-registered-properties + bus service path interface property)))) + (puthash key val dbus-registered-objects-table) + + ;; Return the object. + (list key (list service path))))) (defun dbus-property-handler (&rest args) "Default handler for the \"org.freedesktop.DBus.Properties\" interface. @@ -1566,58 +1618,82 @@ It will be registered for all objects created by `dbus-register-property'." (cond ;; "Get" returns a variant. ((string-equal method "Get") - (let ((entry (gethash (list :property bus interface property) - dbus-registered-objects-table))) - (when (string-equal path (nth 2 (car entry))) - `((:variant ,(cdar (last (car entry)))))))) + (let* ((entry (dbus-get-this-registered-property + bus service path interface property)) + (object (car (last (car entry))))) + (cond + ((not (consp object)) + `(:error ,dbus-error-unknown-property + ,(format-message + "No such property \"%s\" at path \"%s\"" property path))) + ((memq :write (car object)) + `(:error ,dbus-error-access-denied + ,(format-message + "Property \"%s\" at path \"%s\" is not readable" property path))) + ;; Return the result. + (t (list :variant (cdar (last (car entry)))))))) ;; "Set" expects a variant. ((string-equal method "Set") (let* ((value (caar (cddr args))) - (entry (gethash (list :property bus interface property) - dbus-registered-objects-table)) - ;; The value of the hash table is a list; in case of - ;; properties it contains just one element (UNAME SERVICE - ;; PATH OBJECT). OBJECT is a cons cell of a list, which - ;; contains a list of annotations (like :read, - ;; :read-write, :emits-signal), and the value of the - ;; property. + (entry (dbus-get-this-registered-property + bus service path interface property)) (object (car (last (car entry))))) - (unless (consp object) - (signal 'dbus-error - (list "Property not registered at path" property path))) - (unless (member :readwrite (car object)) - (signal 'dbus-error - (list "Property not writable at path" property path))) - (puthash (list :property bus interface property) - (list (append (butlast (car entry)) - (list (cons (car object) value)))) - dbus-registered-objects-table) - ;; Send the "PropertiesChanged" signal. - (when (member :emits-signal (car object)) - (dbus-send-signal - bus service path dbus-interface-properties "PropertiesChanged" - `((:dict-entry ,property (:variant ,value))) - '(:array))) - ;; Return empty reply. - :ignore)) + (cond + ((not (consp object)) + `(:error ,dbus-error-unknown-property + ,(format-message + "No such property \"%s\" at path \"%s\"" property path))) + ((memq :read (car object)) + `(:error ,dbus-error-property-read-only + ,(format-message + "Property \"%s\" at path \"%s\" is not writable" property path))) + (t (puthash (list :property bus interface property) + (cons (append + (butlast (car entry)) + ;; Reuse ACCESS und TYPE from registration. + (list (list (car object) (cadr object) value))) + (dbus-get-other-registered-properties + bus service path interface property)) + dbus-registered-objects-table) + ;; Send the "PropertiesChanged" signal. + (when (member :emits-signal (car object)) + (dbus-send-signal + bus service path dbus-interface-properties "PropertiesChanged" + (if (or (member :read (car object)) + (member :readwrite (car object))) + `(:array (:dict-entry ,property (:variant ,value))) + '(:array: :signature "{sv}")) + (if (eq (car object) :write) + `(:array ,property) + '(:array)))) + ;; Return empty reply. + :ignore)))) ;; "GetAll" returns "a{sv}". ((string-equal method "GetAll") (let (result) (maphash (lambda (key val) - (when (and (equal (butlast key) (list :property bus interface)) - (string-equal path (nth 2 (car val))) - (not (functionp (car (last (car val)))))) - (push - (list :dict-entry - (car (last key)) - (list :variant (cdar (last (car val))))) - result))) + (when (consp val) + (dolist (item val) + (when (and (equal (butlast key) (list :property bus interface)) + (string-equal path (nth 2 item)) + (consp (car (last item))) + (not (memq :write (caar (last item))))) + (push + (list :dict-entry + (car (last key)) + (cons :variant (cdar (last item)))) + result))))) dbus-registered-objects-table) ;; Return the result, or an empty array. - (list :array (or result '(:signature "{sv}")))))))) + (list :array (or result '(:signature "{sv}"))))) + + (t `(:error ,dbus-error-unknown-method + ,(format-message + "No such method \"%s.%s\" at path \"%s\"" + dbus-interface-properties method path)))))) ;;; D-Bus object manager. @@ -1673,7 +1749,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! @@ -1704,7 +1780,7 @@ It will be registered for all objects created by `dbus-register-service'." ;; Check for object path wildcard interfaces. (maphash (lambda (key val) - (when (and (equal (butlast key 2) (list :method bus)) + (when (and (equal (butlast key 2) (list :property bus)) (null (nth 2 (car-safe val)))) (push (nth 2 key) interfaces))) dbus-registered-objects-table) @@ -1713,7 +1789,7 @@ It will be registered for all objects created by `dbus-register-service'." (maphash (lambda (key val) (let ((object (or (nth 2 (car-safe val)) ""))) - (when (and (equal (butlast key 2) (list :method bus)) + (when (and (equal (butlast key 2) (list :property bus)) (string-prefix-p path object)) (dolist (interface (cons (nth 2 key) interfaces)) (unless (assoc object result) @@ -1730,7 +1806,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) @@ -1822,5 +1898,9 @@ this connection to those buses." ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and ;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved. +;; +;; * Cache introspection data. +;; +;; * Run handlers in own threads. ;;; dbus.el ends here 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..c368cd773c2 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -1,4 +1,4 @@ -;;; dns.el --- Domain Name Service lookups +;;; dns.el --- Domain Name Service lookups -*- lexical-binding:t -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -24,6 +24,8 @@ ;;; Code: +(require 'cl-lib) + (defvar dns-timeout 5 "How many seconds to wait when doing DNS queries.") @@ -73,7 +75,7 @@ updated. Set this variable to t to disable the check.") (defun dns-write-bytes (value &optional length) (let (bytes) - (dotimes (i (or length 1)) + (dotimes (_ (or length 1)) (push (% value 256) bytes) (setq value (/ value 256))) (dolist (byte bytes) @@ -81,7 +83,7 @@ updated. Set this variable to t to disable the check.") (defun dns-read-bytes (length) (let ((value 0)) - (dotimes (i length) + (dotimes (_ length) (setq value (logior (* value 256) (following-char))) (forward-char 1)) value)) @@ -138,7 +140,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 +191,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)) @@ -227,7 +231,7 @@ If TCP-P, the first two bytes of the package with be the length field." (setq authorities (dns-read-bytes 2)) (setq additionals (dns-read-bytes 2)) (let ((qs nil)) - (dotimes (i queries) + (dotimes (_ queries) (push (list (dns-read-name) (list 'type (dns-inverse-get (dns-read-bytes 2) dns-query-types)) @@ -235,33 +239,36 @@ If TCP-P, the first two bytes of the package with be the length field." dns-classes))) qs)) (push (list 'queries qs) spec)) - (dolist (slot '(answers authorities additionals)) - (let ((qs nil) - type) - (dotimes (i (symbol-value slot)) - (push (list (dns-read-name) - (list 'type - (setq type (dns-inverse-get (dns-read-bytes 2) - dns-query-types))) - (list 'class (dns-inverse-get (dns-read-bytes 2) - dns-classes)) - (list 'ttl (dns-read-bytes 4)) - (let ((length (dns-read-bytes 2))) - (list 'data - (dns-read-type - (buffer-substring - (point) - (progn (forward-char length) (point))) - type)))) - qs)) - (push (list slot qs) spec))) + (cl-loop for (slot length) in `((answers ,answers) + (authorities ,authorities) + (additionals ,additionals)) + do (let ((qs nil) + type) + (dotimes (_ length) + (push (list (dns-read-name) + (list 'type + (setq type (dns-inverse-get + (dns-read-bytes 2) + dns-query-types))) + (list 'class (dns-inverse-get + (dns-read-bytes 2) + dns-classes)) + (list 'ttl (dns-read-bytes 4)) + (let ((length (dns-read-bytes 2))) + (list 'data + (dns-read-type + (buffer-substring + (point) + (progn (forward-char length) + (point))) + type)))) + qs)) + (push (list slot qs) spec))) (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)) @@ -274,23 +281,23 @@ If TCP-P, the first two bytes of the package with be the length field." (cond ((eq type 'A) (let ((bytes nil)) - (dotimes (i 4) + (dotimes (_ 4) (push (dns-read-bytes 1) bytes)) (mapconcat 'number-to-string (nreverse bytes) "."))) ((eq type 'AAAA) (let (hextets) - (dotimes (i 8) + (dotimes (_ 8) (push (dns-read-bytes 2) hextets)) (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":"))) ((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)) @@ -309,16 +316,14 @@ If TCP-P, the first two bytes of the package with be the length field." "Return false if we need to recheck the list of DNS servers." (and dns-servers (or (eq dns-servers-valid-for-interfaces t) - ;; `network-interface-list' was introduced in Emacs 22.1. - (not (fboundp 'network-interface-list)) (equal dns-servers-valid-for-interfaces (network-interface-list))))) (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,11 +334,10 @@ 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 (fboundp 'network-interface-list) - (setq dns-servers-valid-for-interfaces (network-interface-list)))) + (when (re-search-forward + "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\|[[:xdigit:]:]*\\)" nil t) + (setq dns-servers (list (match-string 1))))))) + (setq dns-servers-valid-for-interfaces (network-interface-list))) (defun dns-read-txt (string) (if (> (length string) 1) @@ -355,23 +359,6 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." result)) ;;; Interface functions. -(defmacro dns-make-network-process (server) - `(let ((server ,server) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (if (fboundp 'make-network-process) - (make-network-process - :name "dns" - :coding 'binary - :buffer (current-buffer) - :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. - (open-network-stream "dns" (current-buffer) server "domain")))) - (defvar dns-cache (make-vector 4096 0)) (defun dns-query-cached (name &optional type fullp reversep) @@ -384,64 +371,141 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (set (intern key dns-cache) result) result)))) -;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23 -;; yet, so no alias are provided. --rsteib - -(defun dns-query (name &optional type fullp reversep) +(defun dns-query-asynchronous (name callback &optional type full reverse) "Query a DNS server for NAME of TYPE. -If FULLP, return the entire record returned. -If REVERSEP, look up an IP address." +CALLBACK will be called with a single parameter: The result. + +If there's no result, or `dns-timeout' has passed, CALLBACK will +be called with nil as the parameter. + +If FULL, return the entire record. +If REVERSE, look up an IP address." (setq type (or type 'A)) (unless (dns-servers-up-to-date-p) (dns-set-servers)) - (when reversep + (when reverse (setq name (concat (mapconcat 'identity (nreverse (split-string name "\\.")) ".") ".in-addr.arpa") type 'PTR)) (if (not dns-servers) - (message "No DNS server configuration found") - (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))) - (step 100) - (times (* dns-timeout 1000)) - (id (random 65000))) - (when process - (process-send-string - process - (dns-write `((id ,id) - (opcode query) - (queries ((,name (type ,type)))) - (recursion-desired-p t)))) - (while (and (zerop (buffer-size)) - (> times 0)) - (let ((step-sec (/ step 1000.0))) - (sit-for step-sec) - (accept-process-output process step-sec)) - (setq times (- times step))) - (condition-case nil - (delete-process process) - (error nil)) - (when (and (>= (buffer-size) 2) - ;; We had a time-out. - (> times 0)) - (let ((result (dns-read (buffer-string)))) - (if fullp - result - (let ((answer (car (dns-get 'answers result)))) - (when (eq type (dns-get 'type answer)) - (if (eq type 'TXT) - (dns-get-txt-answer (dns-get 'answers result)) - (dns-get 'data answer)))))))))))) + (progn + (message "No DNS server configuration found") + nil) + (dns--lookup name callback type full))) + +(defun dns--lookup (name callback type full) + (with-current-buffer (generate-new-buffer " *dns*") + (set-buffer-multibyte nil) + (let* ((tcp nil) + (process + (condition-case () + (let ((server (car dns-servers)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (if (featurep 'make-network-process '(:type datagram)) + (make-network-process + :name "dns" + :coding 'binary + :buffer (current-buffer) + :host server + :service "domain" + :type 'datagram) + ;; On MS-Windows datagram sockets are not + ;; supported, so we fall back on opening a TCP + ;; connection to the DNS server. + (progn + (setq tcp t) + (open-network-stream "dns" (current-buffer) + server "domain")))) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) + (triggered nil) + (buffer (current-buffer)) + timer) + (if (not process) + (progn + (kill-buffer buffer) + (funcall callback nil)) + ;; Call the callback if we don't get any response at all. + (setq timer (run-at-time dns-timeout nil + (lambda () + (unless triggered + (setq triggered t) + (delete-process process) + (kill-buffer buffer) + (funcall callback nil))))) + (process-send-string + process + (dns-write `((id ,(random 65000)) + (opcode query) + (queries ((,name (type ,type)))) + (recursion-desired-p t)) + tcp)) + (set-process-filter + process + (lambda (process string) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string) + (goto-char (point-min)) + ;; If this is DNS, then we always get the full data in + ;; one packet. If it's TCP, we may only get part of the + ;; data, but the first two bytes says how long the data + ;; is supposed to be. + (when (or (not tcp) + (>= (buffer-size) (dns-read-bytes 2))) + (setq triggered t) + (cancel-timer timer) + (dns--filter process callback type full tcp))))) + ;; In case we the process is deleted for some reason, then do + ;; a failure callback. + (set-process-sentinel + process + (lambda (_ state) + (when (and (eq state 'deleted) + ;; Ensure we don't trigger this callback twice. + (not triggered)) + (setq triggered t) + (cancel-timer timer) + (kill-buffer buffer) + (funcall callback nil)))))))) + +(defun dns--filter (process callback type full tcp) + (let ((message (buffer-string))) + (when (process-live-p process) + (delete-process process)) + (kill-buffer (current-buffer)) + (when (>= (length message) 2) + (let ((result (dns-read message tcp))) + (funcall callback + (if full + result + (let ((answer (car (dns-get 'answers result)))) + (when (eq type (dns-get 'type answer)) + (if (eq type 'TXT) + (dns-get-txt-answer (dns-get 'answers result)) + (dns-get 'data answer)))))))))) + +(defun dns-query (name &optional type full reverse) + "Query a DNS server for NAME of TYPE. +If FULL, return the entire record returned. +If REVERSE, look up an IP address." + (let ((result nil)) + (dns-query-asynchronous + name + (lambda (response) + (setq result (list response))) + type full reverse) + ;; Loop until we get the callback. + (while (not result) + (sleep-for 0.01)) + (car result))) (provide 'dns) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 20a5c5f6075..bb6682520ae 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -1,4 +1,4 @@ -;;; eudc-bob.el --- Binary Objects Support for EUDC +;;; eudc-bob.el --- Binary Objects Support for EUDC -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -39,19 +39,41 @@ (require 'eudc) -(defvar eudc-bob-generic-keymap nil +(defvar eudc-bob-generic-keymap + (let ((map (make-sparse-keymap))) + (define-key map "s" 'eudc-bob-save-object) + (define-key map "!" 'eudc-bob-pipe-object-to-external-program) + (define-key map [down-mouse-3] 'eudc-bob-popup-menu) + map) "Keymap for multimedia objects.") -(defvar eudc-bob-image-keymap nil +(defvar eudc-bob-image-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map eudc-bob-generic-keymap) + (define-key map "t" 'eudc-bob-toggle-inline-display) + map) "Keymap for inline images.") -(defvar eudc-bob-sound-keymap nil +(defvar eudc-bob-sound-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map eudc-bob-generic-keymap) + (define-key map (kbd "RET") 'eudc-bob-play-sound-at-point) + (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) + map) "Keymap for inline sounds.") -(defvar eudc-bob-url-keymap nil +(defvar eudc-bob-url-keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'browse-url-at-point) + (define-key map [down-mouse-2] 'browse-url-at-mouse) + map) "Keymap for inline urls.") -(defvar eudc-bob-mail-keymap nil +(defvar eudc-bob-mail-keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'goto-address-at-point) + (define-key map [down-mouse-2] 'goto-address-at-point) + map) "Keymap for inline e-mail addresses.") (defvar eudc-bob-generic-menu @@ -71,16 +93,9 @@ `("EUDC Sound Menu" ["---" nil nil] ["Play sound" eudc-bob-play-sound-at-point - (fboundp 'play-sound)] + (fboundp 'play-sound-internal)] ,@(cdr (cdr eudc-bob-generic-menu)))) -(defun eudc-jump-to-event (event) - "Jump to the window and point where EVENT occurred." - (if (fboundp 'event-closest-point) - (goto-char (event-closest-point event)) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))))) - (defun eudc-bob-get-overlay-prop (prop) "Get property PROP from one of the overlays around." (let ((overlays (append (overlays-at (1- (point))) @@ -197,7 +212,7 @@ display a button." (let (sound) (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) (error "No sound data available here") - (unless (fboundp 'play-sound) + (unless (fboundp 'play-sound-internal) (error "Playing sounds not supported on this system")) (play-sound (list 'sound :data sound))))) @@ -205,44 +220,30 @@ display a button." "Play the sound data contained in the button where EVENT occurred." (interactive "e") (save-excursion - (eudc-jump-to-event event) + (mouse-set-point event) (eudc-bob-play-sound-at-point))) -(defun eudc-bob-save-object () +(defun eudc-bob-save-object (filename) "Save the object data of the button at point." - (interactive) + (interactive "fWrite file: ") (let ((data (eudc-bob-get-overlay-prop 'object-data)) - (buffer (generate-new-buffer "*eudc-tmp*"))) - (save-excursion - (if (fboundp 'set-buffer-file-coding-system) - (set-buffer-file-coding-system 'binary)) - (set-buffer buffer) - (set-buffer-multibyte nil) - (insert data) - (save-buffer)) - (kill-buffer buffer))) + (coding-system-for-write 'binary)) ;Inhibit EOL conversion. + (write-region data nil filename))) -(defun eudc-bob-pipe-object-to-external-program () +(defun eudc-bob-pipe-object-to-external-program (program) "Pipe the object data of the button at point to an external program." - (interactive) + (interactive (list (completing-read "Viewer: " eudc-external-viewers))) (let ((data (eudc-bob-get-overlay-prop 'object-data)) - (buffer (generate-new-buffer "*eudc-tmp*")) - program - viewer) - (condition-case nil - (save-excursion - (if (fboundp 'set-buffer-file-coding-system) - (set-buffer-file-coding-system 'binary)) - (set-buffer buffer) - (insert data) - (setq program (completing-read "Viewer: " eudc-external-viewers)) - (if (setq viewer (assoc program eudc-external-viewers)) - (call-process-region (point-min) (point-max) - (car (cdr viewer)) - (cdr (cdr viewer))) - (call-process-region (point-min) (point-max) program))) - (error - (kill-buffer buffer))))) + (viewer (assoc program eudc-external-viewers))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert data) + (let ((coding-system-for-write 'binary)) ;Inhibit EOL conversion + (if viewer + (call-process-region (point-min) (point-max) + (car (cdr viewer)) + (cdr (cdr viewer))) + (call-process-region (point-min) (point-max) program)))))) (defun eudc-bob-menu () "Retrieve the menu attached to a binary object." @@ -252,47 +253,8 @@ display a button." "Pop-up a menu of EUDC multimedia commands." (interactive "@e") (run-hooks 'activate-menubar-hook) - (eudc-jump-to-event event) - (let ((result (x-popup-menu t (eudc-bob-menu))) - command) - (if result - (progn - (setq command (lookup-key (eudc-bob-menu) - (apply 'vector result))) - (command-execute command))))) - -(setq eudc-bob-generic-keymap - (let ((map (make-sparse-keymap))) - (define-key map "s" 'eudc-bob-save-object) - (define-key map "!" 'eudc-bob-pipe-object-to-external-program) - (define-key map [down-mouse-3] 'eudc-bob-popup-menu) - map)) - -(setq eudc-bob-image-keymap - (let ((map (make-sparse-keymap))) - (define-key map "t" 'eudc-bob-toggle-inline-display) - map)) - -(setq eudc-bob-sound-keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] 'eudc-bob-play-sound-at-point) - (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) - map)) - -(setq eudc-bob-url-keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] 'browse-url-at-point) - (define-key map [down-mouse-2] 'browse-url-at-mouse) - map)) - -(setq eudc-bob-mail-keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] 'goto-address-at-point) - (define-key map [down-mouse-2] 'goto-address-at-point) - map)) - -(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) -(set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap) + (mouse-set-point event) + (popup-menu (eudc-bob-menu) event)) ;; If the first arguments can be nil here, then these 3 can be ;; defconsts once more. diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el new file mode 100644 index 00000000000..3c0d88fc23f --- /dev/null +++ b/lisp/net/eudcb-macos-contacts.el @@ -0,0 +1,123 @@ +;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Alexander Adolf + +;; 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: +;; This library provides an interface to the macOS Contacts app as +;; an EUDC data source. It uses AppleScript to interface with the +;; Contacts app on localhost, so no 3rd party tools are needed. + +;;; Usage: +;; (require 'eudcb-macos-contacts) +;; (eudc-macos-contacts-set-server "localhost") + +;;; Code: + +(require 'eudc) +(require 'executable) + +;;{{{ Internal cooking + +(defvar eudc-macos-contacts-conversion-alist nil) + +;; hook ourselves into the EUDC framework +(eudc-protocol-set 'eudc-query-function + 'eudc-macos-contacts-query-internal + 'macos-contacts) +(eudc-protocol-set 'eudc-list-attributes-function + nil + 'macos-contacts) +(eudc-protocol-set 'eudc-macos-contacts-conversion-alist + nil + 'macos-contacts) +(eudc-protocol-set 'eudc-protocol-has-default-query-attributes + nil + 'macos-contacts) + +(defun eudc-macos-contacts-search-helper (str) + "Helper function to query the Contacts app via AppleScript. +Searches for all persons with a case-insensitive substring match +of STR in any of their name fields (first, middle, or last)." + (if (executable-find "osascript") + (call-process "osascript" nil t nil + "-e" + (format " +set results to {} +tell application \"Address Book\" + set pList to every person whose (name contains \"%s\") + repeat with pers in pList + repeat with emailAddr in emails of pers + set results to results & {name of pers & \":\" & value ¬ + of emailAddr & \"\n\"} + end repeat + end repeat + get results as text +end tell" str)) + (message (concat "[eudc] Error in macOS Contacts backend: " + "`osascript' executable not found. " + "Is this is a macOS 10.0 or later system?")))) + +(defun eudc-macos-contacts-query-internal (query &optional return-attrs) + "Query macOS Contacts with QUERY. +QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid +macOS Contacts attribute names. +RETURN-ATTRS is a list of attributes to return, defaulting to +`eudc-default-return-attributes'." + (let ((macos-contacts-buffer (get-buffer-create " *macOS Contacts*")) + result) + (with-current-buffer macos-contacts-buffer + (erase-buffer) + (dolist (term query) + (eudc-macos-contacts-search-helper (cdr term))) + (delete-duplicate-lines (point-min) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (if (not (equal (line-beginning-position) (line-end-position))) + (let* ((args (split-string (buffer-substring + (point) (line-end-position)) + ":")) + (name (nth 0 args)) + (email (nth 1 args))) + (setq result (cons `((name . ,name) + (email . ,email)) + result)))) + (forward-line)) + result))) + +;;}}} + +;;{{{ High-level interfaces (interactive functions) + +(defun eudc-macos-contacts-set-server (dummy) + "Set the EUDC server to macOS Contacts app. +The server in DUMMY is not actually used, since this backend +always and implicitly connetcs to an instance of the Contacts app +running on the local host." + (interactive) + (eudc-set-server dummy 'macos-contacts) + (message "[eudc] macOS Contacts app server selected")) + +;;}}} + +(eudc-register-protocol 'macos-contacts) + +(provide 'eudcb-macos-contacts) + +;;; eudcb-macos-contacts.el ends here diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 568b96f4d58..07aa48aeaee 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -25,14 +25,15 @@ ;;; 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 +(require 'xdg) +(eval-when-compile (require 'subr-x)) (defgroup eww nil "Emacs Web Wowser" @@ -55,11 +56,24 @@ :group 'eww :type 'string) -(defcustom eww-download-directory "~/Downloads/" - "Directory where files will downloaded." - :version "24.4" +(defun erc--download-directory () + "Return the name of the download directory. +If ~/Downloads/ exists, that will be used, and if not, the +DOWNLOAD XDG user directory will be returned. If that's +undefined, ~/Downloads/ is returned anyway." + (or (and (file-exists-p "~/Downloads/") + "~/Downloads/") + (when-let ((dir (xdg-user-dir "DOWNLOAD"))) + (file-name-as-directory dir)) + "~/Downloads/")) + +(defcustom eww-download-directory 'erc--download-directory + "Directory where files will downloaded. +This should either be a directory name or a function (called with +no parameters) that returns a directory name." + :version "28.1" :group 'eww - :type 'directory) + :type '(choice directory function)) ;;;###autoload (defcustom eww-suggest-uris @@ -263,19 +277,40 @@ This list can be customized via `eww-suggest-uris'." (nreverse uris))) ;;;###autoload -(defun eww (url &optional arg) +(defun eww-browse () + "Function to be run to parse command line URLs. +This is meant to be used for MIME handlers or command line use. + +Setting the handler for \"text/x-uri;\" to +\"emacs -f eww-browse %u\" will then start up Emacs and call eww +to browse the url. + +This can also be used on the command line directly: + + emacs -f eww-browse https://gnu.org + +will start Emacs and browse the GNU web site." + (interactive) + (eww (pop command-line-args-left))) + + +;;;###autoload +(defun eww (url &optional arg buffer) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer." +the default EWW buffer. + +If BUFFER, the data to be rendered is in that buffer. In that +case, this function doesn't actually fetch URL. BUFFER will be +killed after rendering." (interactive - (let* ((uris (eww-suggested-uris)) - (prompt (concat "Enter URL or keywords" - (if uris (format " (default %s)" (car uris)) "") - ": "))) - (list (read-string prompt nil 'eww-prompt-history uris) + (let ((uris (eww-suggested-uris))) + (list (read-string (format-prompt "Enter URL or keywords" + (and uris (car uris))) + nil 'eww-prompt-history uris) (prefix-numeric-value current-prefix-arg)))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window @@ -307,8 +342,14 @@ 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 - (list url nil (current-buffer))))) + (if buffer + (let ((eww-buffer (current-buffer))) + (with-current-buffer buffer + (eww-render nil url nil eww-buffer))) + (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)) @@ -359,7 +400,19 @@ the default EWW buffer." (eww (concat "file://" (and (memq system-type '(windows-nt ms-dos)) "/") - (expand-file-name file)))) + (expand-file-name file)) + nil + ;; The file name may be a non-local Tramp file. The URL + ;; library doesn't understand these file names, so use the + ;; normal Emacs machinery to load the file. + (with-current-buffer (generate-new-buffer " *eww file*") + (set-buffer-multibyte nil) + (insert "Content-type: " (or (mailcap-extension-to-mime + (url-file-extension file)) + "application/octet-stream") + "\n\n") + (insert-file-contents file) + (current-buffer)))) ;;;###autoload (defun eww-search-words () @@ -373,8 +426,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 +594,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 @@ -614,25 +667,78 @@ Currently this means either text/html or application/xhtml+xml." eww-image-link-keymap eww-link-keymap)))) +(defun eww--limit-string-pixelwise (string pixels) + (if (not pixels) + string + (with-temp-buffer + (insert string) + (if (< (eww--pixel-column) pixels) + string + ;; Iterate to find appropriate length. + (while (and (> (eww--pixel-column) pixels) + (not (bobp))) + (forward-char -1)) + ;; Return at least one character. + (buffer-substring (point-min) (max (point) + (1+ (point-min)))))))) + +(defun eww--pixel-column () + (if (not (get-buffer-window (current-buffer))) + (save-window-excursion + ;; Avoid errors if the selected window is a dedicated one, + ;; and they just want to insert a document into it. + (set-window-dedicated-p nil nil) + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size nil (line-beginning-position) (point)))) + (car (window-text-pixel-size nil (line-beginning-position) (point))))) + (defun eww-update-header-line-format () (setq header-line-format (and eww-header-line-format - (let ((title (plist-get eww-data :title)) - (peer (plist-get eww-data :peer))) + (let ((title (propertize (plist-get eww-data :title) + 'face 'variable-pitch)) + (peer (plist-get eww-data :peer)) + (url (propertize (plist-get eww-data :url) + 'face 'variable-pitch))) (when (zerop (length title)) - (setq title "[untitled]")) + (setq title (propertize "[untitled]" 'face 'variable-pitch))) ;; This connection has is https. (when peer - (setq title - (propertize title 'face - (if (plist-get peer :warnings) - 'eww-invalid-certificate - 'eww-valid-certificate)))) + (add-face-text-property 0 (length title) + (if (plist-get peer :warnings) + 'eww-invalid-certificate + 'eww-valid-certificate) + t title)) + ;; Limit the length of the title so that the host name + ;; of the URL is always visible. + (when url + (let* ((parsed (url-generic-parse-url url)) + (host-length (shr-string-pixel-width + (format "%s://%s" (url-type parsed) + (url-host parsed)))) + (width (window-width nil t))) + (cond + ;; The host bit is wider than the window, so nix + ;; the title. + ((> (+ host-length (shr-string-pixel-width "xxxxx")) width) + (setq title "")) + ;; Trim the title. + ((> (+ (shr-string-pixel-width (concat title "xx")) + host-length) + width) + (setq title + (concat + (eww--limit-string-pixelwise + title (- width host-length + (shr-string-pixel-width + (propertize "...: " 'face + 'variable-pitch)))) + (propertize "..." 'face 'variable-pitch))))))) (replace-regexp-in-string "%" "%%" (format-spec eww-header-line-format - `((?u . ,(or (plist-get eww-data :url) "")) + `((?u . ,(or url "")) (?t . ,title)))))))) (defun eww-tag-title (dom) @@ -1011,7 +1117,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. @@ -1060,6 +1166,8 @@ just re-display the HTML already fetched." (defvar eww-select-map (let ((map (make-sparse-keymap))) (define-key map "\r" 'eww-change-select) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] 'eww-change-select) (define-key map [(control c) (control c)] 'eww-submit) map)) @@ -1111,11 +1219,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 @@ -1256,7 +1366,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-tag-textarea (dom) (let ((start (point)) - (value (or (dom-attr dom 'value) "")) + (value (or (dom-text dom) "")) (lines (string-to-number (or (dom-attr dom 'rows) "10"))) (width (string-to-number (or (dom-attr dom 'cols) "10"))) end) @@ -1325,16 +1435,15 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (options nil) (start (point)) (max 0)) - (dolist (elem (dom-non-text-children dom)) - (when (eq (dom-tag elem) 'option) - (when (dom-attr elem 'selected) - (nconc menu (list :value (dom-attr elem 'value)))) - (let ((display (dom-text elem))) - (setq max (max max (length display))) - (push (list 'item - :value (dom-attr elem 'value) - :display display) - options)))) + (dolist (elem (dom-by-tag dom 'option)) + (when (dom-attr elem 'selected) + (nconc menu (list :value (dom-attr elem 'value)))) + (let ((display (dom-text elem))) + (setq max (max max (length display))) + (push (list 'item + :value (dom-attr elem 'value) + :display display) + options))) (when options (setq options (nreverse options)) ;; If we have no selected values, default to the first value. @@ -1361,25 +1470,30 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (setq display (plist-get (cdr elem) :display)))) display)) -(defun eww-change-select () +(defun eww--form-items (form) + (cl-loop for elem in form + when (and (consp elem) + (eq (car elem) 'item)) + collect (cdr elem))) + +(defun eww-change-select (event) "Change the value of the select drop-down menu under point." - (interactive) - (let* ((input (get-text-property (point) 'eww-form)) - (completion-ignore-case t) - (options - (delq nil - (mapcar (lambda (elem) - (and (consp elem) - (eq (car elem) 'item) - (cons (plist-get (cdr elem) :display) - (plist-get (cdr elem) :value)))) - input))) - (display - (completing-read "Change value: " options nil 'require-match)) - (inhibit-read-only t)) - (plist-put input :value (cdr (assoc-string display options t))) - (goto-char - (eww-update-field display)))) + (interactive (list last-nonmenu-event)) + (mouse-set-point event) + (let ((input (get-text-property (point) 'eww-form))) + (popup-menu + (cons + "Change Value" + (mapcar + (lambda (elem) + (vector (plist-get elem :display) + (lambda () + (interactive) + (plist-put input :value (plist-get elem :value)) + (goto-char (eww-update-field (plist-get elem :display)))) + t)) + (eww--form-items input))) + event))) (defun eww-update-field (string &optional offset) (unless offset @@ -1572,8 +1686,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)) @@ -1606,20 +1722,23 @@ Differences in #targets are ignored." "Download URL to `eww-download-directory'. Use link at point if there is one, else the current page's URL." (interactive) - (access-file eww-download-directory "Download failed") - (let ((url (or (get-text-property (point) 'shr-url) - (eww-current-url)))) - (if (not url) - (message "No URL under point") - (url-retrieve url 'eww-download-callback (list url))))) - -(defun eww-download-callback (status url) + (let ((dir (if (stringp eww-download-directory) + eww-download-directory + (funcall eww-download-directory)))) + (access-file dir "Download failed") + (let ((url (or (get-text-property (point) 'shr-url) + (eww-current-url)))) + (if (not url) + (message "No URL under point") + (url-retrieve url #'eww-download-callback (list url dir)))))) + +(defun eww-download-callback (status url dir) (unless (plist-get status :error) (let* ((obj (url-generic-parse-url url)) (path (directory-file-name (car (url-path-and-query obj)))) (file (eww-make-unique-file-name (eww-decode-url-file-name (file-name-nondirectory path)) - eww-download-directory))) + dir))) (goto-char (point-min)) (re-search-forward "\r?\n\r?\n") (let ((coding-system-for-write 'no-conversion)) @@ -1735,28 +1854,30 @@ 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 () +(defun eww-read-bookmarks (&optional error-out) + "Read bookmarks from `eww-bookmarks'. +If ERROR-OUT, signal user-error if there are no bookmarks." (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory))) (setq eww-bookmarks (unless (zerop (or (file-attribute-size (file-attributes file)) 0)) (with-temp-buffer (insert-file-contents file) - (read (current-buffer))))))) + (read (current-buffer))))) + (when (and error-out (not eww-bookmarks)) + (user-error "No bookmarks are defined")))) ;;;###autoload (defun eww-list-bookmarks () "Display the bookmarks." (interactive) + (eww-read-bookmarks t) (pop-to-buffer "*eww bookmarks*") (eww-bookmark-prepare)) (defun eww-bookmark-prepare () - (eww-read-bookmarks) - (unless eww-bookmarks - (user-error "No bookmarks are defined")) (set-buffer (get-buffer-create "*eww bookmarks*")) (eww-bookmark-mode) (let* ((width (/ (window-width) 2)) @@ -1824,6 +1945,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (when (and (not first) @@ -1842,6 +1964,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (if first @@ -2124,12 +2247,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 5212bf6a3f6..e713c94117b 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -170,8 +170,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. @@ -209,7 +210,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/goto-addr.el b/lisp/net/goto-addr.el index 9436f45aa32..43bea76a6bc 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -280,6 +280,16 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and (widen) (goto-address-unfontify (point-min) (point-max))))) +(defun goto-addr-mode--turn-on () + (when (not goto-address-mode) + (goto-address-mode 1))) + +;;;###autoload +(define-globalized-minor-mode global-goto-address-mode + goto-address-mode goto-addr-mode--turn-on + :group 'goto-address + :version "28.1") + ;;;###autoload (define-minor-mode goto-address-prog-mode "Like `goto-address-mode', but only for comments and strings." 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..22b59084004 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -134,9 +134,9 @@ ;; ;;; Code: +;;; Dependencies (eval-when-compile (require 'cl-lib)) -(require 'format-spec) (require 'utf7) (require 'rfc2104) ;; Hmm... digest-md5 is not part of Emacs. @@ -146,7 +146,7 @@ (declare-function digest-md5-digest-uri "ext:digest-md5") (declare-function digest-md5-challenge "ext:digest-md5") -;; User variables. +;;; User variables (defgroup imap nil "Low-level IMAP issues." @@ -258,7 +258,7 @@ Shorter values mean quicker response, but is more CPU intensive." :group 'imap :type 'boolean) -;; Various variables. +;;; Various variables (defvar imap-fetch-data-hook nil "Hooks called after receiving each FETCH response.") @@ -317,7 +317,9 @@ the value of this variable will be bound to a certain value to which an application program that uses this module specifies on a per-server basis.") -;; Internal constants. Change these and die. +;;; Internal constants + +;; Change these and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) @@ -349,7 +351,7 @@ basis.") (defconst imap-log-buffer "*imap-log*") (defconst imap-debug-buffer "*imap-debug*") -;; Internal variables. +;;; Internal variables (defvar imap-stream nil) (defvar imap-auth nil) @@ -438,7 +440,7 @@ This variable is set to t automatically per server if the canonical form fails.") -;; Utility functions: +;;; Utility functions (defun imap-remassoc (key alist) "Delete by side effect any elements of ALIST whose car is `equal' to KEY. @@ -490,7 +492,8 @@ sure of changing the value of `foo'." (nth 3 (car imap-failed-tags)))) -;; Server functions; stream stuff: +;;; Server functions +;;;; Stream functions (defun imap-log (string-or-buffer) (when imap-log @@ -517,12 +520,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 +583,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 +698,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 @@ -757,7 +751,7 @@ sure of changing the value of `foo'." (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) done)) -;; Server functions; authenticator stuff: +;;;; Authenticator functions (defun imap-interactive-login (buffer loginfunc) "Login to server in BUFFER. @@ -881,7 +875,7 @@ t if it successfully authenticates, nil otherwise." (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) -;;; Compiler directives. +;;; Compiler directives (defvar imap-sasl-client) (defvar imap-sasl-step) @@ -979,7 +973,7 @@ t if it successfully authenticates, nil otherwise." (imap-send-command-1 "") (imap-ok-p (imap-wait-for-tag tag))))))) -;; Server functions: +;;; Server functions (defun imap-open-1 (buffer) (with-current-buffer buffer @@ -1238,7 +1232,7 @@ If BUFFER is nil, the current buffer is assumed." (imap-send-command-wait "LOGOUT" buffer))) -;; Mailbox functions: +;;; Mailbox functions (defun imap-mailbox-put (propname value &optional mailbox buffer) (with-current-buffer (or buffer (current-buffer)) @@ -1530,7 +1524,7 @@ or `unseen'. The IMAP command tag is returned." identifier)))))) -;; Message functions: +;;; Message functions (defun imap-current-message (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -1842,7 +1836,7 @@ on failure." (if (aref from 0) ">")))) -;; Internal functions. +;;; Internal functions (defun imap-add-callback (tag func) (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) @@ -1979,7 +1973,7 @@ Return nil if no complete line has arrived." (delete-region (point-min) (point-max))))))))) -;; Imap parser. +;;; Imap parser (defsubst imap-forward () (or (eobp) (forward-char))) @@ -2860,6 +2854,8 @@ Return nil if no complete line has arrived." (imap-forward) (nreverse body))))) +;;; Debug + (when imap-debug ; (untrace-all) (require 'trace) (buffer-disable-undo (get-buffer-create imap-debug-buffer)) 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/mailcap.el b/lisp/net/mailcap.el index 5fe5b4d3a54..f01a5deb7ec 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -29,6 +29,7 @@ ;;; Code: +(require 'cl-lib) (autoload 'mail-header-parse-content-type "mail-parse") (defgroup mailcap nil @@ -268,11 +269,6 @@ is consulted." (viewer . "display %s") (type . "image/*") (test . (eq window-system 'x)) - ("needsx11")) - (".*" - (viewer . "ee %s") - (type . "image/*") - (test . (eq window-system 'x)) ("needsx11"))) ("text" ("plain" @@ -337,6 +333,10 @@ is a string or list of strings, it represents a shell command to run to return a true or false shell value for the validity.") (put 'mailcap-mime-data 'risky-local-variable t) +(defvar mailcap--computed-mime-data nil + "Computed version of the mailcap data incorporating all sources. +Same format as `mailcap-mime-data'.") + (defcustom mailcap-download-directory nil "Directory to which `mailcap-save-binary-file' downloads files by default. nil means your home directory." @@ -422,7 +422,13 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus (when (or (not mailcap-parsed-p) force) ;; Clear out all old data. - (setq mailcap-mime-data nil) + (setq mailcap--computed-mime-data nil) + ;; Add the Emacs-distributed defaults (which will be used as + ;; fallbacks). Do it this way instead of just copying the list, + ;; since entries are destructively modified. + (cl-loop for (major . minors) in mailcap-mime-data + do (cl-loop for (minor . entry) in minors + do (mailcap-add-mailcap-entry major minor entry))) (cond (path nil) ((getenv "MAILCAPS") @@ -709,10 +715,13 @@ to supply to the test." (push (list otest result) mailcap-viewer-test-cache) result)))) -(defun mailcap-add-mailcap-entry (major minor info) - (let ((old-major (assoc major mailcap-mime-data))) +(defun mailcap-add-mailcap-entry (major minor info &optional storage) + (let* ((storage (or storage 'mailcap--computed-mime-data)) + (old-major (assoc major (symbol-value storage)))) (if (null old-major) ; New major area - (push (cons major (list (cons minor info))) mailcap-mime-data) + (set storage + (cons (cons major (list (cons minor info))) + (symbol-value storage))) (let ((cur-minor (assoc minor old-major))) (cond ((or (null cur-minor) ; New minor area, or @@ -736,11 +745,15 @@ If TEST is not given, it defaults to t." (when (or (not (car tl)) (not (cadr tl))) (error "%s is not a valid MIME type" type)) - (mailcap-add-mailcap-entry - (car tl) (cadr tl) - `((viewer . ,viewer) - (test . ,(if test test t)) - (type . ,type))))) + (let ((entry + `((viewer . ,viewer) + (test . ,(if test test t)) + (type . ,type)))) + ;; Store it. + (mailcap-add-mailcap-entry (car tl) (cadr tl) entry + 'mailcap-user-mime-data) + ;; Make it available for usage. + (mailcap-add-mailcap-entry (car tl) (cadr tl) entry)))) ;;; ;;; The main whabbo @@ -791,13 +804,13 @@ If NO-DECODE is non-nil, don't decode STRING." ;; NO-DECODE avoids calling `mail-header-parse-content-type' from ;; `mail-parse.el' (let ( - major ; Major encoding (text, etc) - minor ; Minor encoding (html, etc) - info ; Other info - major-info ; (assoc major mailcap-mime-data) - viewers ; Possible viewers - passed ; Viewers that passed the test - viewer ; The one and only viewer + major ; Major encoding (text, etc) + minor ; Minor encoding (html, etc) + info ; Other info + major-info ; (assoc major mailcap--computed-mime-data) + viewers ; Possible viewers + passed ; Viewers that passed the test + viewer ; The one and only viewer ctl) (save-excursion (setq ctl @@ -809,12 +822,12 @@ If NO-DECODE is non-nil, don't decode STRING." (if viewer (setq passed (list viewer)) ;; None found, so heuristically select some applicable viewer - ;; from `mailcap-mime-data'. + ;; from `mailcap--computed-mime-data'. (mailcap-parse-mailcaps nil t) (setq major (split-string (car ctl) "/")) (setq minor (cadr major) major (car major)) - (when (setq major-info (cdr (assoc major mailcap-mime-data))) + (when (setq major-info (cdr (assoc major mailcap--computed-mime-data))) (when (setq viewers (mailcap-possible-viewers major-info minor)) (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) (cdr a))) @@ -847,7 +860,7 @@ If NO-DECODE is non-nil, don't decode STRING." ((eq request 'all) passed) (t - ;; MUST make a copy *sigh*, else we modify mailcap-mime-data + ;; MUST make a copy *sigh*, else we modify mailcap--computed-mime-data (setq viewer (copy-sequence viewer)) (let ((view (assq 'viewer viewer)) (test (assq 'test viewer))) @@ -1057,7 +1070,7 @@ For instance, \"foo.png\" will result in \"image/png\"." (nconc (mapcar 'cdr mailcap-mime-extensions) (let (res type) - (dolist (data mailcap-mime-data) + (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) (setq type (cdr (assq 'type (cdr info)))) (unless (string-match-p "\\*" type) @@ -1117,7 +1130,7 @@ For instance, \"foo.png\" will result in \"image/png\"." (defun mailcap-view-mime (type) "View the data in the current buffer that has MIME type TYPE. -`mailcap-mime-data' determines the method to use." +`mailcap--computed-mime-data' determines the method to use." (let ((method (mailcap-mime-info type))) (if (stringp method) (shell-command-on-region (point-min) (point-max) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index e99d7a372c0..e86426d4664 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 @@ -135,7 +139,10 @@ values: :capability-command specifies a command used to query the HOST for its capabilities. For instance, for IMAP this should be - \"1 CAPABILITY\\r\\n\". + \"1 CAPABILITY\\r\\n\". This can either be a string (which will + then be sent verbatim to the server), or a function (called with + a single parameter; the \"greeting\" from the server when connecting), + and should return a string to send to the server. :starttls-function specifies a function for handling STARTTLS. This function should take one parameter, the response to the @@ -166,8 +173,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 +196,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 +257,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,11 +279,15 @@ 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 - eo-capa)) + (capabilities + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)) (resulting-type 'plain) starttls-available starttls-command error) @@ -322,7 +335,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; Requery capabilities for protocols that require it; i.e., ;; EHLO for SMTP. (when (plist-get parameters :always-query-capabilities) - (network-stream-command stream capability-command eo-capa))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa))) (when (let ((response (network-stream-command stream starttls-command eoc))) (and response (string-match success-string response))) @@ -350,14 +366,18 @@ 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" host service)) ;; Re-get the capabilities, which may have now changed. (setq capabilities - (network-stream-command stream capability-command eo-capa)))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)))) ;; If TLS is mandatory, close the connection if it's unencrypted. (when (and require-tls @@ -420,7 +440,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." parameters) (require 'tls) (open-tls-stream name buffer host service))) - (eoc (plist-get parameters :end-of-command))) + (eoc (plist-get parameters :end-of-command)) + greeting) (if (plist-get parameters :nowait) (list stream nil nil 'tls) ;; Check certificate validity etc. @@ -432,42 +453,58 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; openssl/gnutls-cli. (when (and (not (gnutls-available-p)) eoc) - (network-stream-get-response stream start eoc) + (setq greeting (network-stream-get-response stream start eoc)) (goto-char (point-min)) (when (re-search-forward eoc nil t) (goto-char (match-beginning 0)) (delete-region (point-min) (line-beginning-position)))) - (let ((capability-command (plist-get parameters :capability-command)) + (let ((capability-command + (plist-get parameters :capability-command)) (eo-capa (or (plist-get parameters :end-of-capability) eoc))) (list stream (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eo-capa) + (network-stream-command + stream + (network-stream--capability-command + capability-command greeting) + 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)))))) + greeting) + (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 - (or (plist-get parameters :end-of-capability) - eoc)) + (setq greeting (network-stream-get-response stream start eoc)) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + (or (plist-get parameters :end-of-capability) + eoc)) 'plain))) +(defun network-stream--capability-command (command greeting) + (if (functionp command) + (funcall command greeting) + command)) + (provide 'network-stream) ;;; network-stream.el ends here 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/newst-treeview.el b/lisp/net/newst-treeview.el index 1bed61f3e7d..ff8a447c7c1 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -131,14 +131,6 @@ groupcontent := feedname | groupdefinition) Example: (\"Topmost group\" \"feed1\" (\"subgroup1\" \"feed 2\") \"feed3\")") -(defcustom newsticker-groups-filename - nil - "Name of the newsticker groups settings file." - :version "25.1" ; changed default value to nil - :type '(choice (const nil) string) - :group 'newsticker-treeview) -(make-obsolete-variable 'newsticker-groups-filename 'newsticker-dir "23.1") - ;; ====================================================================== ;;; internal variables ;; ====================================================================== @@ -1265,29 +1257,9 @@ Note: does not update the layout." (defun newsticker--treeview-load () "Load treeview settings." (let* ((coding-system-for-read 'utf-8) - (filename - (or (and newsticker-groups-filename - (not (string= - (expand-file-name newsticker-groups-filename) - (expand-file-name (concat newsticker-dir "/groups")))) - (file-exists-p newsticker-groups-filename) - (y-or-n-p - (format-message - (concat "Obsolete variable `newsticker-groups-filename' " - "points to existing file \"%s\".\n" - "Read it? ") - newsticker-groups-filename)) - newsticker-groups-filename) - (concat newsticker-dir "/groups"))) + (filename (concat newsticker-dir "/groups")) (buf (and (file-exists-p filename) (find-file-noselect filename)))) - (and newsticker-groups-filename - (file-exists-p newsticker-groups-filename) - (y-or-n-p (format-message - (concat "Delete the file \"%s\",\nto which the obsolete " - "variable `newsticker-groups-filename' points ? ") - newsticker-groups-filename)) - (delete-file newsticker-groups-filename)) (when buf (set-buffer buf) (goto-char (point-min)) 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/ntlm.el b/lisp/net/ntlm.el index ebcd21948bf..9401430799c 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -69,7 +69,6 @@ (require 'md4) (require 'hmac-md5) -(require 'calc) (defgroup ntlm nil "NTLM (NT LanManager) authentication." @@ -133,32 +132,27 @@ is not given." domain ;buffer field )))) -(defun ntlm-compute-timestamp () - "Compute an NTLMv2 timestamp. +(defun ntlm--time-to-timestamp (time) + "Convert TIME to an NTLMv2 timestamp. Return a unibyte string representing the number of tenths of a microsecond since January 1, 1601 as a 64-bit little-endian -signed integer." - ;; FIXME: This can likely be significantly simplified using the new - ;; bignums support! - (let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)") - (us-to-tenths-of-us "mul($3,10)") - (ps-to-tenths-of-us "idiv($4,100000)") - (tenths-of-us-since-jan-1-1601 - (apply #'calc-eval (concat "add(add(add(" - s-to-tenths-of-us "," - us-to-tenths-of-us ")," - ps-to-tenths-of-us ")," - ;; tenths of microseconds between - ;; 1601-01-01 and 1970-01-01 - "116444736000000000)") - 'rawnum (time-convert nil 'list))) - result-bytes) - (dotimes (_byte 8) - (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601) - result-bytes) - (setq tenths-of-us-since-jan-1-1601 - (calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601))) - (apply #'unibyte-string (nreverse result-bytes)))) +signed integer. TIME must be on the form (HIGH LOW USEC PSEC)." + (let* ((s (+ (ash (nth 0 time) 16) (nth 1 time))) + (us (nth 2 time)) + (ps (nth 3 time)) + (tenths-of-us-since-jan-1-1601 + (+ (* s 10000000) (* us 10) (/ ps 100000) + ;; tenths of microseconds between 1601-01-01 and 1970-01-01 + 116444736000000000))) + (apply #'unibyte-string + (mapcar (lambda (i) + (logand (ash tenths-of-us-since-jan-1-1601 (* i -8)) + #xff)) + (number-sequence 0 7))))) + +(defun ntlm-compute-timestamp () + "Current time as an NTLMv2 timestamp, as a unibyte string." + (ntlm--time-to-timestamp (time-convert nil 'list))) (defun ntlm-generate-nonce () "Generate a random nonce, not to be used more than once. 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..f296ae3afe1 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"))))) @@ -625,7 +625,7 @@ SERVER-PLIST is the property list for the server." (default (or (plist-get server-plist :encryption) "plain"))) (intern - (completing-read (format "Encryption (default %s): " default) + (completing-read (format-prompt "Encryption" default) choices nil t nil nil default)))) (defun rcirc-keepalive () @@ -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..6517596130c 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -95,15 +95,31 @@ If nil, don't draw horizontal table lines." :type 'character) (defcustom shr-width nil - "Frame width to use for rendering. + "Window width to use for HTML rendering. May either be an integer specifying a fixed width in characters, -or nil, meaning that the full width of the window should be used. -If `shr-use-fonts' is set, the mean character width is used to -compute the pixel width, which is used instead." +or nil, meaning use the full width of the window. +If `shr-use-fonts' is set, the value is interpreted as a multiple +of the mean character width of the default face's font. + +Also see `shr-max-width'." :version "25.1" :type '(choice (integer :tag "Fixed width in characters") (const :tag "Use the width of the window" nil))) +(defcustom shr-max-width 120 + "Maximum text width to use for HTML rendering. +May either be an integer specifying a fixed width in characters, +or nil, meaning that there is no width limit. + +If `shr-use-fonts' is set, the value of this variable is +interpreted as a multiple of the mean character width of the +default face's font. + +If `shr-width' is non-nil, it overrides this variable." + :version "28.1" + :type '(choice (integer :tag "Fixed width in characters") + (const :tag "No width limit" nil))) + (defcustom shr-bullet "* " "Bullet used for unordered lists. Alternative suggestions are: @@ -135,7 +151,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 +201,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) @@ -265,30 +283,37 @@ DOM should be a parse tree as generated by (shr-table-separator-pixel-width (shr-string-pixel-width "-")) (shr-internal-bullet (cons shr-bullet (shr-string-pixel-width shr-bullet))) - (shr-internal-width (or (and shr-width - (if (not shr-use-fonts) - shr-width - (* shr-width (frame-char-width)))) - ;; We need to adjust the available - ;; width for when the user disables - ;; the fringes, which will cause the - ;; display engine usurp one column for - ;; the continuation glyph. - (if (not shr-use-fonts) - (- (window-body-width) 1 - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - 0 - 1)) - (- (window-body-width nil t) - (* 2 (frame-char-width)) - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0) - 1)))) + (shr-internal-width + (if shr-width + ;; Specified width; use it. + (if (not shr-use-fonts) + shr-width + (* shr-width (frame-char-width))) + ;; Compute the width based on the window width. We need to + ;; adjust the available width for when the user disables + ;; the fringes, which will cause the display engine usurp + ;; one column for the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (shr--have-one-fringe-p) + 1 + 0)) + (- (window-body-width nil t) + (* 2 (frame-char-width)) + (if (shr--have-one-fringe-p) + 0 + (* (frame-char-width) 2)) + 1)))) (max-specpdl-size max-specpdl-size) bidi-display-reordering) + ;; Adjust for max width specification. + (when (and shr-max-width + (not shr-width)) + (setq shr-internal-width + (min shr-internal-width + (if shr-use-fonts + (* shr-max-width (frame-char-width)) + shr-max-width)))) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it ;; starts with a non-hscrolled window (vertical-motion will move @@ -365,25 +390,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 +457,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 +483,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 +513,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 +551,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,10 +750,11 @@ 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) (shr-indent) + (when face + (put-text-property gap-start (point) + 'face (shr-face-background face))) (when (and (> (1- gap-start) (point-min)) (get-text-property (point) 'shr-url) ;; The link on both sides of the newline are the @@ -838,7 +859,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 +956,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 +1007,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 +1020,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 +1171,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. @@ -1195,25 +1209,8 @@ Return a string with image data." ;; that are non-ASCII. (shr-dom-to-xml (libxml-parse-xml-region (point) (point-max)) 'utf-8))) - ;; SVG images often do not have a specified foreground/background - ;; color, so wrap them in styles. - (when (and (display-images-p) - (eq content-type 'image/svg+xml)) - (setq data (svg--wrap-svg data))) (list data content-type))) -(defun svg--wrap-svg (data) - "Add a default foreground colour to SVG images." - (let ((size (image-size (create-image data nil t :scaling 1) t))) - (with-temp-buffer - (insert - (format - "<svg xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:xi=\"http://www.w3.org/2001/XInclude\" style=\"color: %s;\" viewBox=\"0 0 %d %d\"> <xi:include href=\"data:image/svg+xml;base64,%s\"></xi:include></svg>" - (face-foreground 'default) - (car size) (cdr size) - (base64-encode-string data t))) - (buffer-string)))) - (defun shr-image-displayer (content-function) "Return a function to display an image. CONTENT-FUNCTION is a function to retrieve an image for a cid url that @@ -1230,7 +1227,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 +1262,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 @@ -1316,7 +1315,7 @@ ones, in case fg and bg are nil." t)) (when bg (add-face-text-property start end - (list :background (car new-colors)) + (list :background (car new-colors) :extend t) t))) new-colors))) @@ -1438,7 +1437,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 +1494,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 +1675,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 +2002,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)) @@ -2253,7 +2250,7 @@ flags that control whether to collect or render objects." (not background)) (setq background (cadr elem)))) (and background - (list :background background)))))) + (list :background background :extend t)))))) (defun shr-expand-alignments (start end) (while (< (setq start (next-single-property-change @@ -2309,8 +2306,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 @@ -2585,12 +2582,28 @@ flags that control whether to collect or render objects." i)) (defun shr-max-columns (dom) - (let ((max 0)) + (let ((max 0) + (this 0) + (rowspans nil)) (dolist (row (dom-children dom)) (when (and (not (stringp row)) (eq (dom-tag row) 'tr)) - (setq max (max max (+ (shr-count row 'td) - (shr-count row 'th)))))) + (setq this 0) + (dolist (column (dom-children row)) + (when (and (not (stringp column)) + (memq (dom-tag column) '(td th))) + (setq this (+ 1 this (length rowspans))) + ;; We have a rowspan, which we emulate later in rendering + ;; by adding an extra column to the following rows. + (when-let* ((span (dom-attr column 'rowspan))) + (push (string-to-number span) rowspans)))) + (setq max (max max this))) + ;; Count down the rowspans in effect. + (let ((new nil)) + (dolist (span rowspans) + (when (> span 1) + (push (1- span) new))) + (setq rowspans new))) max)) (provide 'shr) diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index e8c0c1bbdf4..29c415e6a65 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -149,7 +149,7 @@ rejecting one login and prompting again for a username and password.") ((string-match "passw" string) (telnet-filter proc string) (setq telnet-count 0) - (process-send-string proc (concat (comint-read-noecho "Password: " t) + (process-send-string proc (concat (read-passwd "Password: ") telnet-new-line)) (clear-this-command-keys)) (t (telnet-check-software-type-initialize string) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 0efe055b084..49ecaa58ee8 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -57,15 +57,27 @@ It is used for TCP/IP devices." "When this method name is used, forward all calls to Android Debug Bridge.") ;;;###tramp-autoload -(defcustom tramp-adb-prompt - "^[[:digit:]]*|?[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*[#\\$][[:space:]]" +(defcustom tramp-adb-prompt "^[^#$\n\r]*[#$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'regexp - :version "24.4" + :version "28.1" :group 'tramp) +(eval-and-compile + (defconst tramp-adb-ls-date-year-regexp + "[[:digit:]]\\{4\\}-[[:digit:]]\\{2\\}-[[:digit:]]\\{2\\}" + "Regexp for date year format in ls output.")) + +(eval-and-compile + (defconst tramp-adb-ls-date-time-regexp + "[[:digit:]]\\{2\\}:[[:digit:]]\\{2\\}" + "Regexp for date time format in ls output.")) + (defconst tramp-adb-ls-date-regexp - "[[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]][0-9][0-9]:[0-9][0-9][[:space:]]" + (concat + "[[:space:]]" tramp-adb-ls-date-year-regexp + "[[:space:]]" tramp-adb-ls-date-time-regexp + "[[:space:]]") "Regexp for date format in ls output.") (defconst tramp-adb-ls-toolbox-regexp @@ -75,7 +87,8 @@ It is used for TCP/IP devices." "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group "[[:space:]]+\\([[:digit:]]+\\)" ; \4 size - "[[:space:]]+\\([-[:digit:]]+[[:space:]][:[:digit:]]+\\)" ; \5 date + "[[:space:]]+\\(" tramp-adb-ls-date-year-regexp + "[[:space:]]" tramp-adb-ls-date-time-regexp "\\)" ; \5 date "[[:space:]]\\(.*\\)$") ; \6 filename "Regexp for ls output.") @@ -83,8 +96,10 @@ It is used for TCP/IP devices." (tramp--with-startup (add-to-list 'tramp-methods `(,tramp-adb-method - (tramp-tmpdir "/data/local/tmp") - (tramp-default-port 5555))) + (tramp-login-program ,tramp-adb-program) + (tramp-login-args (("shell"))) + (tramp-tmpdir "/data/local/tmp") + (tramp-default-port 5555))) (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) @@ -138,7 +153,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. @@ -162,6 +177,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) @@ -183,10 +200,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 @@ -216,11 +232,10 @@ ARGUMENTS to pass to the OPERATION." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*[^[:space:]]+" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "[[:space:]]*[^[:space:]]+" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) ;; The values are given as 1k numbers, so we must change ;; them to number of bytes. (list (* 1024 (string-to-number (match-string 1))) @@ -230,105 +245,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)) @@ -372,7 +288,9 @@ ARGUMENTS to pass to the OPERATION." (if (eq id-format 'integer) 0 uid) (if (eq id-format 'integer) 0 gid) tramp-time-dont-know ; atime - (date-to-time date) ; mtime + ;; `date-to-time' checks `iso8601-parse', which might fail. + (let (signal-hook-function) + (date-to-time date)) ; mtime tramp-time-dont-know ; ctime size mod-string @@ -451,21 +369,6 @@ ARGUMENTS to pass to the OPERATION." "ls --color=never") (t "ls")))) -(defun tramp-adb--gnu-switches-to-ash (switches) - "Almquist shell can't handle multiple arguments. -Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." - (split-string - (apply #'concat - (mapcar (lambda (s) - (replace-regexp-in-string - "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) - ;; FIXME: Warning about removed switches (long and non-dash). - (delq nil - (mapcar - (lambda (s) - (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s)) - switches)))))) - (defun tramp-adb-sh-fix-ls-output (&optional sort-by-time) "Insert dummy 0 in empty size columns. Android's \"ls\" command doesn't insert size column for directories: @@ -475,10 +378,16 @@ Emacs dired can't find files." (goto-char (point-min)) (while (search-forward-regexp - "[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t) + (eval-when-compile + (concat + "[[:space:]]" + "\\([[:space:]]" tramp-adb-ls-date-year-regexp "[[:space:]]\\)")) + nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". - (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$") + (when (looking-at-p + (eval-when-compile + (concat tramp-adb-ls-date-time-regexp "[[:space:]]+$"))) (end-of-line) (insert "/"))) ;; Sort entries. @@ -589,9 +498,10 @@ Emacs dired can't find files." (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) ;; "adb pull ..." does not always return an error code. - (when (or (tramp-adb-execute-adb-command - v "pull" (tramp-compat-file-name-unquote localname) tmpfile) - (not (file-exists-p tmpfile))) + (unless + (and (tramp-adb-execute-adb-command + v "pull" (tramp-compat-file-name-unquote localname) tmpfile) + (file-exists-p tmpfile)) (ignore-errors (delete-file tmpfile)) (tramp-error v 'file-error "Cannot make local copy of file `%s'" filename)) @@ -644,8 +554,8 @@ But handle the case, if the \"test\" command is not available." v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect - (when (tramp-adb-execute-adb-command - v "push" tmpfile (tramp-compat-file-name-unquote localname)) + (unless (tramp-adb-execute-adb-command + v "push" tmpfile (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) @@ -670,13 +580,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 &optional _flag) +(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 (tramp-shell-quote-argument localname)))))) -(defun tramp-adb-handle-set-file-times (filename &optional time _flag) +(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) @@ -685,21 +598,23 @@ 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") - (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) - quoted-name - (format-time-string "%Y-%m-%dT%H:%M:%S" time t) - quoted-name - (format-time-string "%Y%m%d%H%M.%S" time t) - quoted-name))))) + 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) + nofollow quoted-name + (format-time-string "%Y-%m-%dT%H:%M:%S" time t) + nofollow quoted-name + (format-time-string "%Y%m%d%H%M.%S" time t) + nofollow quoted-name))))) (defun tramp-adb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -722,7 +637,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 @@ -742,46 +657,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 + (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) + (unless (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))))))))) + (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) @@ -804,7 +718,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 @@ -973,164 +887,168 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; 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 - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((name (plist-get args :name)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (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 %s" - (tramp-shell-quote-argument localname) - (if tmpstderr (format "2>'%s'" tmpstderr) "") - (mapconcat #'tramp-shell-quote-argument - (cons program args) " "))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0)) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' - ;; could be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t)) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (delete-region (point-min) (point-max)) - ;; Send the command. - (let* ((p (tramp-get-connection-process v))) - (tramp-adb-send-command v command nil t) ; nooutput - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (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 - (progn - (goto-char (point-min)) - (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)))) - - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + "Like `make-process' for Tramp files. +If connection property \"direct-async-process\" is non-nil, an +alternative implementation will be used." + (if (tramp-direct-async-process-p args) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (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 %s" + (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', + ;; in order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (let* ((p (tramp-get-connection-process v))) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for + ;; this process. We ignore errors, because + ;; the process could have finished already. + (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 + (progn + (goto-char (point-min)) + (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)))) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) (defun tramp-adb-handle-exec-path () "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) @@ -1145,11 +1063,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" a host name \"R38273882DE\" returns \"R38273882DE\"." - ;; Sometimes this is called before there is a connection process - ;; yet. In order to work with the connection cache, we flush all - ;; unwanted entries first. - (tramp-flush-connection-properties nil) - (with-tramp-connection-property (tramp-get-connection-process vec) "device" + (with-tramp-connection-property (tramp-get-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) @@ -1167,10 +1081,10 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" ;; Try to connect device. ((and tramp-adb-connect-if-not-connected (not (zerop (length host))) - (not (tramp-adb-execute-adb-command - vec "connect" - (replace-regexp-in-string - tramp-prefix-port-format ":" host)))) + (tramp-adb-execute-adb-command + vec "connect" + (replace-regexp-in-string + tramp-prefix-port-format ":" host))) ;; When new device connected, running other adb command (e.g. ;; adb shell) immediately will fail. To get around this ;; problem, add sleep 0.1 second here. @@ -1180,18 +1094,18 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" vec 'file-error "Could not find device %s" host))))))) (defun tramp-adb-execute-adb-command (vec &rest args) - "Return nil on success error-output on failure." + "Execute an adb command. +Insert the result into the connection buffer. Return nil on +error and non-nil on success." (when (and (> (length (tramp-file-name-host vec)) 0) ;; The -s switch is only available for ADB device commands. (not (member (car args) '("connect" "disconnect")))) (setq args (append (list "-s" (tramp-adb-get-device vec)) args))) - (with-temp-buffer - (prog1 - (unless - (zerop - (apply #'tramp-call-process vec tramp-adb-program nil t nil args)) - (buffer-string)) - (tramp-message vec 6 "%s" (buffer-string))))) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Clean up the buffer. We cannot call `erase-buffer' because + ;; narrowing might be in effect. + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) + (zerop (apply #'tramp-call-process vec tramp-adb-program nil t nil args)))) (defun tramp-adb-find-test-command (vec) "Check whether the ash has a builtin \"test\" command. @@ -1203,25 +1117,30 @@ This happens for Android >= 4.0." (defun tramp-adb-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC." - (unless neveropen (tramp-adb-maybe-open-connection vec)) - (tramp-message vec 6 "%s" command) - (tramp-send-string vec command) - (unless nooutput - ;; FIXME: Race condition. - (tramp-adb-wait-for-output (tramp-get-connection-process vec)) - (with-current-buffer (tramp-get-connection-buffer vec) - (save-excursion - (goto-char (point-min)) - ;; We can't use stty to disable echo of command. stty is said - ;; to be added to toybox 0.7.6. busybox shall have it, but this - ;; isn't used any longer for Android. - (delete-matching-lines (regexp-quote command)) - ;; When the local machine is W32, there are still trailing ^M. - ;; There must be a better solution by setting the correct coding - ;; system, but this requires changes in core Tramp. - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" nil nil)))))) + (if (string-match-p "[[:multibyte:]]" command) + ;; Multibyte codepoints with four bytes are not supported at + ;; least by toybox. + (tramp-adb-execute-adb-command vec "shell" command) + + (unless neveropen (tramp-adb-maybe-open-connection vec)) + (tramp-message vec 6 "%s" command) + (tramp-send-string vec command) + (unless nooutput + ;; FIXME: Race condition. + (tramp-adb-wait-for-output (tramp-get-connection-process vec)) + (with-current-buffer (tramp-get-connection-buffer vec) + (save-excursion + (goto-char (point-min)) + ;; We can't use stty to disable echo of command. stty is said + ;; to be added to toybox 0.7.6. busybox shall have it, but this + ;; isn't used any longer for Android. + (delete-matching-lines (regexp-quote command)) + ;; When the local machine is W32, there are still trailing ^M. + ;; There must be a better solution by setting the correct coding + ;; system, but this requires changes in core Tramp. + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" nil nil))))))) (defun tramp-adb-send-command-and-check (vec command &optional exit-status) "Run COMMAND and check its exit status. @@ -1236,7 +1155,7 @@ the exit status." (format "%s; echo tramp_exit_status $?" command) "echo tramp_exit_status $?")) (with-current-buffer (tramp-get-connection-buffer vec) - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") @@ -1340,12 +1259,24 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) + ;; Disable line editing. + (tramp-adb-send-command + vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs") + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-adb-send-command vec "set -o")) + ;; Check whether the properties have been changed. If ;; yes, this is a strong indication that we must expire all ;; connection properties. We start again. (tramp-message vec 5 "Checking system information") (tramp-adb-send-command - vec "echo \\\"`getprop ro.product.model` `getprop ro.product.version` `getprop ro.build.version.release`\\\"") + vec + (concat + "echo \\\"`getprop ro.product.model` " + "`getprop ro.product.version` " + "`getprop ro.build.version.release`\\\"")) (let ((old-getprop (tramp-get-connection-property vec "getprop" nil)) (new-getprop @@ -1369,7 +1300,8 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "su %s" user)) (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) - (tramp-flush-file-property vec "" "su-command-p") + ;; Do not flush, we need the nil value. + (tramp-set-file-property vec "" "su-command-p" nil) (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) @@ -1403,4 +1335,9 @@ connection if a previous connection has died for some reason." (provide 'tramp-adb) +;;; TODO: +;; +;; * Support file names with multibyte codepoints. Use as fallback +;; "adb shell COMMAND". +;; ;;; tramp-adb.el ends here diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 611247ef2cb..9502cc35300 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -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) @@ -353,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 @@ -369,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'. @@ -520,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 0f2d7a1800f..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. diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index b4dca2321c1..827d5f60a2b 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. @@ -350,9 +359,8 @@ The remote connection identified by SOURCE is flushed by (or (setq target (tramp-default-rename-file source)) (tramp-user-error nil - (eval-when-compile - (concat "There is no target specified. " - "Check `tramp-default-rename-alist' for a proper entry."))))) + (concat "There is no target specified. " + "Check `tramp-default-rename-alist' for a proper entry.")))) (when (tramp-equal-remote source target) (tramp-user-error nil "Source and target must have different remote.")) @@ -474,9 +482,7 @@ For details, see `tramp-rename-files'." (defun tramp-bug () "Submit a bug report to the Tramp developers." (interactive) - (let ((reporter-prompt-for-summary-p t) - ;; In rare cases, it could contain the password. So we make it nil. - tramp-password-save-function) + (let ((reporter-prompt-for-summary-p t)) (reporter-submit-bug-report tramp-bug-report-address ; to-address (format "tramp (%s %s/%s)" ; package name and version @@ -484,10 +490,11 @@ For details, see `tramp-rename-files'." (sort (delq nil (mapcar (lambda (x) - (and x (boundp x) (cons x 'tramp-reporter-dump-variable))) + (and x (boundp x) (not (get x 'tramp-suppress-trace)) + (cons x 'tramp-reporter-dump-variable))) (append (mapcar #'intern (all-completions "tramp-" obarray #'boundp)) - ;; Non-tramp variables of interest. + ;; Non-Tramp variables of interest. '(shell-prompt-pattern backup-by-copying backup-by-copying-when-linked @@ -544,11 +551,11 @@ buffer in your bug report. (string-match-p (concat "[^" (bound-and-true-p mm-7bit-chars) "]") val)) (with-current-buffer reporter-eval-buffer - (set - varsym - (format - "(decode-coding-string (base64-decode-string \"%s\") 'raw-text)" - (base64-encode-string (encode-coding-string val 'raw-text))))))) + (set varsym + `(decode-coding-string + (base64-decode-string + ,(base64-encode-string (encode-coding-string val 'raw-text))) + 'raw-text))))) ;; Dump variable. (reporter-dump-variable varsym mailbuf) @@ -557,11 +564,10 @@ buffer in your bug report. ;; Remove string quotation. (forward-line -1) (when (looking-at - (eval-when-compile - (concat "\\(^.*\\)" "\"" ;; \1 " - "\\((base64-decode-string \\)" "\\\\" ;; \2 \ - "\\(\".*\\)" "\\\\" ;; \3 \ - "\\(\")\\)" "\"$"))) ;; \4 " + (concat "\\(^.*\\)" "\"" ;; \1 " + "\\((base64-decode-string \\)" "\\\\" ;; \2 \ + "\\(\".*\\)" "\\\\" ;; \3 \ + "\\(\")\\)" "\"$")) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) (insert " ;; Variable encoded due to non-printable characters.\n")) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 3f25afedb99..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) @@ -43,6 +43,7 @@ ;; `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 @@ -52,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'." @@ -59,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 @@ -75,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) @@ -181,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 @@ -215,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) @@ -257,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'." @@ -266,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. @@ -285,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 @@ -323,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-ftp.el b/lisp/net/tramp-ftp.el index 95ae1569dc9..996a92454f1 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -31,8 +31,7 @@ (require 'tramp) ;; Pacify byte-compiler. -(eval-when-compile - (require 'custom)) +(eval-when-compile (require 'custom)) (defvar ange-ftp-ftp-name-arg) (defvar ange-ftp-ftp-name-res) (defvar ange-ftp-name-format) @@ -79,9 +78,9 @@ present for backward compatibility." ;;; This regexp recognizes absolute filenames with only one component ;;; on Windows, for the sake of hostname completion. (and (memq system-type '(ms-dos windows-nt)) - (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist) + (or (assoc "^[[:alpha:]]:/[^/:]*\\'" file-name-handler-alist) (setq file-name-handler-alist - (cons '("^[a-zA-Z]:/[^/:]*\\'" . + (cons '("^[:alpha:]]:/[^/:]*\\'" . ange-ftp-completion-hook-function) file-name-handler-alist))))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index ddb535fea6e..6467d8f88b4 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 @@ -104,8 +108,7 @@ (require 'url-util) ;; Pacify byte-compiler. -(eval-when-compile - (require 'custom)) +(eval-when-compile (require 'custom)) (declare-function zeroconf-init "zeroconf") (declare-function zeroconf-list-service-types "zeroconf") @@ -124,16 +127,16 @@ (or ;; Until Emacs 25, `process-attributes' could crash Emacs ;; for some processes. Better we don't check. (<= emacs-major-version 25) - (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) + (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") @@ -141,10 +144,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.") @@ -154,15 +159,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" @@ -172,13 +185,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.") @@ -460,8 +475,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. @@ -473,38 +689,41 @@ 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")) "List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".") ;; <http://www.pygtk.org/docs/pygobject/gio-constants.html> -(defconst tramp-gvfs-file-attributes - '("name" - "type" - "standard::display-name" - "standard::symlink-target" - "standard::is-volatile" - "unix::nlink" - "unix::uid" - "owner::user" - "unix::gid" - "owner::group" - "time::access" - "time::modified" - "time::changed" - "standard::size" - "unix::mode" - "access::can-read" - "access::can-write" - "access::can-execute" - "unix::inode" - "unix::device") - "GVFS file attributes.") - -(defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp - (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)") - "Regexp to parse GVFS file attributes with `gvfs-ls'.") +(eval-and-compile + (defconst tramp-gvfs-file-attributes + '("name" + "type" + "standard::display-name" + "standard::symlink-target" + "standard::is-volatile" + "unix::nlink" + "unix::uid" + "owner::user" + "unix::gid" + "owner::group" + "time::access" + "time::modified" + "time::changed" + "standard::size" + "unix::mode" + "access::can-read" + "access::can-write" + "access::can-execute" + "unix::inode" + "unix::device") + "GVFS file attributes.")) + +(eval-and-compile + (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp + (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)") + "Regexp to parse GVFS file attributes with `gvfs-ls'.")) (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp (concat "^[[:blank:]]*" @@ -603,6 +822,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) @@ -628,10 +849,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) @@ -645,20 +865,19 @@ pass to the OPERATION." (defun tramp-gvfs-dbus-string-to-byte-array (string) "Like `dbus-string-to-byte-array' but add trailing \\0 if needed." (dbus-string-to-byte-array - (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature) + (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature) (concat string (string 0)) string))) (defun tramp-gvfs-dbus-byte-array-to-string (byte-array) "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." @@ -683,6 +902,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. @@ -692,14 +913,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 @@ -707,6 +929,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 @@ -715,8 +938,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 @@ -731,10 +952,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))) +(add-hook 'tramp-gvfs-unload-hook + (lambda () + (remove-hook 'dbus-event-error-functions + #'tramp-gvfs-dbus-event-error))) ;; File name primitives. @@ -765,11 +986,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) @@ -779,7 +1004,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 @@ -840,8 +1065,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)) @@ -957,10 +1182,11 @@ file names." (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (while (looking-at - (concat "^\\(.+\\)[[:blank:]]" - "\\([[:digit:]]+\\)[[:blank:]]" - "(\\(.+?\\))" - tramp-gvfs-file-attributes-with-gvfs-ls-regexp)) + (eval-when-compile + (concat "^\\(.+\\)[[:blank:]]" + "\\([[:digit:]]+\\)[[:blank:]]" + "(\\(.+?\\))" + tramp-gvfs-file-attributes-with-gvfs-ls-regexp))) (let ((item (list (cons "type" (match-string 3)) (cons "standard::size" (match-string 2)) (cons "name" (match-string 1))))) @@ -1061,8 +1287,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::uid" attributes)) - (eval-when-compile - (format "%s" tramp-unknown-id-integer)))) + (eval-when-compile (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::user" attributes)) (cdr (assoc "unix::uid" attributes)) tramp-unknown-id-string))) @@ -1070,8 +1295,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::gid" attributes)) - (eval-when-compile - (format "%s" tramp-unknown-id-integer)))) + (eval-when-compile (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::group" attributes)) (cdr (assoc "unix::gid" attributes)) tramp-unknown-id-string))) @@ -1251,11 +1475,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; File names are returned as URL paths. We must convert them. (when (string-match ddu file) (setq file (replace-match dd nil nil file))) - (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file) + (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" file) (setq file (url-unhex-string file))) (when (string-match ddu (or file1 "")) (setq file1 (replace-match dd nil nil file1))) - (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 "")) + (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" (or file1 "")) (setq file1 (url-unhex-string file1))) ;; Remove watch when file or directory to be watched is deleted. (when (and (member action '(moved deleted)) @@ -1288,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 @@ -1338,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)) @@ -1349,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 &optional _flag) +(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 _flag) +(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) @@ -1432,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. @@ -1498,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. @@ -1572,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 @@ -1662,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)) @@ -1691,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. @@ -1704,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))) @@ -1759,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." @@ -1802,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. @@ -1851,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)))) @@ -1934,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." @@ -1976,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) @@ -1989,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 @@ -2020,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))) @@ -2044,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. @@ -2088,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 () @@ -2133,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 fcbd2010a26..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) @@ -484,7 +485,8 @@ file names." ;; crash Emacs for some processes. So we use ;; "pidof", which might not work everywhere. (if (<= emacs-major-version 25) - (let ((default-directory temporary-file-directory)) + (let ((default-directory + (tramp-compat-temporary-file-directory))) (mapcar #'string-to-number (split-string diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 9e8a3168fd7..7a3f3fe8f02 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -91,10 +91,10 @@ the default storage location, e.g. \"$HOME/.sh_history\"." (string :tag "Redirect to a file"))) ;;;###tramp-autoload -(defconst tramp-display-escape-sequence-regexp "\e[[;0-9]+m" +(defconst tramp-display-escape-sequence-regexp "\e[[:digit:];[]+m" "Terminal control escape sequences for display attributes.") -(defconst tramp-device-escape-sequence-regexp "\e[[0-9]+n" +(defconst tramp-device-escape-sequence-regexp "\e[[:digit:][]+n" "Terminal control escape sequences for device status.") ;; ksh on OpenBSD 4.5 requires that $PS1 contains a `#' character for @@ -482,6 +482,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" @@ -492,8 +493,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 @@ -1039,6 +1040,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) @@ -1116,8 +1119,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) @@ -1154,59 +1156,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) @@ -1378,13 +1330,12 @@ component is used as the target of the symlink." (tramp-send-command-and-read vec (format - (eval-when-compile - (concat - ;; 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 -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')")) + (concat + ;; 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 -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) @@ -1474,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 &optional _flag) +(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 _flag) +(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) @@ -1497,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 @@ -1527,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) @@ -1535,9 +1514,8 @@ of." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (eval-when-compile - (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):" + "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)"))) (when (and (tramp-remote-selinux-p v) (tramp-send-command-and-check v (format @@ -1576,7 +1554,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) @@ -1706,8 +1684,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) @@ -1785,21 +1765,19 @@ of." (tramp-send-command-and-read vec (format - (eval-when-compile - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a - ;; solution, but it does not work on all remote systems. - ;; Therefore, we use \000 as file separator. - ;; `tramp-sh--quoting-style-options' do not work for file names - ;; with spaces piped to "xargs". - ;; Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape - ;; of them in file names. - "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " - "xargs -0 %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, + ;; but it does not work on all remote systems. Therefore, we use + ;; \000 as file separator. `tramp-sh--quoting-style-options' do + ;; not work for file names with spaces piped to "xargs". + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " + "xargs -0 %s -c " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) ;; On systems which have no quoting style, file names with special @@ -1840,13 +1818,12 @@ of." (format "tramp_perl_file_name_all_completions %s" (tramp-shell-quote-argument localname))) - (format (eval-when-compile - (concat - "(cd %s 2>&1 && %s -a 2>/dev/null" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail")) + (format (concat + "(cd %s 2>&1 && %s -a 2>/dev/null" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail") (tramp-shell-quote-argument localname) (tramp-get-ls-command v) (tramp-get-test-command v)))) @@ -1954,7 +1931,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))) @@ -1967,7 +1944,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 @@ -1984,8 +1961,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)) @@ -2036,7 +2013,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 @@ -2063,7 +2040,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 @@ -2076,7 +2053,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) @@ -2091,11 +2068,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. @@ -2117,7 +2094,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. @@ -2145,10 +2123,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. @@ -2302,10 +2281,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)) @@ -2328,9 +2309,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 @@ -2504,10 +2485,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) @@ -2720,7 +2702,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) @@ -2730,12 +2712,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))))))) @@ -2806,223 +2787,232 @@ the result will be a local, non-Tramp, file name." ;; terminated. (defun tramp-sh-handle-make-process (&rest args) "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)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (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)) - ;; When PROGRAM matches "*sh", and the first arg is - ;; "-c", it might be that the arguments exceed the - ;; command line length. Therefore, we modify the - ;; command. - (heredoc (and (stringp program) - (string-match-p "sh$" program) - (string-equal "-c" (car args)) - (= (length args) 2))) - ;; When PROGRAM is nil, we just provide a tty. - (args (if (not heredoc) args - (let ((i 250)) - (while (and (< i (length (cadr args))) - (string-match " " (cadr args) i)) - (setcdr - args - (list - (replace-match " \\\\\n" nil nil (cadr args)))) - (setq i (+ i 250)))) - (cdr args))) - ;; Use a human-friendly prompt, for example for - ;; `shell'. We discard hops, if existing, that's why - ;; we cannot use `file-remote-p'. - (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name v nil 'nohop) - tramp-initial-end-of-output)) - ;; We use as environment the difference to toplevel - ;; `process-environment'. - env uenv - (env (dolist (elt (cons prompt process-environment) env) - (or (member - elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) - (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv))))))) - (command - (when (stringp program) - (format "cd %s && %s exec %s %s env %s %s" - (tramp-shell-quote-argument localname) - (if uenv - (format - "unset %s &&" - (mapconcat - #'tramp-shell-quote-argument uenv " ")) - "") - (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") - (if tmpstderr (format "2>'%s'" tmpstderr) "") - (mapconcat #'tramp-shell-quote-argument env " ") - (if heredoc - (format "%s\n(\n%s\n) </dev/tty\n%s" - program (car args) tramp-end-of-heredoc) - (mapconcat #'tramp-shell-quote-argument - (cons program args) " "))))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0) - ;; We do not want to raise an error when `make-process' - ;; has been started several times in `eshell' and - ;; friends. - tramp-current-connection - p) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (mark (point-max))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (catch 'suppress - (tramp-maybe-open-connection v) - (setq p (tramp-get-connection-process v)) - ;; Set the pid of the remote shell. This is - ;; needed when sending signals remotely. - (let ((pid (tramp-send-command-and-read v "echo $$"))) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) - ;; `tramp-maybe-open-connection' and - ;; `tramp-send-command-and-read' could have - ;; trashed the connection buffer. Remove this. - (widen) - (delete-region mark (point-max)) +STDERR can also be a file name. If connection property +\"direct-async-process\" is non-nil, an alternative +implementation will be used." + (if (tramp-direct-async-process-p args) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (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)) + ;; When PROGRAM matches "*sh", and the first arg is + ;; "-c", it might be that the arguments exceed the + ;; command line length. Therefore, we modify the + ;; command. + (heredoc (and (stringp program) + (string-match-p "sh$" program) + (string-equal "-c" (car args)) + (= (length args) 2))) + ;; When PROGRAM is nil, we just provide a tty. + (args (if (not heredoc) args + (let ((i 250)) + (while (and (< i (length (cadr args))) + (string-match " " (cadr args) i)) + (setcdr + args + (list + (replace-match " \\\\\n" nil nil (cadr args)))) + (setq i (+ i 250)))) + (cdr args))) + ;; Use a human-friendly prompt, for example for + ;; `shell'. We discard hops, if existing, that's why + ;; we cannot use `file-remote-p'. + (prompt (format "PS1=%s %s" + (tramp-make-tramp-file-name v nil 'nohop) + tramp-initial-end-of-output)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + env uenv + (env (dolist (elt (cons prompt process-environment) env) + (or (member + elt (default-toplevel-value 'process-environment)) + (if (string-match-p "=" elt) + (setq env (append env `(,elt))) + (if (tramp-get-env-with-u-option v) + (setq env (append `("-u" ,elt) env)) + (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 + (format + "unset %s &&" + (mapconcat + #'tramp-shell-quote-argument uenv " ")) + "") + (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument env " ") + (if heredoc + (format "%s\n(\n%s\n) </dev/tty\n%s" + program (car args) tramp-end-of-heredoc) + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when + ;; `make-process' has been started several times in + ;; `eshell' and friends. + tramp-current-connection + p) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max))) + (clear-visited-file-modtime) (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" - name)))) - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (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 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)) - ;; 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))) + ;; We call `tramp-maybe-open-connection', in + ;; order to cleanup the prompt afterwards. + (catch 'suppress + (tramp-maybe-open-connection v) + (setq p (tramp-get-connection-process v)) + ;; Set the pid of the remote shell. This is + ;; needed when sending signals remotely. + (let ((pid (tramp-send-command-and-read v "echo $$"))) + (process-put p 'remote-pid pid) + (tramp-set-connection-property p "remote-pid" pid)) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could have + ;; trashed the connection buffer. Remove this. + (widen) + (delete-region mark (point-max)) + (narrow-to-region (point-max) (point-max)) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (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 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)) + ;; 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))) - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) (defun tramp-sh-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." @@ -3103,6 +3093,11 @@ STDERR can also be a 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 @@ -3331,7 +3326,8 @@ STDERR can also be a 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 @@ -3450,9 +3446,8 @@ STDERR can also be a file name." loc-enc tmpfile t)) (tramp-error v 'file-error - (eval-when-compile - (concat "Cannot write to `%s', " - "local encoding command `%s' failed")) + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") filename loc-enc)))) ;; Send buffer into remote decoding command which @@ -3497,9 +3492,8 @@ STDERR can also be a file name." (buffer-string)))) (tramp-error v 'file-error - (eval-when-compile - (concat "Couldn't write region to `%s'," - " decode using `%s' failed")) + (concat "Couldn't write region to `%s'," + " decode using `%s' failed") filename rem-dec))))) ;; Save exit. @@ -3509,9 +3503,8 @@ STDERR can also be a file name." (t (tramp-error v 'file-error - (eval-when-compile - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program")) + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program") method)))) ;; Make `last-coding-system-used' have the right value. @@ -3564,8 +3557,7 @@ STDERR can also be a 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 @@ -3624,27 +3616,30 @@ STDERR can also be a 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 @@ -3655,10 +3650,17 @@ STDERR can also be a 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))) + +;;;###tramp-autoload +(defun tramp-sh-file-name-handler-p (vec) + "Whether VEC uses a method from `tramp-sh-file-name-handler'." + (and (assoc (tramp-file-name-method vec) tramp-methods) + (eq (tramp-find-foreign-file-name-handler + (tramp-make-tramp-file-name vec nil 'nohop)) + 'tramp-sh-file-name-handler))) ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload @@ -3710,13 +3712,11 @@ Fall back to normal file name handler if no Tramp handler exists." events (cond ((and (memq 'change flags) (memq 'attribute-change flags)) - (eval-when-compile - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,attrib,ignored"))) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,attrib,ignored")) ((memq 'change flags) - (eval-when-compile - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,ignored"))) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,ignored")) ((memq 'attribute-change flags) "attrib,ignored")) sequence `(,command "-mq" "-e" ,events ,localname) ;; Make events a list of symbols. @@ -3858,12 +3858,11 @@ Fall back to normal file name handler if no Tramp handler exists." "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) (while (string-match - (eval-when-compile - (concat "^[\n\r]*" - "Directory Monitor Event:[\n\r]+" - "Child = \\([^\n\r]+\\)[\n\r]+" - "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" - "Event = \\([^[:blank:]]+\\)[\n\r]+")) + (concat "^[\n\r]*" + "Directory Monitor Event:[\n\r]+" + "Child = \\([^\n\r]+\\)[\n\r]+" + "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" + "Event = \\([^[:blank:]]+\\)[\n\r]+") string) (let* ((file (match-string 1 string)) (file1 (match-string 3 string)) @@ -3899,10 +3898,9 @@ Fall back to normal file name handler if no Tramp handler exists." (dolist (line (split-string string "[\n\r]+" 'omit)) ;; Check, whether there is a problem. (unless (string-match - (eval-when-compile - (concat "^[^[:blank:]]+" - "[[:blank:]]+\\([^[:blank:]]+\\)" - "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")) + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") line) (tramp-error proc 'file-notify-error "%s" line)) @@ -3938,11 +3936,10 @@ Fall back to normal file name handler if no Tramp handler exists." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" - "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" + "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) (mapcar (lambda (d) (* d (tramp-get-connection-property v "df-blocksize" 0))) @@ -4011,13 +4008,16 @@ hosts, or files, disagree." (tramp-shell-quote-argument v1-localname) (tramp-shell-quote-argument v2-localname)))))) +(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + "Regexp to determine remote SunOS.") + (defun tramp-find-executable (vec progname dirlist &optional ignore-tilde ignore-path) "Search for PROGNAME in $PATH and all directories mentioned in DIRLIST. 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. @@ -4032,7 +4032,7 @@ This function expects to be in the right *tramp* buffer." ;; therefore. (unless (or ignore-path (string-match-p - (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) + tramp-sunos-unames (tramp-get-connection-property vec "uname" ""))) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) @@ -4043,19 +4043,18 @@ 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)))) (tramp-send-command vec - (format (eval-when-compile - (concat "while read d; " - "do if test -x $d/%s && test -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'%s'\n" - "%s\n%s")) + (format (concat "while read d; " + "do if test -x $d/%s && test -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'%s'\n" + "%s\n%s") progname progname progname tramp-end-of-heredoc (string-join dirlist "\n") @@ -4096,7 +4095,7 @@ variable PATH." chunk (substring command 0 chunksize) command (substring command chunksize)) (tramp-send-command vec (format - "echo -n %s >>%s" + "printf \"%%b\" \"$*\" %s >>%s" (tramp-shell-quote-argument chunk) (tramp-shell-quote-argument tmpfile)))) (tramp-send-command vec (format ". %s" tmpfile)) @@ -4193,12 +4192,11 @@ file exists and nonzero exit status otherwise." ;; our initial probes to ensure the remote shell is usable.) (tramp-send-command vec (format - (eval-when-compile - (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " - "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")) + (concat + "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" @@ -4226,45 +4224,45 @@ 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 - (eval-when-compile + ;; 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 + tramp-sunos-unames + (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 (concat "Couldn't find a remote shell which groks tilde " - "expansion, using `%s'")) - default-shell))) + "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. @@ -4326,11 +4324,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 @@ -4550,8 +4552,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)) @@ -4573,9 +4575,9 @@ 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 @@ -4645,11 +4647,7 @@ Goes through the list `tramp-local-coding-commands' and ?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 @@ -4672,9 +4670,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 @@ -4787,99 +4785,6 @@ Goes through the list `tramp-inline-compress-commands'." (tramp-message vec 2 "Couldn't find an inline transfer compress command"))))) -(defun tramp-compute-multi-hops (vec) - "Expands VEC according to `tramp-default-proxies-alist'." - (let ((saved-tdpa tramp-default-proxies-alist) - (target-alist `(,vec)) - (hops (or (tramp-file-name-hop vec) "")) - (item vec) - choices proxy) - - ;; Ad-hoc proxy definitions. - (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) - (let* ((host-port (tramp-file-name-host-port item)) - (user-domain (tramp-file-name-user-domain item)) - (proxy (concat - tramp-prefix-format proxy tramp-postfix-host-format)) - (entry - (list (and (stringp host-port) - (concat "^" (regexp-quote host-port) "$")) - (and (stringp user-domain) - (concat "^" (regexp-quote user-domain) "$")) - (propertize proxy 'tramp-ad-hoc t)))) - (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) - ;; Add the hop. - (add-to-list 'tramp-default-proxies-alist entry) - (setq item (tramp-dissect-file-name proxy)))) - ;; Save the new value. - (when (and hops tramp-save-ad-hoc-proxies) - (customize-save-variable - 'tramp-default-proxies-alist tramp-default-proxies-alist)) - - ;; Look for proxy hosts to be passed. - (setq choices tramp-default-proxies-alist) - (while choices - (setq item (pop choices) - proxy (eval (nth 2 item))) - (when (and - ;; Host. - (string-match-p - (or (eval (nth 0 item)) "") - (or (tramp-file-name-host-port (car target-alist)) "")) - ;; User. - (string-match-p - (or (eval (nth 1 item)) "") - (or (tramp-file-name-user-domain (car target-alist)) ""))) - (if (null proxy) - ;; No more hops needed. - (setq choices nil) - ;; Replace placeholders. - (setq proxy - (format-spec - proxy - (format-spec-make - ?u (or (tramp-file-name-user (car target-alist)) "") - ?h (or (tramp-file-name-host (car target-alist)) "")))) - (with-parsed-tramp-file-name proxy l - ;; Add the hop. - (push l target-alist) - ;; Start next search. - (setq choices tramp-default-proxies-alist))))) - - ;; Foreign and out-of-band methods are not supported for multi-hops. - (when (cdr target-alist) - (setq choices target-alist) - (while (setq item (pop choices)) - (when (or (not (tramp-get-method-parameter item 'tramp-login-program)) - (tramp-get-method-parameter item 'tramp-copy-program)) - (setq tramp-default-proxies-alist saved-tdpa) - (tramp-user-error - vec "Method `%s' is not supported for multi-hops." - (tramp-file-name-method item))))) - - ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the - ;; host name in their command template. In this case, the remote - ;; file name must use either a local host name (first hop), or a - ;; host name matching the previous hop. - (let ((previous-host (or tramp-local-host-regexp ""))) - (setq choices target-alist) - (while (setq item (pop choices)) - (let ((host (tramp-file-name-host item))) - (unless - (or - ;; The host name is used for the remote shell command. - (member - '("%h") (tramp-get-method-parameter item 'tramp-login-args)) - ;; The host name must match previous hop. - (string-match-p previous-host host)) - (setq tramp-default-proxies-alist saved-tdpa) - (tramp-user-error - vec "Host name `%s' does not match `%s'" host previous-host)) - (setq previous-host (concat "^" (regexp-quote host) "$"))))) - - ;; Result. - target-alist)) - (defun tramp-ssh-controlmaster-options (vec) "Return the Control* arguments of the local ssh." (cond @@ -4938,7 +4843,7 @@ If there is just some editing, retry it after 5 seconds." (run-at-time 5 nil 'tramp-timeout-session vec)) (tramp-message vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) - (tramp-cleanup-connection vec 'keep-debug))) + (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes))) (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -4959,11 +4864,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 @@ -4974,11 +4876,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) @@ -5092,11 +4992,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. @@ -5276,7 +5173,7 @@ the exit status." "echo tramp_exit_status $?" (if subshell " )" ""))) (with-current-buffer (tramp-get-connection-buffer vec) - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") @@ -5472,7 +5369,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)) @@ -5680,8 +5577,7 @@ Nonexistent directories are removed from spec." ;; stat on Solaris is buggy. We've got reports for "SunOS 5.10" ;; and "SunOS 5.11" so far. (unless (string-match-p - (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) - (tramp-get-connection-property vec "uname" "")) + tramp-sunos-unames (tramp-get-connection-property vec "uname" "")) (tramp-message vec 5 "Finding a suitable `stat' command") (let ((result (tramp-find-executable vec "stat" (tramp-get-remote-path vec))) @@ -5727,10 +5623,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 @@ -5845,27 +5738,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 @@ -5896,27 +5768,6 @@ 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" @@ -5958,6 +5809,19 @@ ID-FORMAT valid values are `string' and `integer'." 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." (with-tramp-connection-property vec "env-u-option" @@ -5975,10 +5839,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. @@ -5996,11 +5859,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) @@ -6078,9 +5939,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 902fcf4b6e3..1b6af2a2e33 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -90,7 +90,7 @@ For example, if the deprecated SMB1 protocol shall be used, add to this variable (\"client min protocol=NT1\") ." :group 'tramp :type '(repeat string) - :version "27.2") + :version "28.1") (defvar tramp-smb-version nil "Version string of the SMB client.") @@ -293,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) @@ -341,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)) @@ -432,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) @@ -469,10 +466,7 @@ 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)))) + (tmpdir (tramp-compat-make-temp-name)) (args (list (concat "//" host "/" share) "-E")) (options tramp-smb-options)) @@ -556,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 @@ -598,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." @@ -709,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))) @@ -880,23 +875,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (while (not (eobp)) (cond ((looking-at - "Size:\\s-+\\([0-9]+\\)\\s-+Blocks:\\s-+[0-9]+\\s-+\\(\\w+\\)") + (concat + "Size:\\s-+\\([[:digit:]]+\\)\\s-+" + "Blocks:\\s-+[[:digit:]]+\\s-+\\(\\w+\\)")) (setq size (string-to-number (match-string 1)) id (if (string-equal "directory" (match-string 2)) t (if (string-equal "symbolic" (match-string 2)) "")))) ((looking-at - "Inode:\\s-+\\([0-9]+\\)\\s-+Links:\\s-+\\([0-9]+\\)") + "Inode:\\s-+\\([[:digit:]]+\\)\\s-+Links:\\s-+\\([[:digit:]]+\\)") (setq inode (string-to-number (match-string 1)) link (string-to-number (match-string 2)))) ((looking-at - "Access:\\s-+([0-9]+/\\(\\S-+\\))\\s-+Uid:\\s-+\\([0-9]+\\)\\s-+Gid:\\s-+\\([0-9]+\\)") + (concat + "Access:\\s-+([[:digit:]]+/\\(\\S-+\\))\\s-+" + "Uid:\\s-+\\([[:digit:]]+\\)\\s-+" + "Gid:\\s-+\\([[:digit:]]+\\)")) (setq mode (match-string 1) uid (if (equal id-format 'string) (match-string 2) (string-to-number (match-string 2))) gid (if (equal id-format 'string) (match-string 3) (string-to-number (match-string 3))))) ((looking-at - "Access:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Access:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq atime (encode-time (string-to-number (match-string 6)) ;; sec @@ -906,7 +909,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - "Modify:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Modify:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq mtime (encode-time (string-to-number (match-string 6)) ;; sec @@ -916,7 +922,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - "Change:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Change:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq ctime (encode-time (string-to-number (match-string 6)) ;; sec @@ -992,10 +1001,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*\\([[:digit:]]+\\)" - " blocks of size \\([[:digit:]]+\\)" - "\\. \\([[:digit:]]+\\) blocks available"))) + (concat "[[:space:]]*\\([[:digit:]]+\\)" + " blocks of size \\([[:digit:]]+\\)" + "\\. \\([[:digit:]]+\\) blocks available")) (setq blocksize (string-to-number (match-string 2)) total (* blocksize (string-to-number (match-string 1))) avail (* blocksize (string-to-number (match-string 3))))) @@ -1025,7 +1033,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 @@ -1377,7 +1385,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 @@ -1479,7 +1487,7 @@ component is used as the target of the symlink." ;; This is meant for traces, and returning from the ;; function. No error is propagated outside, due to ;; the `ignore-errors' closure. - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error v 'file-error "Couldn't find exit status of `%s'" tramp-smb-acl-program)) @@ -1493,15 +1501,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 &optional _flag) +(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 @@ -1722,21 +1732,21 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." ;; Entries provided by smbclient DIR aren't fully regular. ;; They should have the format ;; -;; \s-\{2,2} - leading spaces +;; \s-\{2,2\} - leading spaces ;; \S-\(.*\S-\)\s-* - file name, 30 chars, left bound ;; \s-+[ADHRSV]* - permissions, 7 chars, right bound ;; \s- - space delimiter -;; \s-+[0-9]+ - size, 8 chars, right bound +;; \s-+[[:digit:]]+ - size, 8 chars, right bound ;; \s-\{2,2\} - space delimiter ;; \w\{3,3\} - weekday ;; \s- - space delimiter ;; \w\{3,3\} - month ;; \s- - space delimiter -;; [ 12][0-9] - day +;; [ 12][[:digit:]] - day ;; \s- - space delimiter -;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time +;; [[:digit:]]\{2,2\}:[[:digit:]]\{2,2\}:[[:digit:]]\{2,2\} - time ;; \s- - space delimiter -;; [0-9]\{4,4\} - year +;; [[:digit:]]\{4,4\} - year ;; ;; samba/src/client.c (http://samba.org/doxygen/samba/client_8c-source.html) ;; has function display_finfo: @@ -1784,13 +1794,14 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-block nil ;; year. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (setq year (string-to-number (match-string 1 line)) line (substring line 0 -5)) (cl-return)) ;; time. - (if (string-match "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)$" line) + (if (string-match + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)$" line) (setq hour (string-to-number (match-string 1 line)) min (string-to-number (match-string 2 line)) sec (string-to-number (match-string 3 line)) @@ -1798,7 +1809,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; day. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (setq day (string-to-number (match-string 1 line)) line (substring line 0 -3)) (cl-return)) @@ -1815,7 +1826,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; size. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (let ((length (- (max 10 (1+ (length (match-string 1 line))))))) (setq size (string-to-number (match-string 1 line))) (when (string-match @@ -1870,7 +1881,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) @@ -1887,8 +1898,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 \"/\"")))) @@ -1950,11 +1960,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) @@ -2025,7 +2033,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 diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 4af58618a6a..98727dc4a87 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)) @@ -282,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 @@ -303,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)) @@ -373,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) @@ -464,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 &optional _flag) +(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) @@ -484,9 +488,8 @@ the result will be a local, non-Tramp, file name." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (eval-when-compile - (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):" + "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)"))) (when (and (tramp-sudoedit-remote-selinux-p v) (tramp-sudoedit-send-command v "ls" "-d" "-Z" @@ -511,10 +514,9 @@ the result will be a local, non-Tramp, file name." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) (list (string-to-number (match-string 1)) ;; The second value is the used size. We need the ;; free size. @@ -522,7 +524,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 _flag) +(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) @@ -535,14 +537,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) @@ -642,8 +644,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)) @@ -687,21 +689,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." @@ -709,21 +709,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))) + (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) @@ -737,7 +738,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. @@ -782,14 +783,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 2e6fbe1c767..2ae28b8758f 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.5-pre -;; 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 @@ -64,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) @@ -79,6 +80,7 @@ (eval-and-compile ;; So it's also available in tramp-loaddefs.el! (defvar tramp--startup-hook nil "Forms to be executed at the end of tramp.el.") + (put 'tramp--startup-hook 'tramp-suppress-trace t) (defmacro tramp--with-startup (&rest body) "Schedule BODY to be executed at the end of tramp.el." @@ -247,6 +249,10 @@ pair of the form (KEY VALUE). The following KEYs are defined: parameters to suppress diagnostic messages, in order not to tamper the process output. + * `tramp-direct-async-args' + An additional argument when a direct asynchronous process is + started. Used so far only in the \"mock\" method of tramp-tests.el. + * `tramp-copy-program' This specifies the name of the program to use for remotely copying the file; this might be the absolute filename of scp or the name of @@ -559,7 +565,7 @@ Sometimes the prompt is reported to look like \"login as:\"." ;; Allow also [] style prompts. They can appear only during ;; connection initialization; Tramp redefines the prompt afterwards. (concat "\\(?:^\\|\r\\)" - "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") + "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[[:digit:];]*[[:alpha:]] *\\)*") "Regexp to match prompts from remote shell. Normally, Tramp expects you to configure `shell-prompt-pattern' correctly, but sometimes it happens that you are connecting to a @@ -578,6 +584,11 @@ This regexp must match both `tramp-initial-end-of-output' and "Regexp matching password-like prompts. The regexp should match at end of buffer. +This variable is, by default, initialised from +`password-word-equivalents' when tramp is loaded, and it is +usually more convenient to add new passphrases to that variable +instead of altering this variable. + The `sudo' program appears to insert a `^@' character into the prompt." :version "24.4" :type 'regexp) @@ -600,7 +611,7 @@ The `sudo' program appears to insert a `^@' character into the prompt." "\\|" "^.*\\(" ;; Here comes a list of regexes, separated by \\| - "Received signal [0-9]+" + "Received signal [[:digit:]]+" "\\).*") "Regexp matching a `login failed' message. The regexp should match at end of buffer." @@ -745,7 +756,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 @@ -796,9 +807,9 @@ Used in `tramp-make-tramp-file-name'.") Should always start with \"^\". Derived from `tramp-prefix-format'.") (defconst tramp-method-regexp-alist - '((default . "[a-zA-Z0-9-]+") + '((default . "[[:alnum:]-]+") (simplified . "") - (separate . "[a-zA-Z0-9-]*")) + (separate . "[[:alnum:]-]*")) "Alist mapping Tramp syntax to regexps matching methods identifiers.") (defun tramp-build-method-regexp () @@ -842,7 +853,7 @@ Derived from `tramp-postfix-method-format'.") "Regexp matching delimiter between user and domain names. Derived from `tramp-prefix-domain-format'.") -(defconst tramp-domain-regexp "[a-zA-Z0-9_.-]+" +(defconst tramp-domain-regexp "[[:alnum:]_.-]+" "Regexp matching domain names.") (defconst tramp-user-with-domain-regexp @@ -859,7 +870,7 @@ Used in `tramp-make-tramp-file-name'.") "Regexp matching delimiter between user and host names. Derived from `tramp-postfix-user-format'.") -(defconst tramp-host-regexp "[a-zA-Z0-9_.%-]+" +(defconst tramp-host-regexp "[[:alnum:]_.%-]+" "Regexp matching host names.") (defconst tramp-prefix-ipv6-format-alist @@ -887,7 +898,7 @@ Derived from `tramp-prefix-ipv6-format'.") ;; The following regexp is a bit sloppy. But it shall serve our ;; purposes. It covers also IPv4 mapped IPv6 addresses, like in ;; "::ffff:192.168.0.1". -(defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+" +(defconst tramp-ipv6-regexp "\\(?:[[:alnum:]]*:\\)+[[:alnum:].]+" "Regexp matching IPv6 addresses.") (defconst tramp-postfix-ipv6-format-alist @@ -919,7 +930,7 @@ Derived from `tramp-postfix-ipv6-format'.") "Regexp matching delimiter between host names and port numbers. Derived from `tramp-prefix-port-format'.") -(defconst tramp-port-regexp "[0-9]+" +(defconst tramp-port-regexp "[[:digit:]]+" "Regexp matching port numbers.") (defconst tramp-host-with-port-regexp @@ -1236,6 +1247,7 @@ the (optional) timestamp of last activity on this connection.") "Password save function. Will be called once the password has been verified by successful authentication.") +(put 'tramp-password-save-function 'tramp-suppress-trace t) (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions @@ -1259,7 +1271,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) @@ -1307,9 +1319,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) @@ -1369,8 +1382,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. @@ -1390,8 +1403,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. @@ -1411,8 +1424,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. @@ -1474,16 +1487,13 @@ 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 v "Method `%s' is not known." method)) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (and - hop - (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program))) + (unless (or (null hop) nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." method))))))) @@ -1497,8 +1507,7 @@ See `tramp-dissect-file-name' for details." tramp-postfix-host-format name)) nodefault))) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program)) + (unless (or nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." (tramp-file-name-method v))) @@ -1631,6 +1640,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 @@ -1673,11 +1691,10 @@ version, the function does nothing." (format "*debug tramp/%s %s*" method host-port)))) (defconst tramp-debug-outline-regexp - (eval-when-compile - (concat - "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ " ;; Timestamp. - "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread. - "[a-z0-9-]+ (\\([0-9]+\\)) #")) ;; Function name, verbosity. + (concat + "[[:digit:]]+:[[:digit:]]+:[[:digit:]]+\\.[[:digit:]]+ " ;; Timestamp. + "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread. + "[[:alnum:]-]+ (\\([[:digit:]]+\\)) #") ;; Function name, verbosity. "Used for highlighting Tramp debug buffers in `outline-mode'.") (defconst tramp-debug-font-lock-keywords @@ -1750,29 +1767,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. @@ -1787,11 +1785,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. @@ -1808,8 +1806,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 @@ -1841,6 +1840,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 @@ -1851,13 +1852,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 @@ -1875,6 +1879,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. @@ -1892,13 +1898,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) @@ -1910,19 +1916,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) @@ -1932,18 +1940,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) @@ -1955,6 +1966,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. @@ -1971,12 +1984,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, @@ -1985,8 +2000,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) @@ -1997,25 +2010,30 @@ 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)))))) + ;; Start only when there is no other progress reporter + ;; running, and when there is a minimum level. + (when-let ((pr (and (null tramp-inhibit-progress-reporter) + (<= ,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))))) @@ -2026,6 +2044,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) @@ -2037,12 +2056,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 @@ -2052,8 +2070,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,12 +2082,15 @@ letter into the file name. This function removes it." (save-match-data (let ((quoted (tramp-compat-file-name-quoted-p name 'top)) (result (tramp-compat-file-name-unquote name 'top))) - (setq result (if (string-match "\\`[a-zA-Z]:/" result) + (setq result (if (string-match "\\`[[:alpha:]]:/" result) (replace-match "/" nil t result) result)) (if quoted (tramp-compat-file-name-quote result 'top) result)))) ;;; 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). @@ -2104,10 +2123,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))) @@ -2145,11 +2164,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) @@ -2180,6 +2201,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 . @@ -2245,7 +2267,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) @@ -2273,13 +2295,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)))) @@ -2396,7 +2418,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)) @@ -2425,18 +2447,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 @@ -2448,7 +2473,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) @@ -2484,34 +2509,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)) @@ -2523,7 +2550,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 @@ -2564,24 +2591,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) @@ -2591,7 +2605,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 @@ -2882,7 +2896,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 "\\)" @@ -2932,7 +2946,7 @@ User is always nil." "Return a list of (user host) tuples allowed to access. User is always nil." (tramp-parse-shostkeys-sknownhosts - dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))) + dirname (concat "^key_[[:digit:]]+_\\(" tramp-host-regexp "\\)\\.pub$"))) (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. @@ -2967,7 +2981,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"))) @@ -2989,7 +3003,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"))) @@ -3026,7 +3040,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)))) @@ -3205,12 +3219,13 @@ User is always nil." (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) -(defun tramp-handle-file-modes (filename &optional _flag) +(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) @@ -3248,12 +3263,13 @@ User is always nil." (let ((candidate (tramp-compat-file-name-unquote (directory-file-name filename))) + case-fold-search tmpfile) ;; Check, whether we find an existing file with ;; lower case letters. This avoids us to create a ;; temporary file. (while (and (string-match-p - "[a-z]" (tramp-file-local-name candidate)) + "[[:lower:]]" (tramp-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3262,8 +3278,8 @@ User is always nil." ;; for comparison. `make-nearby-temp-file' is added ;; to Emacs 26+ like `file-name-case-insensitive-p', ;; so there is no compatibility problem calling it. - (unless - (string-match-p "[a-z]" (tramp-file-local-name candidate)) + (unless (string-match-p + "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3328,21 +3344,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." @@ -3381,8 +3394,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) @@ -3394,6 +3406,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. @@ -3453,7 +3467,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. @@ -3463,7 +3477,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)) @@ -3512,10 +3526,10 @@ User is always nil." ;; When we shall insert only a part of the file, we ;; copy this part. This works only for the shell file - ;; name handlers. + ;; name handlers. It doesn't work for crypted files. (when (and (or beg end) - (tramp-get-method-parameter - v 'tramp-login-program)) + (tramp-sh-file-name-handler-p v) + (null tramp-crypt-enabled)) (setq remote-copy (tramp-make-tramp-temp-file v)) ;; This is defined in tramp-sh.el. Let's assume ;; this is loaded already. @@ -3587,8 +3601,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) @@ -3622,7 +3636,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 @@ -3630,6 +3645,222 @@ User is always nil." (delete-file local-copy))))) t))) +(defun tramp-multi-hop-p (vec) + "Whether the method of VEC is capable of multi-hops." + (and (tramp-sh-file-name-handler-p vec) + (not (tramp-get-method-parameter vec 'tramp-copy-program)))) + +(defun tramp-compute-multi-hops (vec) + "Expands VEC according to `tramp-default-proxies-alist'." + (let ((saved-tdpa tramp-default-proxies-alist) + (target-alist `(,vec)) + (hops (or (tramp-file-name-hop vec) "")) + (item vec) + choices proxy) + + ;; Ad-hoc proxy definitions. + (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) + (let* ((host-port (tramp-file-name-host-port item)) + (user-domain (tramp-file-name-user-domain item)) + (proxy (concat + tramp-prefix-format proxy tramp-postfix-host-format)) + (entry + (list (and (stringp host-port) + (concat "^" (regexp-quote host-port) "$")) + (and (stringp user-domain) + (concat "^" (regexp-quote user-domain) "$")) + (propertize proxy 'tramp-ad-hoc t)))) + (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) + ;; Add the hop. + (add-to-list 'tramp-default-proxies-alist entry) + (setq item (tramp-dissect-file-name proxy)))) + ;; Save the new value. + (when (and hops tramp-save-ad-hoc-proxies) + (customize-save-variable + 'tramp-default-proxies-alist tramp-default-proxies-alist)) + + ;; Look for proxy hosts to be passed. + (setq choices tramp-default-proxies-alist) + (while choices + (setq item (pop choices) + proxy (eval (nth 2 item))) + (when (and + ;; Host. + (string-match-p + (or (eval (nth 0 item)) "") + (or (tramp-file-name-host-port (car target-alist)) "")) + ;; User. + (string-match-p + (or (eval (nth 1 item)) "") + (or (tramp-file-name-user-domain (car target-alist)) ""))) + (if (null proxy) + ;; No more hops needed. + (setq choices nil) + ;; Replace placeholders. + (setq proxy + (format-spec + proxy + (format-spec-make + ?u (or (tramp-file-name-user (car target-alist)) "") + ?h (or (tramp-file-name-host (car target-alist)) "")))) + (with-parsed-tramp-file-name proxy l + ;; Add the hop. + (push l target-alist) + ;; Start next search. + (setq choices tramp-default-proxies-alist))))) + + ;; Foreign and out-of-band methods are not supported for multi-hops. + (when (cdr target-alist) + (setq choices target-alist) + (while (setq item (pop choices)) + (unless (tramp-multi-hop-p item) + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Method `%s' is not supported for multi-hops." + (tramp-file-name-method item))))) + + ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the + ;; host name in their command template. In this case, the remote + ;; file name must use either a local host name (first hop), or a + ;; host name matching the previous hop. + (let ((previous-host (or tramp-local-host-regexp ""))) + (setq choices target-alist) + (while (setq item (pop choices)) + (let ((host (tramp-file-name-host item))) + (unless + (or + ;; The host name is used for the remote shell command. + (member + '("%h") (tramp-get-method-parameter item 'tramp-login-args)) + ;; The host name must match previous hop. + (string-match-p previous-host host)) + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Host name `%s' does not match `%s'" host previous-host)) + (setq previous-host (concat "^" (regexp-quote host) "$"))))) + + ;; Result. + target-alist)) + +(defun tramp-direct-async-process-p (&rest args) + "Whether direct async `make-process' can be called." + (let ((v (tramp-dissect-file-name default-directory)) + (buffer (plist-get args :buffer)) + (stderr (plist-get args :stderr))) + (and ;; It has been indicated. + (tramp-get-connection-property v "direct-async-process" nil) + ;; There's no multi-hop. + (or (not (tramp-multi-hop-p v)) + (= (length (tramp-compute-multi-hops v)) 1)) + ;; There's no remote stdout or stderr file. + (or (not (stringp buffer)) (not (tramp-tramp-file-p buffer))) + (or (not (stringp stderr)) (not (tramp-tramp-file-p stderr)))))) + +(defun tramp-handle-make-process (&rest args) + "An alternative `make-process' implementation for Tramp files. +It does not support `:stderr'." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((default-directory (tramp-compat-temporary-file-directory)) + (name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr)) + (signal 'wrong-type-argument (list #'stringp 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))) + (command + (mapconcat + #'identity (append `("cd" ,localname "&&") command) " "))) + + ;; Check for `tramp-sh-file-name-handler', because something + ;; is different between tramp-adb.el and tramp-sh.el. + (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v)) + (login-program + (tramp-get-method-parameter v 'tramp-login-program)) + (login-args + (tramp-get-method-parameter v 'tramp-login-args)) + (async-args + (tramp-get-method-parameter v 'tramp-async-args)) + (direct-async-args + (tramp-get-method-parameter v 'tramp-direct-async-args)) + ;; We don't create the temporary file. In fact, it + ;; is just a prefix for the ControlPath option of + ;; ssh; the real temporary file has another name, and + ;; it is created and protected by ssh. It is also + ;; removed by ssh when the connection is closed. The + ;; temporary file name is cached in the main + ;; connection process, therefore we cannot use + ;; `tramp-get-connection-process'. + (tmpfile + (when sh-file-name-handler-p + (with-tramp-connection-property + (tramp-get-process v) "temp-file" + (tramp-compat-make-temp-name)))) + (options + (when sh-file-name-handler-p + (tramp-compat-funcall + 'tramp-ssh-controlmaster-options v))) + spec p) + + ;; Replace `login-args' place holders. + (setq + spec (format-spec-make ?t tmpfile) + options (format-spec (or options "") spec) + spec (format-spec-make + ?h (or host "") ?u (or user "") ?p (or port "") + ?c options ?l "") + ;; Add arguments for asynchronous processes. + login-args (append async-args direct-async-args login-args) + ;; Expand format spec. + login-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) x)) + login-args)) + ;; Split ControlMaster options. + login-args + (tramp-compat-flatten-tree + (mapcar (lambda (x) (split-string x " ")) login-args)) + p (make-process + :name name :buffer buffer + :command (append `(,login-program) login-args `(,command)) + :coding coding :noquery noquery :connection-type connection-type + :filter filter :sentinel sentinel :stderr stderr)) + + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + p)))))) + (defun tramp-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) "Like `make-symbolic-link' for Tramp files. @@ -3664,9 +3895,12 @@ support symbolic links." (setq current-buffer-p t) (current-buffer)) (t (get-buffer-create + ;; These variables have been introduced with Emacs 28.1. (if asynchronous - "*Async Shell Command*" - "*Shell Command Output*"))))) + (or (bound-and-true-p shell-command-buffer-name-async) + "*Async Shell Command*") + (or (bound-and-true-p shell-command-buffer-name) + "*Shell Command Output*")))))) (error-buffer (cond ((bufferp error-buffer) error-buffer) @@ -3800,7 +4034,8 @@ support symbolic links." (defun tramp-handle-start-file-process (name buffer program &rest args) "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. + ;; `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 @@ -3908,7 +4143,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 @@ -3927,15 +4169,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) @@ -3989,7 +4234,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: @@ -4131,9 +4376,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) @@ -4183,9 +4428,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))) @@ -4206,10 +4450,9 @@ performed successfully. Any other value means an error." (tramp-get-connection-buffer vec))) ((eq exit 'process-died) (substitute-command-keys - (eval-when-compile - (concat - "Tramp failed to connect. If this happens repeatedly, try\n" - " `\\[tramp-cleanup-this-connection]'")))) + (concat + "Tramp failed to connect. If this happens repeatedly, try\n" + " `\\[tramp-cleanup-this-connection]'"))) ((eq exit 'timeout) (format-message "Timeout reached, see buffer `%s' for details" @@ -4224,18 +4467,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) @@ -4503,9 +4749,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) @@ -4535,16 +4781,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. @@ -4610,12 +4855,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))) @@ -4649,6 +4890,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." @@ -4662,16 +4929,16 @@ This handles also chrooted environments, which are not regarded as local." ;; The method shall be applied to one of the shell file name ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. - (tramp-get-method-parameter vec 'tramp-login-program) + (tramp-sh-file-name-handler-p vec) + ;; 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." @@ -4684,18 +4951,21 @@ This handles also chrooted environments, which are not regarded as local." (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. @@ -4868,6 +5138,19 @@ 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. @@ -5089,16 +5372,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 4aed8abd9b3..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.5-pre" +(defconst tramp-version "2.5.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -73,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.5-pre 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))) @@ -104,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)" "") ": ") |