diff options
Diffstat (limited to 'lisp/net')
35 files changed, 3942 insertions, 2128 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 92ed98b2a89..0cb8d7cb837 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -838,7 +838,7 @@ If nil, prompt the user for a password." "If non-nil, regexp matching hosts on which `dir' command lists directory." :group 'ange-ftp :type '(choice (const :tag "Default" nil) - string)) + regexp)) (defcustom ange-ftp-binary-file-name-regexp "" "If a file matches this regexp then it is transferred in binary mode." @@ -4169,8 +4169,7 @@ directory, so that Emacs will know its current contents." (if (file-directory-p file) (ange-ftp-delete-directory file recursive trash) (delete-file file trash))) - ;; We do not want to delete "." and "..". - (directory-files dir 'full (rx (or (not ".") "..."))))) + (directory-files dir 'full directory-files-no-dot-files-regexp))) (if parsed (let* ((host (nth 0 parsed)) (user (nth 1 parsed)) @@ -4739,7 +4738,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired. 0) -(defun ange-ftp-set-file-modes (filename mode) +(defun ange-ftp-set-file-modes (filename mode &optional flag) + flag ;; FIXME: Support 'nofollow'. (ange-ftp-call-chmod (list (format "%o" mode) filename))) (defun ange-ftp-make-symbolic-link (&rest _arguments) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 25aabf6d61d..8892e800cd6 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,7 +39,6 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany Epiphany Don't know -;; browse-url-conkeror Conkeror Don't know ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -114,9 +113,23 @@ ;; To always save modified buffers before displaying the file in a browser: ;; (setq browse-url-save-file t) -;; To invoke different browsers for different URLs: -;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail) -;; ("." . browse-url-firefox))) +;; To invoke different browsers/tools for different URLs, customize +;; `browse-url-handlers'. In earlier versions of Emacs, the same +;; could be done by setting `browse-url-browser-function' to an alist +;; but this usage is deprecated now. + +;; All browser functions provided by here have a +;; `browse-url-browser-kind' symbol property set to either `internal' +;; or `external' which determines if they browse the given URL inside +;; Emacs or spawn an external application with it. Some parts of +;; Emacs make use of that, e.g., when an URL is dragged into Emacs, it +;; is not sensible to invoke an external browser with it, so here only +;; internal browsers are considered. Therefore, it is advised to put +;; that property also on custom browser functions. +;; (function-put 'my-browse-url-in-emacs 'browse-url-browser-kind +;; 'internal) +;; (function-put 'my-browse-url-externally 'browse-url-browser-kind +;; 'external) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code: @@ -140,7 +153,6 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "Epiphany" :value browse-url-epiphany) - (function-item :tag "Conkeror" :value browse-url-conkeror) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -157,7 +169,9 @@ :value browse-url-default-browser) (function :tag "Your own function") (alist :tag "Regexp/function association list" - :key-type regexp :value-type function))) + :key-type regexp :value-type function + :format "%{%t%}\n%d%v\n" + :doc "Deprecated. Use `browse-url-handlers' instead."))) ;;;###autoload (defcustom browse-url-browser-function 'browse-url-default-browser @@ -165,13 +179,8 @@ This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. -If the value is not a function it should be a list of pairs -\(REGEXP . FUNCTION). In this case the function called will be the one -associated with the first REGEXP which matches the current URL. The -function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser. - -Also see `browse-url-secondary-browser-function'." +Also see `browse-url-secondary-browser-function' and +`browse-url-handlers'." :type browse-url--browser-defcustom-type :version "24.1") @@ -216,7 +225,7 @@ be used instead." "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" "\\|" "[" chars punct "]+" "[" chars "]" @@ -385,6 +394,8 @@ If non-nil, then open the URL in a new buffer rather than a new window if :version "25.1" :type 'boolean) +(make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1") + (defcustom browse-url-galeon-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if @@ -438,11 +449,15 @@ commands reverses the effect of this variable." :type 'string :version "25.1") +(make-obsolete-variable 'browse-url-conkeror-program nil "28.1") + (defcustom browse-url-conkeror-arguments nil "A list of strings to pass to Conkeror as arguments." :version "25.1" :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'browse-url-conkeror-arguments nil "28.1") + (defcustom browse-url-filename-alist `(("^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*" . "ftp://\\2/") ;; The above loses the username to avoid the browser prompting for @@ -595,6 +610,116 @@ down (this *won't* always work)." "Wrapper command prepended to the Elinks command-line." :type '(repeat (string :tag "Wrapper"))) +(defun browse-url--browser-kind (function url) + "Return the browser kind of a browser FUNCTION for URL. +The browser kind is either `internal' (the browser runs inside +Emacs), `external' (the browser is spawned in an external +process), or nil (we don't know)." + (let ((kind (if (symbolp function) + (get function 'browse-url-browser-kind)))) + (if (functionp kind) + (funcall kind url) + kind))) + +(defun browse-url--mailto (url &rest args) + "Calls `browse-url-mailto-function' with URL and ARGS." + (funcall browse-url-mailto-function url args)) + +(defun browse-url--browser-kind-mailto (url) + (browse-url--browser-kind browse-url-mailto-function url)) +(function-put 'browse-url--mailto 'browse-url-browser-kind + #'browse-url--browser-kind-mailto) + +(defun browse-url--man (url &rest args) + "Calls `browse-url-man-function' with URL and ARGS." + (funcall browse-url-man-function url args)) + +(defun browse-url--browser-kind-man (url) + (browse-url--browser-kind browse-url-man-function url)) +(function-put 'browse-url--man 'browse-url-browser-kind + #'browse-url--browser-kind-man) + +(defun browse-url--browser (url &rest args) + "Calls `browse-url-browser-function' with URL and ARGS." + (funcall browse-url-browser-function url args)) + +(defun browse-url--browser-kind-browser (url) + (browse-url--browser-kind browse-url-browser-function url)) +(function-put 'browse-url--browser 'browse-url-browser-kind + #'browse-url--browser-kind-browser) + +(defun browse-url--non-html-file-url-p (url) + "Return non-nil if URL is a file:// URL of a non-HTML file." + (and (string-match-p "\\`file://" url) + (not (string-match-p "\\`file://.*\\.html?\\b" url)))) + +;;;###autoload +(defvar browse-url-default-handlers + '(("\\`mailto:" . browse-url--mailto) + ("\\`man:" . browse-url--man) + (browse-url--non-html-file-url-p . browse-url-emacs)) + "Like `browse-url-handlers' but populated by Emacs and packages. + +Emacs and external packages capable of browsing certain URLs +should place their entries in this alist rather than +`browse-url-handlers' which is reserved for the user.") + +(defcustom browse-url-handlers nil + "An alist with elements of the form (REGEXP-OR-PREDICATE . HANDLER). +Each REGEXP-OR-PREDICATE is matched against the URL to be opened +in turn and the first match's HANDLER is invoked with the URL. + +A HANDLER must be a function with the same arguments as +`browse-url'. + +If no REGEXP-OR-PREDICATE matches, the same procedure is +performed with the value of `browse-url-default-handlers'. If +there is also no match, the URL is opened using the value of +`browse-url-browser-function'." + :type '(alist :key-type (choice + (regexp :tag "Regexp") + (function :tag "Predicate")) + :value-type (function :tag "Handler")) + :version "28.1") + +;;;###autoload +(defun browse-url-select-handler (url &optional kind) + "Return a handler of suitable for browsing URL. +This searches `browse-url-handlers', and +`browse-url-default-handlers' for a matching handler. Return nil +if no handler is found. + +If KIND is given, the search is restricted to handlers whose +function symbol has the symbol-property `browse-url-browser-kind' +set to KIND. + +Currently, it also consults `browse-url-browser-function' first +if it is set to an alist, although this usage is deprecated since +Emacs 28.1 and will be removed in a future release." + (catch 'custom-url-handler + (dolist (rxpred-handler + (append + ;; The alist choice of browse-url-browser-function + ;; is deprecated since 28.1, so the (unless ...) + ;; can be removed at some point in time. + (when (and (consp browse-url-browser-function) + (not (functionp browse-url-browser-function))) + (lwarn 'browse-url :warning + "Having `browse-url-browser-function' set to an +alist is deprecated. Use `browse-url-handlers' instead.") + browse-url-browser-function) + browse-url-handlers + browse-url-default-handlers)) + (let ((rx-or-pred (car rxpred-handler)) + (handler (cdr rxpred-handler))) + (when (and (or (null kind) + (eq kind (browse-url--browser-kind + handler url))) + (if (functionp rx-or-pred) + (funcall rx-or-pred url) + (string-match-p rx-or-pred url))) + (throw 'custom-url-handler handler)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL encoding @@ -768,16 +893,18 @@ narrowed." "Ask a WWW browser to load URL. Prompt for a URL, defaulting to the URL at or before point. Invokes a suitable browser function which does the actual job. -The variable `browse-url-browser-function' says which browser function to -use. If the URL is a mailto: URL, consult `browse-url-mailto-function' -first, if that exists. - -The additional ARGS are passed to the browser function. See the doc -strings of the actual functions, starting with `browse-url-browser-function', -for information about the significance of ARGS (most of the functions -ignore it). -If ARGS are omitted, the default is to pass `browse-url-new-window-flag' -as ARGS." + +The variables `browse-url-browser-function', +`browse-url-handlers', and `browse-url-default-handlers' +determine which browser function to use. + +The additional ARGS are passed to the browser function. See the +doc strings of the actual functions, starting with +`browse-url-browser-function', for information about the +significance of ARGS (most of the functions ignore it). + +If ARGS are omitted, the default is to pass +`browse-url-new-window-flag' as ARGS." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) @@ -786,12 +913,9 @@ as ARGS." (not (string-match "\\`[a-z]+:" url))) (setq url (expand-file-name url))) (let ((process-environment (copy-sequence process-environment)) - (function (or (and (string-match "\\`mailto:" url) - browse-url-mailto-function) - (and (string-match "\\`man:" url) - browse-url-man-function) - browse-url-browser-function)) - ;; Ensure that `default-directory' exists and is readable (b#6077). + (function (or (browse-url-select-handler url) + browse-url-browser-function)) + ;; Ensure that `default-directory' exists and is readable (bug#6077). (default-directory (or (unhandled-file-name-directory default-directory) (expand-file-name "~/")))) ;; When connected to various displays, be careful to use the display of @@ -799,20 +923,9 @@ as ARGS." ;; which may not even exist any more. (if (stringp (frame-parameter nil 'display)) (setenv "DISPLAY" (frame-parameter nil 'display))) - (if (and (consp function) - (not (functionp function))) - ;; The `function' can be an alist; look down it for first match - ;; and apply the function (which might be a lambda). - (catch 'done - (dolist (bf function) - (when (string-match (car bf) url) - (apply (cdr bf) url args) - (throw 'done t))) - (error "No browse-url-browser-function matching URL %s" - url)) - ;; Unbound symbols go down this leg, since void-function from - ;; apply is clearer than wrong-type-argument from dolist. - (apply function url args)))) + (if (functionp function) + (apply function url args) + (error "No suitable browser for URL %s" url)))) ;;;###autoload (defun browse-url-at-point (&optional arg) @@ -829,6 +942,34 @@ Optional prefix argument ARG non-nil inverts the value of the option (error "No URL found")))) ;;;###autoload +(defun browse-url-with-browser-kind (kind url &optional arg) + "Browse URL with a browser of the given browser KIND. +KIND is either `internal' or `external'. + +When called interactively, the default browser kind is the +opposite of the browser kind of `browse-url-browser-function'." + (interactive + (let* ((url-arg (browse-url-interactive-arg "URL: ")) + ;; Default to the inverse kind of the default browser. + (default (if (eq (browse-url--browser-kind + browse-url-browser-function (car url-arg)) + 'internal) + 'external + 'internal)) + (k (intern (completing-read + (format "Browser kind (default %s): " default) + '(internal external) + nil t nil nil + default)))) + (cons k url-arg))) + (let ((function (browse-url-select-handler url kind))) + (unless function + (setq function (if (eq kind 'external) + #'browse-url-default-browser + #'eww))) + (funcall function url arg))) + +;;;###autoload (defun browse-url-at-mouse (event) "Ask a WWW browser to load a URL clicked with the mouse. The URL is the one around or before the position of the mouse click @@ -875,12 +1016,18 @@ The optional NEW-WINDOW argument is not used." (url-unhex-string url) url))))) +(function-put 'browse-url-default-windows-browser 'browse-url-browser-kind + 'external) + (defun browse-url-default-macosx-browser (url &optional _new-window) "Invoke the macOS system's default Web browser. The optional NEW-WINDOW argument is not used." (interactive (browse-url-interactive-arg "URL: ")) (start-process (concat "open " url) nil "open" url)) +(function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind + 'external) + ;; --- Netscape --- (defun browse-url-process-environment () @@ -929,7 +1076,7 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-kde-program) 'browse-url-kde) ;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ;;; ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) - ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) +;;; ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) ((executable-find browse-url-chrome-program) 'browse-url-chrome) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) @@ -937,6 +1084,10 @@ instead of `browse-url-new-window-flag'." (lambda (&rest _ignore) (error "No usable browser found")))) url args)) +(function-put 'browse-url-default-browser 'browse-url-browser-kind + ;; Well, most probably external if we ignore w3. + 'external) + (defun browse-url-can-use-xdg-open () "Return non-nil if the \"xdg-open\" program can be used. xdg-open is a desktop utility that calls your preferred web browser." @@ -956,6 +1107,8 @@ The optional argument IGNORED is not used." (interactive (browse-url-interactive-arg "URL: ")) (call-process "xdg-open" nil 0 nil url)) +(function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-netscape (url &optional new-window) "Ask the Netscape WWW browser to load URL. @@ -999,6 +1152,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-netscape-sentinel process ,url))))) +(function-put 'browse-url-netscape 'browse-url-browser-kind 'external) + (defun browse-url-netscape-sentinel (process url) "Handle a change to the process communicating with Netscape." (declare (obsolete nil "25.1")) @@ -1069,6 +1224,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-mozilla-sentinel process ,url))))) +(function-put 'browse-url-mozilla 'browse-url-browser-kind 'external) + (defun browse-url-mozilla-sentinel (process url) "Handle a change to the process communicating with Mozilla." (or (eq (process-exit-status process) 0) @@ -1109,6 +1266,8 @@ instead of `browse-url-new-window-flag'." '("-new-window"))) (list url))))) +(function-put 'browse-url-firefox 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-chromium (url &optional _new-window) "Ask the Chromium WWW browser to load URL. @@ -1126,6 +1285,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chromium-arguments (list url))))) +(function-put 'browse-url-chromium 'browse-url-browser-kind 'external) + (defun browse-url-chrome (url &optional _new-window) "Ask the Google Chrome WWW browser to load URL. Default to the URL around or before point. The strings in @@ -1142,6 +1303,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chrome-arguments (list url))))) +(function-put 'browse-url-chrome 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-galeon (url &optional new-window) "Ask the Galeon WWW browser to load URL. @@ -1179,6 +1342,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-galeon-sentinel process ,url))))) +(function-put 'browse-url-galeon 'browse-url-browser-kind 'external) + (defun browse-url-galeon-sentinel (process url) "Handle a change to the process communicating with Galeon." (declare (obsolete nil "25.1")) @@ -1225,6 +1390,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-epiphany-sentinel process ,url))))) +(function-put 'browse-url-epiphany 'browse-url-browser-kind 'external) + (defun browse-url-epiphany-sentinel (process url) "Handle a change to the process communicating with Epiphany." (or (eq (process-exit-status process) 0) @@ -1249,6 +1416,8 @@ currently selected window instead." file-name-handler-alist))) (if same-window (find-file url) (find-file-other-window url)))) +(function-put 'browse-url-emacs 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. @@ -1273,6 +1442,8 @@ used instead of `browse-url-new-window-flag'." '("--newwin")) (list "--raise" url)))) +(function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external) + ;; --- Mosaic --- ;;;###autoload @@ -1324,6 +1495,8 @@ used instead of `browse-url-new-window-flag'." (append browse-url-mosaic-arguments (list url))) (message "Starting %s...done" browse-url-mosaic-program)))) +(function-put 'browse-url-mosaic 'browse-url-browser-kind 'external) + ;; --- Mosaic using CCI --- ;;;###autoload @@ -1356,6 +1529,8 @@ used instead of `browse-url-new-window-flag'." (process-send-string "browse-url" "disconnect\r\n") (delete-process "browse-url")) +(function-put 'browse-url-cci 'browse-url-browser-kind 'external) + ;; --- Conkeror --- ;;;###autoload (defun browse-url-conkeror (url &optional new-window) @@ -1375,6 +1550,7 @@ new window, load it in a new buffer in an existing window instead. When called non-interactively, use optional second argument NEW-WINDOW instead of `browse-url-new-window-flag'." + (declare (obsolete nil "28.1")) (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) @@ -1392,6 +1568,9 @@ NEW-WINDOW instead of `browse-url-new-window-flag'." "window") "buffer") url)))))) + +(function-put 'browse-url-conkeror 'browse-url-browser-kind 'external) + ;; --- W3 --- ;; External. @@ -1415,6 +1594,8 @@ used instead of `browse-url-new-window-flag'." (w3-fetch-other-window url) (w3-fetch url))) +(function-put 'browse-url-w3 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-w3-gnudoit (url &optional _new-window) ;; new-window ignored @@ -1429,6 +1610,8 @@ The `browse-url-gnudoit-program' program is used with options given by (list (concat "(w3-fetch \"" url "\")") "(raise-frame)")))) +(function-put 'browse-url-w3-gnudoit 'browse-url-browser-kind 'internal) + ;; --- Lynx in an xterm --- ;;;###autoload @@ -1446,6 +1629,8 @@ The optional argument NEW-WINDOW is not used." ,@browse-url-xterm-args "-e" ,browse-url-text-browser ,url))) +(function-put 'browse-url-text-xterm 'browse-url-browser-kind 'external) + ;; --- Lynx in an Emacs "term" window --- (declare-function term-char-mode "term" ()) @@ -1520,6 +1705,8 @@ used instead of `browse-url-new-window-flag'." url "\r"))))) +(function-put 'browse-url-text-emacs 'browse-url-browser-kind 'internal) + ;; --- mailto --- (autoload 'rfc2368-parse-mailto-url "rfc2368") @@ -1567,6 +1754,8 @@ used instead of `browse-url-new-window-flag'." (unless (bolp) (insert "\n")))))))) +(function-put 'browse-url-mail 'browse-url-browser-kind 'internal) + ;; --- man --- (defvar manual-program) @@ -1578,7 +1767,9 @@ used instead of `browse-url-new-window-flag'." (setq url (replace-regexp-in-string "\\`man:" "" url)) (cond ((executable-find manual-program) (man url)) - (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + +(function-put 'browse-url-man 'browse-url-browser-kind 'internal) ;; --- Random browser --- @@ -1597,6 +1788,8 @@ don't offer a form of remote control." 0 nil (append browse-url-generic-args (list url)))) +(function-put 'browse-url-generic 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-kde (url &optional _new-window) "Ask the KDE WWW browser to load URL. @@ -1607,6 +1800,8 @@ The optional argument NEW-WINDOW is not used." (apply #'start-process (concat "KDE " url) nil browse-url-kde-program (append browse-url-kde-args (list url)))) +(function-put 'browse-url-kde 'browse-url-browser-kind 'external) + (defun browse-url-elinks-new-window (url) "Ask the Elinks WWW browser to load URL in a new window." (let ((process-environment (browse-url-process-environment))) @@ -1616,6 +1811,9 @@ The optional argument NEW-WINDOW is not used." browse-url-elinks-wrapper (list "elinks" url))))) +(function-put 'browse-url-elinks-new-window 'browse-url-browser-kind + 'external) + ;;;###autoload (defun browse-url-elinks (url &optional new-window) "Ask the Elinks WWW browser to load URL. @@ -1637,6 +1835,8 @@ from `browse-url-elinks-wrapper'." `(lambda (process change) (browse-url-elinks-sentinel process ,url)))))) +(function-put 'browse-url-elinks 'browse-url-browser-kind 'external) + (defun browse-url-elinks-sentinel (process url) "Determines if Elinks is running or a new one has to be started." ;; Try to determine if an instance is running or if we have to diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 06bd9e567fe..fdd726ff613 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -51,9 +51,6 @@ (unless (boundp 'dbus-debug) (defvar dbus-debug nil)) -;; Pacify byte compiler. -(eval-when-compile (require 'cl-lib)) - (require 'xml) (defconst dbus-service-dbus "org.freedesktop.DBus" @@ -169,10 +166,7 @@ Otherwise, return result of last form in BODY, or all other errors." `(condition-case err (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) -(define-obsolete-variable-alias 'dbus-event-error-hooks - 'dbus-event-error-functions "24.3") (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable @@ -181,7 +175,7 @@ caught in `condition-case' by `dbus-error'.") ;;; Basic D-Bus message functions. -(defvar dbus-return-values-table (make-hash-table :test 'equal) +(defvar dbus-return-values-table (make-hash-table :test #'equal) "Hash table for temporarily storing arguments of reply messages. A key in this hash table is a list (:serial BUS SERIAL), like in `dbus-registered-objects-table'. BUS is either a Lisp symbol, @@ -301,8 +295,8 @@ object is returned instead of a list containing this single Lisp object. (check-interval 0.001) (key (apply - 'dbus-message-internal dbus-message-type-method-call - bus service path interface method 'dbus-call-method-handler args)) + #'dbus-message-internal dbus-message-type-method-call + bus service path interface method #'dbus-call-method-handler args)) (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into @@ -338,10 +332,6 @@ object is returned instead of a list containing this single Lisp object. (cdr result)) (remhash key dbus-return-values-table)))) -;; `dbus-call-method' works non-blocking now. -(defalias 'dbus-call-method-non-blocking 'dbus-call-method) -(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3") - (defun dbus-call-method-asynchronously (bus service path interface method handler &rest args) "Call METHOD on the D-Bus BUS asynchronously. @@ -406,7 +396,7 @@ Example: (or (null handler) (functionp handler) (signal 'wrong-type-argument (list 'functionp handler))) - (apply 'dbus-message-internal dbus-message-type-method-call + (apply #'dbus-message-internal dbus-message-type-method-call bus service path interface method handler args)) (defun dbus-send-signal (bus service path interface signal &rest args) @@ -454,7 +444,7 @@ Example: (or (stringp signal) (signal 'wrong-type-argument (list 'stringp signal))) - (apply 'dbus-message-internal dbus-message-type-signal + (apply #'dbus-message-internal dbus-message-type-signal bus service path interface signal args)) (defun dbus-method-return-internal (bus service serial &rest args) @@ -470,7 +460,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-method-return + (apply #'dbus-message-internal dbus-message-type-method-return bus service serial args)) (defun dbus-method-error-internal (bus service serial &rest args) @@ -486,7 +476,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-error + (apply #'dbus-message-internal dbus-message-type-error bus service serial args)) @@ -552,13 +542,13 @@ placed in the queue. `:already-owner': Service is already the primary owner." ;; Add Peer handler. - (dbus-register-method - bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register) + (dbus-register-method bus service nil dbus-interface-peer "Ping" + #'dbus-peer-handler 'dont-register) ;; Add ObjectManager handler. (dbus-register-method bus service nil dbus-interface-objectmanager "GetManagedObjects" - 'dbus-managed-objects-handler 'dont-register) + #'dbus-managed-objects-handler 'dont-register) (let ((arg 0) reply) @@ -681,7 +671,7 @@ Example: (if (and (stringp service) (not (zerop (length service))) (not (string-equal service dbus-service-dbus)) - (not (string-match "^:" service))) + (/= (string-to-char service) ?:)) (setq uname (dbus-get-name-owner bus service)) (setq uname service)) @@ -710,7 +700,7 @@ Example: ;; `:arg0' .. `:arg63', `:path0' .. `:path63'. ((and (keywordp key) (string-match - "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$" + "\\`:\\(arg\\|path\\)\\([[:digit:]]+\\)\\'" (symbol-name key))) (setq counter (match-string 2 (symbol-name key)) args (cdr args) @@ -726,9 +716,7 @@ Example: "path" "") value)) ;; `:arg-namespace', `:path-namespace'. - ((and (keywordp key) - (string-match - "^:\\(arg\\|path\\)-namespace$" (symbol-name key))) + ((memq key '(:arg-namespace :path-namespace)) (setq args (cdr args) value (car args)) (unless (stringp value) @@ -736,8 +724,7 @@ Example: (list "Wrong argument" key value))) (format ",%s='%s'" - (if (string-equal (match-string 1 (symbol-name key)) "path") - "path_namespace" "arg0namespace") + (if (eq key :path-namespace) "path_namespace" "arg0namespace") value)) ;; `:eavesdrop'. ((eq key :eavesdrop) @@ -751,11 +738,11 @@ Example: bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule) (dbus-error - (if (not (string-match "eavesdrop" rule)) + (if (not (string-match-p "eavesdrop" rule)) (signal (car err) (cdr err)) ;; The D-Bus spec says we shall fall back to a rule without eavesdrop. (when dbus-debug (message "Removing eavesdrop from rule %s" rule)) - (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule)) + (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule t t)) (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule)))) @@ -893,9 +880,7 @@ association to the service from D-Bus." STRING shall be UTF-8 coded." (if (zerop (length string)) '(:array :signature "y") - (let (result) - (dolist (elt (string-to-list string) (append '(:array) result)) - (setq result (append result (list :byte elt))))))) + (cons :array (mapcan (lambda (c) (list :byte c)) string)))) (defun dbus-byte-array-to-string (byte-array &optional multibyte) "Transform BYTE-ARRAY into UTF-8 coded string. @@ -903,12 +888,9 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array'. The resulting string is unibyte encoded, unless MULTIBYTE is non-nil." (apply - (if multibyte 'string 'unibyte-string) - (if (equal byte-array '(:array :signature "y")) - nil - (let (result) - (dolist (elt byte-array result) - (when (characterp elt) (setq result (append result `(,elt))))))))) + (if multibyte #'string #'unibyte-string) + (unless (equal byte-array '(:array :signature "y")) + (seq-filter #'characterp byte-array)))) (defun dbus-escape-as-identifier (string) "Escape an arbitrary STRING so it follows the rules for a C identifier. @@ -930,9 +912,9 @@ telepathy-glib's `tp_escape_as_identifier'." (if (zerop (length string)) "_" (replace-regexp-in-string - "^[0-9]\\|[^A-Za-z0-9]" + "\\`[0-9]\\|[^A-Za-z0-9]" (lambda (x) (format "_%2x" (aref x 0))) - string))) + string nil t))) (defun dbus-unescape-from-identifier (string) "Retrieve the original string from the encoded STRING as unibyte string. @@ -942,7 +924,7 @@ STRING must have been encoded with `dbus-escape-as-identifier'." (replace-regexp-in-string "_.." (lambda (x) (byte-to-string (string-to-number (substring x 1) 16))) - string))) + string nil t))) ;;; D-Bus events. @@ -1020,7 +1002,7 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (if (eq result :ignore) (dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event)) - (apply 'dbus-method-return-internal + (apply #'dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event) (if (consp result) result (list result))))))) ;; Error handling. @@ -1119,10 +1101,9 @@ unique names for services." (defun dbus-list-known-names (bus) "Retrieve all services which correspond to a known name in BUS. A service has a known name if it doesn't start with \":\"." - (let (result) - (dolist (name (dbus-list-names bus) (nreverse result)) - (unless (string-equal ":" (substring name 0 1)) - (push name result))))) + (seq-remove (lambda (name) + (= (string-to-char name) ?:)) + (dbus-list-names bus))) (defun dbus-list-queued-owners (bus service) "Return the unique names registered at D-Bus BUS and queued for SERVICE. @@ -1182,6 +1163,18 @@ It will be registered for all objects created by `dbus-register-service'." ;;; D-Bus introspection. +(defsubst dbus--introspect-names (object tag) + "Return the names of the children of OBJECT with TAG." + (mapcar (lambda (elt) + (dbus-introspect-get-attribute elt "name")) + (xml-get-children object tag))) + +(defsubst dbus--introspect-name (object tag name) + "Return the first child of OBJECT with TAG, whose name is NAME." + (seq-find (lambda (elt) + (string-equal (dbus-introspect-get-attribute elt "name") name)) + (xml-get-children object tag))) + (defun dbus-introspect (bus service path) "Return all interfaces and sub-nodes of SERVICE, registered at object path PATH at bus BUS. @@ -1197,17 +1190,25 @@ XML format." bus service path dbus-interface-introspectable "Introspect" :timeout 1000))) +(defalias 'dbus--parse-xml-buffer + (if (libxml-available-p) + (lambda () + (xml-remove-comments (point-min) (point-max)) + (libxml-parse-xml-region (point-min) (point-max))) + (lambda () + (car (xml-parse-region (point-min) (point-max))))) + "Compatibility shim for `libxml-parse-xml-region'.") + (defun dbus-introspect-xml (bus service path) "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. The data are a parsed list. The root object is a \"node\", representing the object path PATH. The root object can contain \"interface\" and further \"node\" objects." - ;; We don't want to raise errors. - (xml-node-name - (ignore-errors - (with-temp-buffer - (insert (dbus-introspect bus service path)) - (xml-parse-region (point-min) (point-max)))))) + (with-temp-buffer + ;; We don't want to raise errors. + (ignore-errors + (insert (dbus-introspect bus service path)) + (dbus--parse-xml-buffer)))) (defun dbus-introspect-get-attribute (object attribute) "Return the ATTRIBUTE value of D-Bus introspection OBJECT. @@ -1219,21 +1220,15 @@ the D-Bus specification." "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings. The node names stand for further object paths of the D-Bus service." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'node) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'node)) (defun dbus-introspect-get-all-nodes (bus service path) "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings, which are further object paths of SERVICE." - (let ((result (list path))) - (dolist (elt - (dbus-introspect-get-node-names bus service path) - result) - (setq elt (expand-file-name elt path)) - (setq result - (append result (dbus-introspect-get-all-nodes bus service elt)))))) + (cons path (mapcan (lambda (elt) + (setq elt (expand-file-name elt path)) + (dbus-introspect-get-all-nodes bus service elt)) + (dbus-introspect-get-node-names bus service path)))) (defun dbus-introspect-get-interface-names (bus service path) "Return all interface names of SERVICE in D-Bus BUS at object path PATH. @@ -1244,10 +1239,7 @@ always present. Another default interface is \"org.freedesktop.DBus.Properties\". If present, \"interface\" objects can also have \"property\" objects as children, beside \"method\" and \"signal\" objects." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'interface) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'interface)) (defun dbus-introspect-get-interface (bus service path interface) "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH. @@ -1256,22 +1248,14 @@ and a member of the list returned by `dbus-introspect-get-interface-names'. The resulting \"interface\" object can contain \"method\", \"signal\", \"property\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-xml bus service path) 'interface))) - (while (and elt - (not (string-equal - interface - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name (dbus-introspect-xml bus service path) + 'interface interface)) (defun dbus-introspect-get-method-names (bus service path interface) "Return a list of strings of all method names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'method) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'method)) (defun dbus-introspect-get-method (bus service path interface method) "Return method METHOD of interface INTERFACE as an XML object. @@ -1279,22 +1263,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. METHOD must be a string and a member of the list returned by `dbus-introspect-get-method-names'. The resulting \"method\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'method))) - (while (and elt - (not (string-equal - method (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'method method)) (defun dbus-introspect-get-signal-names (bus service path interface) "Return a list of strings of all signal names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'signal) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'signal)) (defun dbus-introspect-get-signal (bus service path interface signal) "Return signal SIGNAL of interface INTERFACE as an XML object. @@ -1302,22 +1279,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. SIGNAL must be a string, element of the list returned by `dbus-introspect-get-signal-names'. The resulting \"signal\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'signal))) - (while (and elt - (not (string-equal - signal (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'signal signal)) (defun dbus-introspect-get-property-names (bus service path interface) "Return a list of strings of all property names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'property) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'property)) (defun dbus-introspect-get-property (bus service path interface property) "Return PROPERTY of INTERFACE as an XML object. @@ -1325,15 +1295,9 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. PROPERTY must be a string and a member of the list returned by `dbus-introspect-get-property-names'. The resulting PROPERTY object can contain \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'property))) - (while (and elt - (not (string-equal - property - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'property property)) (defun dbus-introspect-get-annotation-names (bus service path interface &optional name) @@ -1341,15 +1305,13 @@ object can contain \"annotation\" children." If NAME is nil, the annotations are children of INTERFACE, otherwise NAME must be a \"method\", \"signal\", or \"property\" object, where the annotations belong to." - (let ((object - (if name - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name) - (dbus-introspect-get-property bus service path interface name)) - (dbus-introspect-get-interface bus service path interface))) - result) - (dolist (elt (xml-get-children object 'annotation) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation)) (defun dbus-introspect-get-annotation (bus service path interface name annotation) @@ -1357,22 +1319,13 @@ object, where the annotations belong to." If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise NAME must be the name of a \"method\", \"signal\", or \"property\" object, where the ANNOTATION belongs to." - (let ((elt (xml-get-children - (if name - (or (dbus-introspect-get-method - bus service path interface name) - (dbus-introspect-get-signal - bus service path interface name) - (dbus-introspect-get-property - bus service path interface name)) - (dbus-introspect-get-interface bus service path interface)) - 'annotation))) - (while (and elt - (not (string-equal - annotation - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation annotation)) (defun dbus-introspect-get-argument-names (bus service path interface name) "Return a list of all argument names as a list of strings. @@ -1380,27 +1333,20 @@ NAME must be a \"method\" or \"signal\" object. Argument names are optional, the function can return nil therefore, even if the method or signal has arguments." - (let ((object - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name))) - result) - (dolist (elt (xml-get-children object 'arg) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg)) (defun dbus-introspect-get-argument (bus service path interface name arg) "Return argument ARG as XML object. NAME must be a \"method\" or \"signal\" object. ARG must be a string and a member of the list returned by `dbus-introspect-get-argument-names'." - (let ((elt (xml-get-children - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name)) - 'arg))) - (while (and elt - (not (string-equal - arg (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg arg)) (defun dbus-introspect-get-signature (bus service path interface name &optional direction) @@ -1469,13 +1415,10 @@ name of the property, and its value. If there are no properties, nil is returned." (dbus-ignore-errors ;; "GetAll" returns "a{sv}". - (let (result) - (dolist (dict - (dbus-call-method - bus service path dbus-interface-properties - "GetAll" :timeout 500 interface) - (nreverse result)) - (push (cons (car dict) (cl-caadr dict)) result))))) + (mapcar (lambda (dict) + (cons (car dict) (caadr dict))) + (dbus-call-method bus service path dbus-interface-properties + "GetAll" :timeout 500 interface)))) (defun dbus-register-property (bus service path interface property access value @@ -1520,13 +1463,13 @@ clients from discovering the still incomplete interface." ;; Add handlers for the three property-related methods. (dbus-register-method bus service path dbus-interface-properties "Get" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "GetAll" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "Set" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) ;; Register SERVICE. (unless (or dont-register-service (member service (dbus-list-names bus))) @@ -1673,7 +1616,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." (if (cadr entry2) ;; "sv". (dolist (entry3 (cadr entry2)) - (setcdr entry3 (cl-caadr entry3))) + (setcdr entry3 (caadr entry3))) (setcdr entry2 nil))))) ;; Fallback: collect the information. Slooow! @@ -1730,7 +1673,7 @@ It will be registered for all objects created by `dbus-register-service'." (append (butlast last-input-event 4) (list object dbus-interface-properties - "GetAll" 'dbus-property-handler)))) + "GetAll" #'dbus-property-handler)))) (dbus-property-handler interface)))) (cdr (assoc object result))))))))) dbus-registered-objects-table) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index 852d8ae0491..f36999119f2 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -1,4 +1,4 @@ -;;; dig.el --- Domain Name System dig interface +;;; dig.el --- Domain Name System dig interface -*- lexical-binding:t -*- ;; Copyright (C) 2000-2020 Free Software Foundation, Inc. @@ -42,15 +42,13 @@ (defcustom dig-program "dig" "Name of dig (domain information groper) binary." - :type 'file - :group 'dig) + :type 'file) (defcustom dig-dns-server nil "DNS server to query. If nil, use system defaults." :type '(choice (const :tag "System defaults") - string) - :group 'dig) + string)) (defcustom dig-font-lock-keywords '(("^;; [A-Z]+ SECTION:" 0 font-lock-keyword-face) @@ -58,8 +56,7 @@ If nil, use system defaults." ("^; <<>>.*" 0 font-lock-type-face) ("^;.*" 0 font-lock-function-name-face)) "Default expressions to highlight in dig mode." - :type 'sexp - :group 'dig) + :type 'sexp) (defun dig-invoke (domain &optional query-type query-class query-option diff --git a/lisp/net/dns.el b/lisp/net/dns.el index cefe0851f03..53ea0b19b52 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -138,7 +138,7 @@ updated. Set this variable to t to disable the check.") (defun dns-write (spec &optional tcp-p) "Write a DNS packet according to SPEC. -If TCP-P, the first two bytes of the package with be the length field." +If TCP-P, the first two bytes of the packet will be the length field." (with-temp-buffer (set-buffer-multibyte nil) (dns-write-bytes (dns-get 'id spec) 2) @@ -189,13 +189,15 @@ If TCP-P, the first two bytes of the package with be the length field." (dns-write-bytes (buffer-size) 2)) (buffer-string))) -(defun dns-read (packet) +(defun dns-read (packet &optional tcp-p) (with-temp-buffer (set-buffer-multibyte nil) (let ((spec nil) queries answers authorities additionals) (insert packet) - (goto-char (point-min)) + ;; When using TCP we have a 2 byte length field to ignore. + (goto-char (+ (point-min) + (if tcp-p 2 0))) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t)) @@ -258,10 +260,8 @@ If TCP-P, the first two bytes of the package with be the length field." (nreverse spec)))) (defun dns-read-int32 () - ;; Full 32 bit Integers can't be handled by 32-bit Emacsen. If we - ;; use floats, it works. - (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) - (dns-read-bytes 3)))) + (declare (obsolete nil "28.1")) + (number-to-string (dns-read-bytes 4))) (defun dns-read-type (string type) (let ((buffer (current-buffer)) @@ -286,11 +286,11 @@ If TCP-P, the first two bytes of the package with be the length field." ((eq type 'SOA) (list (list 'mname (dns-read-name buffer)) (list 'rname (dns-read-name buffer)) - (list 'serial (dns-read-int32)) - (list 'refresh (dns-read-int32)) - (list 'retry (dns-read-int32)) - (list 'expire (dns-read-int32)) - (list 'minimum (dns-read-int32)))) + (list 'serial (dns-read-bytes 4)) + (list 'refresh (dns-read-bytes 4)) + (list 'retry (dns-read-bytes 4)) + (list 'expire (dns-read-bytes 4)) + (list 'minimum (dns-read-bytes 4)))) ((eq type 'SRV) (list (list 'priority (dns-read-bytes 2)) (list 'weight (dns-read-bytes 2)) @@ -317,8 +317,8 @@ If TCP-P, the first two bytes of the package with be the length field." (defun dns-set-servers () "Set `dns-servers' to a list of DNS servers or nil if none are found. Parses \"/etc/resolv.conf\" or calls \"nslookup\"." + (setq dns-servers nil) (or (when (file-exists-p "/etc/resolv.conf") - (setq dns-servers nil) (with-temp-buffer (insert-file-contents "/etc/resolv.conf") (goto-char (point-min)) @@ -329,9 +329,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (with-temp-buffer (call-process "nslookup" nil t nil "localhost") (goto-char (point-min)) - (re-search-forward - "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) - (setq dns-servers (list (match-string 1)))))) + (when (re-search-forward + "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\|[[:xdigit:]:]*\\)" nil t) + (setq dns-servers (list (match-string 1))))))) (when (fboundp 'network-interface-list) (setq dns-servers-valid-for-interfaces (network-interface-list)))) @@ -359,7 +359,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." `(let ((server ,server) (coding-system-for-read 'binary) (coding-system-for-write 'binary)) - (if (fboundp 'make-network-process) + (if (and + (fboundp 'make-network-process) + (featurep 'make-network-process '(:type datagram))) (make-network-process :name "dns" :coding 'binary @@ -367,9 +369,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." :host server :service "domain" :type 'datagram) - ;; Older versions of Emacs doesn't have - ;; `make-network-process', so we fall back on opening a TCP - ;; connection to the DNS server. + ;; Older versions of Emacs do not have `make-network-process', + ;; and on MS-Windows datagram sockets are not supported, so we + ;; fall back on opening a TCP connection to the DNS server. (open-network-stream "dns" (current-buffer) server "domain")))) (defvar dns-cache (make-vector 4096 0)) @@ -402,26 +404,30 @@ If REVERSEP, look up an IP address." type 'PTR)) (if (not dns-servers) - (message "No DNS server configuration found") + (progn + (message "No DNS server configuration found") + nil) (with-temp-buffer (set-buffer-multibyte nil) - (let ((process (condition-case () - (dns-make-network-process (car dns-servers)) - (error - (message - "dns: Got an error while trying to talk to %s" - (car dns-servers)) - nil))) + (let* ((process (condition-case () + (dns-make-network-process (car dns-servers)) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) (step 100) (times (* dns-timeout 1000)) - (id (random 65000))) + (id (random 65000)) + (tcp-p (and process (not (process-contact process :type))))) (when process (process-send-string process (dns-write `((id ,id) (opcode query) (queries ((,name (type ,type)))) - (recursion-desired-p t)))) + (recursion-desired-p t)) + tcp-p)) (while (and (zerop (buffer-size)) (> times 0)) (let ((step-sec (/ step 1000.0))) @@ -434,7 +440,7 @@ If REVERSEP, look up an IP address." (when (and (>= (buffer-size) 2) ;; We had a time-out. (> times 0)) - (let ((result (dns-read (buffer-string)))) + (let ((result (dns-read (buffer-string) tcp-p))) (if fullp result (let ((answer (car (dns-get 'answers result)))) diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el new file mode 100644 index 00000000000..f258d5cb9fb --- /dev/null +++ b/lisp/net/eudcb-macos-contacts.el @@ -0,0 +1,118 @@ +;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend + +;; Copyright (C) 2020 condition-alpha.com + +;; This program 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. +;; +;; This program 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 this program. 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..edb2f729c8b 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,13 +277,17 @@ This list can be customized via `eww-suggest-uris'." (nreverse uris))) ;;;###autoload -(defun eww (url &optional arg) +(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" @@ -307,8 +325,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 +383,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 +409,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 +577,10 @@ Currently this means either text/html or application/xhtml+xml." (goto-char point)) (shr-target-id (goto-char (point-min)) - (let ((point (next-single-property-change - (point-min) 'shr-target-id))) - (when point - (goto-char point)))) + (let ((match (text-property-search-forward + 'shr-target-id shr-target-id t))) + (when match + (goto-char (prop-match-beginning match))))) (t (goto-char (point-min)) ;; Don't leave point inside forms, because the normal eww @@ -1011,7 +1047,7 @@ just re-display the HTML already fetched." (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render + (url-retrieve url #'eww-render (list url (point) (current-buffer) encode)))))) ;; Form support. @@ -1111,11 +1147,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 +1294,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) @@ -1572,8 +1610,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 +1646,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 +1778,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 +1869,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 +1888,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 +2171,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/hmac-md5.el b/lisp/net/hmac-md5.el index 92efb6ba275..974ee0d3691 100644 --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -1,4 +1,4 @@ -;;; hmac-md5.el --- Compute HMAC-MD5. +;;; hmac-md5.el --- Compute HMAC-MD5. -*- lexical-binding:t -*- ;; Copyright (C) 1999, 2001, 2007-2020 Free Software Foundation, Inc. @@ -22,42 +22,8 @@ ;;; Commentary: -;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". -;; -;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) -;; => "9294727a3638bb1c13f48ef8158bfc9d" -;; -;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) -;; => "750c783e6ab0b503eaa86e310a5db738" -;; -;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) -;; => "56be34521d144c88dbb8c733f0e8b3f6" -;; -;; (encode-hex-string -;; (hmac-md5 -;; (make-string 50 ?\xcd) -;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) -;; => "697eaf0aca3a3aea3a75164746ffaa79" -;; -;; (encode-hex-string -;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995690efd4c" -;; -;; (encode-hex-string -;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key - Hash Key First" -;; (make-string 80 ?\xaa))) -;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" -;; (make-string 80 ?\xaa))) -;; => "6f630fad67cda0ee1fb1f562db3aa53e" +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1", +;; moved to lisp/test/net/hmac-md5-tests.el ;;; Code: diff --git a/lisp/net/imap.el b/lisp/net/imap.el index aa10f0291fd..a492dc8c798 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -136,7 +136,6 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -(require 'format-spec) (require 'utf7) (require 'rfc2104) ;; Hmm... digest-md5 is not part of Emacs. @@ -517,12 +516,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -583,12 +579,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -701,13 +694,10 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?g imap-shell-host - ?p (number-to-string port) - ?l imap-default-user))))) + (format-spec cmd `((?s . ,server) + (?g . ,imap-shell-host) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user)))))) (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index e42a7655ef3..700653250fb 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -727,7 +727,7 @@ an alist of attribute/value pairs." (setq record nil) (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) - (1+ numres)) + (setq numres (1+ numres))) (message "Parsing results... done") (nreverse result))))) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index e99d7a372c0..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/nsm.el b/lisp/net/nsm.el index e94947bc7f1..cc22427e6d1 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -311,9 +311,9 @@ See also: `network-security-protocol-checks' and `nsm-noninteractive'" (map-values results) "\n") "\n") - "\n* "))))) - (delete-process process) - (setq process nil))) + "\n* ")))))) + (delete-process process) + (setq process nil)) (run-hook-with-args 'nsm-tls-post-check-functions host port status settings results))) process) @@ -371,7 +371,7 @@ Reference: Sheffer, Holz, Saint-Andre (May 2015). \"Recommendations for Secure Use of Transport Layer Security (TLS) and Datagram Transport Layer Security (DTLS)\", \"(4.1. General Guidelines)\" -`https://tools.ietf.org/html/rfc7525\#section-4.1'" +`https://tools.ietf.org/html/rfc7525#section-4.1'" (let ((kx (plist-get status :key-exchange))) (and (string-match "^\\bRSA\\b" kx) (format-message @@ -468,7 +468,7 @@ Reference: GnuTLS authors (2018). \"GnuTLS Manual 4.3.3 Anonymous authentication\", -`https://www.gnutls.org/manual/gnutls.html\#Anonymous-authentication'" +`https://www.gnutls.org/manual/gnutls.html#Anonymous-authentication'" (let ((kx (plist-get status :key-exchange))) (and (string-match "\\bANON\\b" kx) (format-message @@ -603,7 +603,7 @@ References: full SHA-1\", `https://shattered.io/static/shattered.pdf' [2]: Chromium Security Education TLS/SSL. \"Deprecated and Removed Features (SHA-1 Certificate Signatures)\", -`https://www.chromium.org/Home/chromium-security/education/tls\#TOC-SHA-1-Certificate-Signatures' +`https://www.chromium.org/Home/chromium-security/education/tls#TOC-SHA-1-Certificate-Signatures' [3]: Jones J.C (2017). \"The end of SHA-1 on the Public Web\", `https://blog.mozilla.org/security/2017/02/23/the-end-of-sha-1-on-the-public-web/' [4]: Apple Support (2017). \"Move to SHA-256 signed certificates to @@ -964,6 +964,7 @@ protocol." (defun nsm-write-settings () (with-temp-file nsm-settings-file + (insert ";;;; -*- mode: lisp-data -*-\n") (insert "(\n") (dolist (setting nsm-permanent-host-settings) (insert " ") diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 60a6c12e6c7..cc406076c58 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -1,4 +1,4 @@ -;;; puny.el --- translate non-ASCII domain names to ASCII +;;; puny.el --- translate non-ASCII domain names to ASCII -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. @@ -35,7 +35,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." ;; The vast majority of domain names are not IDNA domain names, so ;; add a check first to avoid doing unnecessary work. - (if (string-match "\\'[[:ascii:]]+\\'" domain) + (if (string-match "\\`[[:ascii:]]+\\'" domain) domain (mapconcat 'puny-encode-string (split-string domain "[.]") "."))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index fff640bb675..1766e192f2d 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -254,7 +254,7 @@ Examples: (\"bitlbee\" bitlbee \"robert\" \"sekrit\") (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))" - :type '(alist :key-type (string :tag "Server") + :type '(alist :key-type (regexp :tag "Server") :value-type (choice (list :tag "NickServ" (const nickserv) (string :tag "Nick") @@ -359,9 +359,9 @@ If VAL is a coding system, it is used for both decoding and encoding messages. If VAL is a cons of coding systems, the car part is used for decoding, and the cdr part is used for encoding." - :type '(alist :key-type (choice (string :tag "Channel Regexp") - (cons (string :tag "Channel Regexp") - (string :tag "Server Regexp"))) + :type '(alist :key-type (choice (regexp :tag "Channel Regexp") + (cons (regexp :tag "Channel Regexp") + (regexp :tag "Server Regexp"))) :value-type (choice coding-system (cons (coding-system :tag "Decode") (coding-system :tag "Encode"))))) @@ -2421,7 +2421,7 @@ keywords when no KEYWORD is given." (concat "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "[" chars "]" "\\|" "[" chars punct "]+" "[" chars "]" "\\)")) @@ -2626,12 +2626,16 @@ the only argument." (and ;; nickserv (string= sender "NickServ") (string= target rcirc-nick) - (member message - (list - (format "You are now identified for \C-b%s\C-b." rcirc-nick) - (format "You are successfully identified as \C-b%s\C-b." rcirc-nick) - "Password accepted - you are now recognized." - ))) + (cl-member + message + (list + (format "You are now identified for \C-b%s\C-b." rcirc-nick) + (format "You are successfully identified as \C-b%s\C-b." + rcirc-nick) + "Password accepted - you are now recognized.") + ;; The nick may have a different case, so match + ;; case-insensitively (Bug#39345). + :test #'cl-equalp)) (and ;; quakenet (string= sender "Q") (string= target rcirc-nick) diff --git a/lisp/net/sasl-scram-sha256.el b/lisp/net/sasl-scram-sha256.el new file mode 100644 index 00000000000..e50a032c233 --- /dev/null +++ b/lisp/net/sasl-scram-sha256.el @@ -0,0 +1,59 @@ +;;; sasl-scram-sha256.el --- SCRAM-SHA-256 module for the SASL client framework -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> +;; Package: sasl + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Implement the SCRAM-SHA-256 mechanism from RFC 7677. + +;;; Code: + +(require 'cl-lib) +(require 'sasl) +(require 'hex-util) +(require 'rfc2104) +(require 'sasl-scram-rfc) + +;;; SCRAM-SHA-256 + +(defconst sasl-scram-sha-256-steps + '(sasl-scram-client-first-message + sasl-scram-sha-256-client-final-message + sasl-scram-sha-256-authenticate-server)) + +(defun sasl-scram-sha256 (object &optional start end binary) + (secure-hash 'sha256 object start end binary)) + +(defun sasl-scram-sha-256-client-final-message (client step) + (sasl-scram--client-final-message + ;; HMAC-SHA256 uses block length 64 and hash length 32; see RFC 4634. + 'sasl-scram-sha256 64 32 client step)) + +(defun sasl-scram-sha-256-authenticate-server (client step) + (sasl-scram--authenticate-server + 'sasl-scram-sha256 64 32 client step)) + +(put 'sasl-scram-sha256 'sasl-mechanism + (sasl-make-mechanism "SCRAM-SHA-256" sasl-scram-sha-256-steps)) + +(provide 'sasl-scram-sha256) + +;;; sasl-scram-sha256.el ends here diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index 4405c904cd3..ab118e1f982 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -35,8 +35,8 @@ ;;; Code: (defvar sasl-mechanisms - '("SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" - "NTLM")) + '("SCRAM-SHA-256" "SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" + "ANONYMOUS" "NTLM")) (defvar sasl-mechanism-alist '(("CRAM-MD5" sasl-cram) @@ -45,6 +45,7 @@ ("LOGIN" sasl-login) ("ANONYMOUS" sasl-anonymous) ("NTLM" sasl-ntlm) + ("SCRAM-SHA-256" sasl-scram-sha256) ("SCRAM-SHA-1" sasl-scram-rfc))) (defvar sasl-unique-id-function #'sasl-unique-id-function) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 241180d471a..ddd81127213 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,9 +750,10 @@ size, and full-buffer size." (let ((gap-start (point)) (face (get-text-property (point) 'face))) ;; Extend the background to the end of the line. - (if face - (insert (propertize "\n" 'face (shr-face-background face))) - (insert "\n")) + (insert ?\n) + (when face + (put-text-property (1- (point)) (point) + 'face (shr-face-background face))) (shr-indent) (when (and (> (1- gap-start) (point-min)) (get-text-property (point) 'shr-url) @@ -838,7 +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. @@ -1230,7 +1244,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 +1279,9 @@ START, and END. Note that START and END should be markers." (format "%s (%s)" iri title) iri)) 'follow-link t - 'mouse-face 'highlight)) + ;; Make separate regions not `eq' so that they'll get + ;; separate mouse highlights. + 'mouse-face (list 'highlight))) ;; Don't overwrite any keymaps that are already in the buffer (i.e., ;; image keymaps). (while (and start @@ -1438,7 +1454,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 +1511,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 +1692,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 +2019,11 @@ BASE is the URL of the HTML being rendered." (cond ((null tbodies) dom) - ((= (length tbodies) 1) + ((null (cdr tbodies)) (car tbodies)) (t ;; Table with multiple tbodies. Convert into a single tbody. - `(tbody nil ,@(cl-reduce 'append - (mapcar 'dom-non-text-children tbodies))))))) + `(tbody nil ,@(mapcan #'dom-non-text-children tbodies)))))) (defun shr--fix-tbody (tbody) (nconc (list 'tbody (dom-attributes tbody)) @@ -2309,8 +2323,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 +2599,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/tramp-adb.el b/lisp/net/tramp-adb.el index 5cfcb81708f..c1eb36e3405 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -55,15 +55,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 @@ -73,7 +85,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.") @@ -136,7 +149,7 @@ It is used for TCP/IP devices." (file-selinux-context . tramp-handle-file-selinux-context) (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-adb-handle-file-system-info) - (file-truename . tramp-adb-handle-file-truename) + (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -160,6 +173,8 @@ It is used for TCP/IP devices." (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -181,10 +196,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 @@ -214,11 +228,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))) @@ -228,105 +241,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)) @@ -370,7 +284,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 @@ -449,21 +365,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: @@ -473,10 +374,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. @@ -587,9 +494,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)) @@ -631,9 +539,6 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -645,11 +550,15 @@ 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))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -667,13 +576,16 @@ But handle the case, if the \"test\" command is not available." (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) -(defun tramp-adb-handle-set-file-modes (filename mode) +(defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) + ;; ADB shell does not support "chmod -h". + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (tramp-adb-send-command-and-check + v (format "chmod %o %s" mode (tramp-shell-quote-argument localname)))))) -(defun tramp-adb-handle-set-file-times (filename &optional time) +(defun tramp-adb-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -682,21 +594,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 @@ -719,14 +633,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter v 0 (format "Copying %s to %s" filename newname) (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. @@ -739,46 +653,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) @@ -801,7 +714,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -809,8 +722,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v l1) @@ -846,7 +759,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -877,8 +790,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -895,14 +807,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; it. Call it in a subshell, in order to preserve working ;; directory. (condition-case nil - (progn - (setq ret - (if (tramp-adb-send-command-and-check - v - (format "(cd %s; %s)" - (tramp-shell-quote-argument localname) command)) - ;; Set return status accordingly. - 0 1)) + (unwind-protect + (setq ret (tramp-adb-send-command-and-check + v (format + "(cd %s; %s)" + (tramp-shell-quote-argument localname) command) + t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -918,6 +829,12 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (> ret 128)) + (setq ret (nth (- ret 128) (tramp-get-signal-strings)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -936,6 +853,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-adb-handle-make-process (&rest args) "Like `make-process' for Tramp files." (when args @@ -969,17 +888,29 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) (command - (format "cd %s && exec %s" + (format "cd %s && exec %s %s" (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) (tramp-process-connection-type @@ -1029,6 +960,18 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Read initial output. Remove the first line, ;; which is the command echo. (while @@ -1037,6 +980,23 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (not (re-search-forward "[\n]" nil t))) (tramp-accept-process-output p 0)) (delete-region (point-min) (point)) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the process + ;; is deleted. The temporary file will exist + ;; until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) ;; Return process. p)))) @@ -1053,7 +1013,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `exec-path' for Tramp files." (append (with-parsed-tramp-file-name default-directory nil - (with-tramp-connection-property v "remote-path" + (with-tramp-connection-property (tramp-get-process v) "remote-path" (tramp-adb-send-command v "echo \\\"$PATH\\\"") (split-string (with-current-buffer (tramp-get-connection-buffer v) @@ -1062,17 +1022,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (read (current-buffer))) ":" 'omit))) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" a host name \"R38273882DE\" returns \"R38273882DE\"." - ;; Sometimes this is called before there is a connection process - ;; yet. In order to work with the connection cache, we flush all - ;; unwanted entries first. - (tramp-flush-connection-properties nil) - (with-tramp-connection-property (tramp-get-connection-process vec) "device" + (with-tramp-connection-property (tramp-get-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) @@ -1090,10 +1046,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. @@ -1103,18 +1059,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. @@ -1126,42 +1082,52 @@ 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) +(defun tramp-adb-send-command-and-check (vec command &optional exit-status) "Run COMMAND and check its exit status. Sends `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just sends `echo $?'. Returns nil if -the exit status is not equal 0, and t otherwise." +the exit status is not equal 0, and t otherwise. + +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-adb-send-command vec (if command (format "%s; echo tramp_exit_status $?" command) "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 "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) @@ -1263,7 +1229,11 @@ connection if a previous connection has died for some reason." ;; 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 @@ -1287,7 +1257,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))) @@ -1321,4 +1292,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 b9bf6180a5d..9502cc35300 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -109,7 +109,7 @@ (eval-when-compile (require 'cl-lib)) ;; Sometimes, compilation fails with "Variable binding depth exceeds -;; max-specpdl-size". +;; max-specpdl-size". Shall be fixed in Emacs 27. (eval-and-compile (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) @@ -279,7 +279,9 @@ It must be supported by libarchive(3).") (start-file-process . tramp-archive-handle-not-implemented) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-archive-handle-temporary-file-directory) - ;; `tramp-set-file-uid-gid' performed by default handler. + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -318,7 +320,10 @@ arguments to pass to the OPERATION." (let* ((filename (apply #'tramp-archive-file-name-for-operation operation args)) - (archive (tramp-archive-file-name-archive filename))) + (archive (tramp-archive-file-name-archive filename)) + ;; Sometimes, it fails with "Variable binding depth exceeds + ;; max-specpdl-size". Shall be fixed in Emacs 27. + (max-specpdl-size (* 2 max-specpdl-size))) ;; `filename' could be a quoted file name. Or the file ;; archive could be a directory, see Bug#30293. @@ -350,7 +355,7 @@ arguments to pass to the OPERATION." (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) - (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))) + (put #'tramp-archive-autoload-file-name-handler 'safe-magic t)))) ;;;###autoload (progn @@ -366,7 +371,7 @@ arguments to pass to the OPERATION." (tramp-register-archive-file-name-handler) ;; Mark `operations' the handler is responsible for. -(put 'tramp-archive-file-name-handler 'operations +(put #'tramp-archive-file-name-handler 'operations (mapcar #'car tramp-archive-file-name-handler-alist)) ;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. @@ -517,13 +522,16 @@ offered." (declare (debug (form symbolp body)) (indent 2)) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(cons - 'archive - (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cons + 'archive + (delete + 'hop + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))))) `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 62e25fa1f08..970e2eea0ac 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -31,13 +31,13 @@ ;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; -;; - localname is NIL. This are reusable properties. Examples: +;; - localname is nil. These are reusable properties. Examples: ;; "remote-shell" identifies the POSIX shell to be called on the ;; remote host, or "perl" is the command to be called on the remote ;; host when starting a Perl script. These properties are saved in ;; the file `tramp-persistency-file-name'. ;; -;; - localname is a string. This are temporary properties, which are +;; - localname is a string. These are temporary properties, which are ;; related to the file localname is referring to. Examples: ;; "file-exists-p" is t or nil, depending on the file existence, or ;; "file-attributes" caches the result of the function @@ -45,21 +45,32 @@ ;; expire after `remote-file-name-inhibit-cache' seconds if this ;; variable is set. ;; -;; - The key is a process. This are temporary properties related to +;; - The key is a process. These are temporary properties related to ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. ;; -;; - The key is nil. This are temporary properties related to the +;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep ;; the results of parsing "/etc/passwd" and "/etc/group", ;; "{uid,gid}-{integer,string}" are the local uid and gid, and ;; "locale" is the used shell locale. +;; +;; - The key is `tramp-cache-undefined'. All functions return the +;; expected values, but nothing is cached. ;; Some properties are handled special: ;; ;; - "process-name", "process-buffer" and "first-password-request" are -;; not saved in the file `tramp-persistency-file-name'. +;; not saved in the file `tramp-persistency-file-name', although +;; being connection properties related to a `tramp-file-name' +;; structure. +;; +;; - Reusable properties, which should not be saved, are kept in the +;; process key retrieved by `tramp-get-process' (the main connection +;; process). Other processes could reuse these properties, avoiding +;; recomputation when a new asynchronous process is created by +;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el). ;;; Code: @@ -96,25 +107,31 @@ details see the info pages." (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload +(defconst tramp-cache-undefined 'undef + "The symbol marking undefined hash keys and values.") + (defun tramp-get-hash-table (key) "Return the hash table for KEY. If it doesn't exist yet, it is created and initialized with -matching entries of `tramp-connection-properties'." - (or (gethash key tramp-cache-data) - (let ((hash - (puthash key (make-hash-table :test #'equal) tramp-cache-data))) - (when (tramp-file-name-p key) - (dolist (elt tramp-connection-properties) - (when (string-match-p - (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) - (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) - hash))) +matching entries of `tramp-connection-properties'. +If KEY is `tramp-cache-undefined', don't create anything, and return nil." + (unless (eq key tramp-cache-undefined) + (or (gethash key tramp-cache-data) + (let ((hash + (puthash key (make-hash-table :test #'equal) tramp-cache-data))) + (when (tramp-file-name-p key) + (dolist (elt tramp-connection-properties) + (when (string-match-p + (or (nth 0 elt) "") + (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) + hash)))) ;;;###tramp-autoload (defun tramp-get-file-property (key file property default) "Get the PROPERTY of FILE from the cache context of KEY. -Returns DEFAULT if not set." +Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -122,31 +139,32 @@ Returns DEFAULT if not set." (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let* ((hash (tramp-get-hash-table key)) - (value (when (hash-table-p hash) (gethash property hash)))) - (if ;; We take the value only if there is any, and - ;; `remote-file-name-inhibit-cache' indicates that it is still - ;; valid. Otherwise, DEFAULT is set. - (and (consp value) + (cached (and (hash-table-p hash) (gethash property hash))) + (cached-at (and (consp cached) (format-time-string "%T" (car cached)))) + (value default) + cache-used) + + (when ;; We take the value only if there is any, and + ;; `remote-file-name-inhibit-cache' indicates that it is + ;; still valid. Otherwise, DEFAULT is set. + (and (consp cached) (or (null remote-file-name-inhibit-cache) (and (integerp remote-file-name-inhibit-cache) (time-less-p - ;; `current-time' can be nil once we get rid of Emacs 24. - (current-time) - (time-add - (car value) - ;; `seconds-to-time' can be removed once we get - ;; rid of Emacs 24. - (seconds-to-time remote-file-name-inhibit-cache)))) + nil + (time-add (car cached) remote-file-name-inhibit-cache))) (and (consp remote-file-name-inhibit-cache) (time-less-p - remote-file-name-inhibit-cache (car value))))) - (setq value (cdr value)) - (setq value default)) + remote-file-name-inhibit-cache (car cached))))) + (setq value (cdr cached) + cache-used t)) - (tramp-message key 8 "%s %s %s" file property value) + (tramp-message + key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" + file property value remote-file-name-inhibit-cache cache-used cached-at) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -157,7 +175,7 @@ Returns DEFAULT if not set." ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. -Returns VALUE." +Return VALUE." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -170,7 +188,7 @@ Returns VALUE." (tramp-message key 8 "%s %s %s" file property value) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -202,13 +220,11 @@ Returns VALUE." key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) file (tramp-file-name-hop key) nil) - (maphash - (lambda (property _value) - (when (string-match-p - "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" - property) - (tramp-flush-file-property key file property))) - (tramp-get-hash-table key))))) + (dolist (property (hash-table-keys (tramp-get-hash-table key))) + (when (string-match-p + "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" + property) + (tramp-flush-file-property key file property)))))) ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) @@ -239,14 +255,12 @@ Remove also properties of all files in subdirectories." #'directory-file-name (list directory))) (truename (tramp-get-file-property key directory "file-truename" nil))) (tramp-message key 8 "%s" directory) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) - (remhash key tramp-cache-data))) - tramp-cache-data) + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (tramp-file-name-p key) + (stringp (tramp-file-name-localname key)) + (string-match-p (regexp-quote directory) + (tramp-file-name-localname key))) + (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) @@ -292,8 +306,9 @@ This is suppressed for temporary buffers." "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. If the -value is not set for the connection, returns DEFAULT." +used to cache connection properties of the local machine. +If KEY is `tramp-cache-undefined', or if the value is not set for +the connection, return DEFAULT." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) @@ -301,15 +316,19 @@ value is not set for the connection, returns DEFAULT." (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) (let* ((hash (tramp-get-hash-table key)) - (value - ;; If the key is an auxiliary process object, check whether - ;; the process is still alive. - (if (and (processp key) (not (process-live-p key))) - default - (if (hash-table-p hash) - (gethash property hash default) - default)))) - (tramp-message key 7 "%s %s" property value) + (cached (if (hash-table-p hash) + (gethash property hash tramp-cache-undefined) + tramp-cache-undefined)) + (value default) + cache-used) + + (when (and (not (eq cached tramp-cache-undefined)) + ;; If the key is an auxiliary process object, check + ;; whether the process is still alive. + (not (and (processp key) (not (process-live-p key))))) + (setq value cached + cache-used t)) + (tramp-message key 7 "%s %s; cache used: %s" property value cache-used) value)) ;;;###tramp-autoload @@ -317,19 +336,22 @@ value is not set for the connection, returns DEFAULT." "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. -PROPERTY is set persistent when KEY is a `tramp-file-name' structure." +used to cache connection properties of the local machine. If KEY +is `tramp-cache-undefined', nothing is set. +PROPERTY is set persistent when KEY is a `tramp-file-name' structure. +Return VALUE." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (let ((hash (tramp-get-hash-table key))) - (puthash property value hash) - (setq tramp-cache-data-changed t) - (tramp-message key 7 "%s %s" property value) - value)) + (when-let ((hash (tramp-get-hash-table key))) + (puthash property value hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) + (tramp-message key 7 "%s %s" property value) + value) ;;;###tramp-autoload (defun tramp-connection-property-p (key property) @@ -337,7 +359,8 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is used to cache connection properties of the local machine." - (not (eq (tramp-get-connection-property key property 'undef) 'undef))) + (not (eq (tramp-get-connection-property key property tramp-cache-undefined) + tramp-cache-undefined))) ;;;###tramp-autoload (defun tramp-flush-connection-property (key property) @@ -352,8 +375,10 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (remhash property (tramp-get-hash-table key)) - (setq tramp-cache-data-changed t) + (when-let ((hash (tramp-get-hash-table key))) + (remhash property hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) (tramp-message key 7 "%s" property)) ;;;###tramp-autoload @@ -370,12 +395,10 @@ used to cache connection properties of the local machine." (tramp-file-name-hop key) nil)) (tramp-message key 7 "%s %s" key - (let ((hash (gethash key tramp-cache-data)) - properties) - (when (hash-table-p hash) - (maphash (lambda (x _y) (push x properties)) hash)) - properties)) - (setq tramp-cache-data-changed t) + (when-let ((hash (gethash key tramp-cache-data))) + (hash-table-keys hash))) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) (remhash key tramp-cache-data)) ;;;###tramp-autoload @@ -386,20 +409,15 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) ;; Remove text properties from KEY and VALUE. - ;; `cl-struct-slot-*' functions exist since Emacs 25 only; we - ;; ignore errors. (when (tramp-file-name-p key) - ;; (dolist - ;; (slot - ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) - ;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) - ;; (setf (cl-struct-slot-value 'tramp-file-name slot key) - ;; (substring-no-properties - ;; (cl-struct-slot-value 'tramp-file-name slot key)))))) - (dotimes (i (length key)) - (when (stringp (elt key i)) - (setf (elt key i) (substring-no-properties (elt key i)))))) - (when (stringp key) + (dolist + (slot + (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) + (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) + (setf (cl-struct-slot-value 'tramp-file-name slot key) + (substring-no-properties + (cl-struct-slot-value 'tramp-file-name slot key)))))) + (when (stringp key) (setq key (substring-no-properties key))) (when (stringp value) (setq value (substring-no-properties value))) @@ -421,18 +439,18 @@ used to cache connection properties of the local machine." ;;;###tramp-autoload (defun tramp-list-connections () "Return all known `tramp-file-name' structs according to `tramp-cache'." - (let (result tramp-verbose) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (null (tramp-file-name-localname key)) - (tramp-connection-property-p key "process-buffer")) - (push key result))) - tramp-cache-data) - result)) + (let ((tramp-verbose 0)) + (delq nil (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (null (tramp-file-name-localname key)) + (tramp-connection-property-p key "process-buffer") + key)) + (hash-table-keys tramp-cache-data))))) (defun tramp-dump-connection-properties () - "Write persistent connection properties into file `tramp-persistency-file-name'." + "Write persistent connection properties into file \ +`tramp-persistency-file-name'." ;; We shouldn't fail, otherwise Emacs might not be able to be closed. (ignore-errors (when (and (hash-table-p tramp-cache-data) @@ -464,15 +482,10 @@ used to cache connection properties of the local machine." ;; Dump it. (with-temp-file tramp-persistency-file-name (insert - ";; -*- emacs-lisp -*-" - ;; `time-stamp-string' might not exist in all Emacs flavors. - (condition-case nil - (progn - (format - " <%s %s>\n" - (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") - tramp-persistency-file-name)) - (error "\n")) + ;; Starting with Emacs 28, we could use `lisp-data'. + (format ";; -*- emacs-lisp -*- <%s %s>\n" + (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") + tramp-persistency-file-name) ";; Tramp connection history. Don't change this file.\n" ";; Run `M-x tramp-cleanup-all-connections' instead.\n\n" (with-output-to-string @@ -490,17 +503,14 @@ used to cache connection properties of the local machine." "Return a list of (user host) tuples allowed to access for METHOD. This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from connection history." - (let (res) - (maphash - (lambda (key _value) - (if (and (tramp-file-name-p key) - (string-equal method (tramp-file-name-method key)) - (not (tramp-file-name-localname key))) - (push (list (tramp-file-name-user key) - (tramp-file-name-host key)) - res))) - tramp-cache-data) - res)) + (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (string-equal method (tramp-file-name-method key)) + (not (tramp-file-name-localname key)) + (list (tramp-file-name-user key) + (tramp-file-name-host key)))) + (hash-table-keys tramp-cache-data))) ;; When "emacs -Q" has been called, both variables are nil. We do not ;; load the persistency file then, in order to have a clean test environment. @@ -514,7 +524,7 @@ for all methods. Resulting data are derived from connection history." tramp-cache-read-persistent-data) (condition-case err (with-temp-buffer - (insert-file-contents tramp-persistency-file-name) + (insert-file-contents-literally tramp-persistency-file-name) (let ((list (read (current-buffer))) (tramp-verbose 0) element key item) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 9d1025b9072..52cc186ecf7 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,15 +359,14 @@ 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.")) ;; Append local file name if none is specified. (when (string-equal (file-remote-p target) target) - (setq target (concat target (file-remote-p source 'localname)))) + (setq target (concat target (tramp-file-local-name source)))) ;; Make them directory names. (setq source (directory-file-name source) target (directory-file-name target)) @@ -557,11 +565,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 723b8cfa1e3..218594b551c 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,15 +23,15 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 27. This -;; package provides compatibility functions for Emacs 24, Emacs 25 and -;; Emacs 26. +;; Tramp's main Emacs version for development is Emacs 28. This +;; package provides compatibility functions for Emacs 25, Emacs 26 and +;; Emacs 27. ;;; Code: -;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not -;; autoloaded. So we declare it here in order to avoid recursive -;; load. This will be overwritten in tramp.el. +;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. +;; So we declare it here in order to avoid recursive load. This will +;; be overwritten in tramp.el. (defun tramp-unload-file-name-handlers () ".") (require 'auth-source) @@ -41,7 +41,9 @@ (require 'shell) (require 'subr-x) +;; `temporary-file-directory' as function is introduced with Emacs 26.1. (declare-function tramp-handle-temporary-file-directory "tramp") +(defvar tramp-temp-name-prefix) ;; For not existing functions, obsolete functions, or functions with a ;; changed argument list, there are compiler warnings. We want to @@ -51,6 +53,8 @@ `(when (functionp ,function) (with-no-warnings (funcall ,function ,@arguments)))) +(put #'tramp-compat-funcall 'tramp-suppress-trace t) + (defsubst tramp-compat-temporary-file-directory () "Return name of directory for temporary files. It is the default value of `temporary-file-directory'." @@ -58,15 +62,19 @@ It is the default value of `temporary-file-directory'." ;; into an infloop. (eval (car (get 'temporary-file-directory 'standard-value)))) +(defsubst tramp-compat-make-temp-name () + "Generate a local temporary file name (compat function)." + (make-temp-name + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) + (defsubst tramp-compat-make-temp-file (f &optional dir-flag) "Create a local temporary file (compat function). Add the extension of F, if existing." - (let* (file-name-handler-alist - (prefix (expand-file-name - (symbol-value 'tramp-temp-name-prefix) - (tramp-compat-temporary-file-directory))) - (extension (file-name-extension f t))) - (make-temp-file prefix dir-flag extension))) + (make-temp-file + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)) + dir-flag (file-name-extension f t))) ;; `temporary-file-directory' as function is introduced with Emacs 26.1. (defalias 'tramp-compat-temporary-file-directory-function @@ -74,31 +82,7 @@ Add the extension of F, if existing." #'temporary-file-directory #'tramp-handle-temporary-file-directory)) -(defun tramp-compat-process-running-p (process-name) - "Return t if system process PROCESS-NAME is running for `user-login-name'." - (when (stringp process-name) - (cond - ;; GNU Emacs 22 on w32. - ((fboundp 'w32-window-exists-p) - (tramp-compat-funcall 'w32-window-exists-p process-name process-name)) - - ;; GNU Emacs 23+. - ((and (fboundp 'list-system-processes) (fboundp 'process-attributes)) - (let (result) - (dolist (pid (tramp-compat-funcall 'list-system-processes) result) - (let ((attributes (process-attributes pid))) - (when (and (string-equal - (cdr (assoc 'user attributes)) (user-login-name)) - (let ((comm (cdr (assoc 'comm attributes)))) - ;; The returned command name could be truncated - ;; to 15 characters. Therefore, we cannot check - ;; for `string-equal'. - (and comm (string-match-p - (concat "^" (regexp-quote comm)) - process-name)))) - (setq result t))))))))) - -;; `file-attribute-*' are introduced in Emacs 25.1. +;; `file-attribute-*' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-attribute-type (if (fboundp 'file-attribute-type) @@ -180,31 +164,13 @@ and later, and is a float in Emacs 26 and earlier." This is a string of ten letters or dashes as in ls -l." (nth 8 attributes)))) -;; `format-message' is new in Emacs 25.1. -(unless (fboundp 'format-message) - (defalias 'format-message #'format)) - -;; `directory-name-p' is new in Emacs 25.1. -(defalias 'tramp-compat-directory-name-p - (if (fboundp 'directory-name-p) - #'directory-name-p - (lambda (name) - "Return non-nil if NAME ends with a directory separator character." - (let ((len (length name)) - (lastc ?.)) - (if (> len 0) - (setq lastc (aref name (1- len)))) - (or (= lastc ?/) - (and (memq system-type '(windows-nt ms-dos)) - (= lastc ?\\))))))) - ;; `file-missing' is introduced in Emacs 26.1. (defconst tramp-file-missing (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") ;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26. +;; `file-name-unquote' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-local-name (if (fboundp 'file-local-name) #'file-local-name @@ -214,7 +180,8 @@ It returns a file name which can be used directly as argument of `process-file', `start-file-process', or `shell-command'." (or (file-remote-p name 'localname) name)))) -;; `file-name-quoted-p' got a second argument in Emacs 27.1. +;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got +;; a second argument in Emacs 27.1. (defalias 'tramp-compat-file-name-quoted-p (if (and (fboundp 'file-name-quoted-p) @@ -256,7 +223,7 @@ NAME is unquoted." localname (if (= (length localname) 2) "/" (substring localname 2)))) (concat (file-remote-p name) localname))))) -;; `tramp-syntax' has changed its meaning in Emacs 26. We still +;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still ;; support old settings. (defsubst tramp-compat-tramp-syntax () "Return proper value of `tramp-syntax'." @@ -265,13 +232,6 @@ NAME is unquoted." ((eq tramp-syntax 'sep) 'separate) (t tramp-syntax))) -;; `cl-struct-slot-info' has been introduced with Emacs 25. -(defmacro tramp-compat-tramp-file-name-slots () - "Return a list of slot names." - (if (fboundp 'cl-struct-slot-info) - '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))) - '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots))))) - ;; The signature of `tramp-make-tramp-file-name' has been changed. ;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior ;; Emacs 26.1. We use `temporary-file-directory' as indicator. @@ -284,10 +244,9 @@ NAME is unquoted." #'exec-path (lambda () "List of directories to search programs to run in remote subprocesses." - (let ((handler (find-file-name-handler default-directory 'exec-path))) - (if handler - (funcall handler 'exec-path) - exec-path))))) + (if-let ((handler (find-file-name-handler default-directory 'exec-path))) + (funcall handler 'exec-path) + exec-path)))) ;; `time-equal-p' has appeared in Emacs 27.1. (defalias 'tramp-compat-time-equal-p @@ -322,16 +281,38 @@ A nil value for either argument stands for the current time." (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) +;; `file-modes', `set-file-modes' and `set-file-times' got argument +;; FLAG in Emacs 28.1. +(defalias 'tramp-compat-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) + #'file-modes + (lambda (filename &optional _flag) + (file-modes filename)))) + +(defalias 'tramp-compat-set-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) + #'set-file-modes + (lambda (filename mode &optional _flag) + (set-file-modes filename mode)))) + +(defalias 'tramp-compat-set-file-times + (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) + #'set-file-times + (lambda (filename &optional timestamp _flag) + (set-file-times filename timestamp)))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-loaddefs 'force) (unload-feature 'tramp-compat 'force))) +(provide 'tramp-compat) + ;;; TODO: ;; -;; * Starting with Emacs 25.1, replace `tramp-message-show-message' by -;; the reverse of `inhibit-message'. - -(provide 'tramp-compat) +;; * `func-arity' exists since Emacs 26.1. +;; +;; * Starting with Emacs 27.1, there's no need to escape open +;; parentheses with a backslash in docstrings anymore. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el new file mode 100644 index 00000000000..c9788fcff52 --- /dev/null +++ b/lisp/net/tramp-crypt.el @@ -0,0 +1,838 @@ +;;; tramp-crypt.el --- Tramp crypt utilities -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Access functions for crypted remote files. It uses encfs to +;; encrypt / decrypt the files on a remote directory. A remote +;; directory, which shall include crypted files, must be declared in +;; `tramp-crypt-directories' via command `tramp-crypt-add-directory'. +;; All files in that directory, including all subdirectories, are +;; stored there encrypted. This includes file names and directory +;; names. + +;; This package is just responsible for the encryption part. Copying +;; of the crypted files is still the responsibility of the remote file +;; name handlers. + +;; A password protected encfs configuration file is created the very +;; first time you access a crypted remote directory. It is kept in +;; your user directory "~/.emacs.d/" with the url-encoded directory +;; name as part of the basename, and ".encfs6.xml" as suffix. Do not +;; loose this file and the corresponding password; otherwise there is +;; no way to decrypt your crypted files. + +;; If the user option `tramp-crypt-save-encfs-config-remote' is +;; non-nil (the default), the encfs configuration file ".encfs6.xml" +;; is also kept in the crypted remote directory. It depends on you, +;; whether you regard the password protection of this file as +;; sufficient. + +;; If you use a remote file name with a quoted localname part, this +;; localname and the corresponding file will not be encrypted/ +;; decrypted. For example, if you have a crypted remote directory +;; "/nextcloud:user@host:/crypted_dir", the command +;; +;; C-x d /nextcloud:user@host:/crypted_dir +;; +;; will show the directory listing with the plain file names, and the +;; command +;; +;; C-x d /nextcloud:user@host:/:/crypted_dir +;; +;; will show the directory with the encrypted file names, and visiting +;; a file will show its crypted contents. However, it is highly +;; discouraged to mix crypted and not crypted files in the same +;; directory. + +;; If a remote directory shall not include crypted files anymore, it +;; must be indicated by the command `tramp-crypt-remove-directory'. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp) + +(autoload 'prop-match-beginning "text-property-search") +(autoload 'prop-match-end "text-property-search") +(autoload 'text-property-search-forward "text-property-search") + +(defconst tramp-crypt-method "crypt" + "Method name for crypted remote directories.") + +(defcustom tramp-crypt-encfs-program "encfs" + "Name of the encfs program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfsctl-program "encfsctl" + "Name of the encfsctl program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfs-option "--standard" + "Configuration option for encfs. +This could be either \"--standard\" or \"--paranoia\". The file +name IV chaining mode mode will always be disabled when +initializing a new crypted remote directory." + :group 'tramp + :version "28.1" + :type '(choice (const "--standard") + (const "--paranoia"))) + +;; We check only for encfs, assuming that encfsctl will be available +;; as well. The autoloaded value is nil, the check will run when +;; tramp-crypt.el is loaded by `tramp-crypt-add-directory'. It is a +;; common technique to let-bind this variable to nil in order to +;; suppress the file name operation of this package. +;;;###tramp-autoload +(defvar tramp-crypt-enabled nil + "Non-nil when encryption support is available.") +(setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program)) + +;;;###tramp-autoload +(defconst tramp-crypt-encfs-config ".encfs6.xml" + "Encfs configuration file name.") + +(defcustom tramp-crypt-save-encfs-config-remote t + "Whether to keep the encfs configuration file in the crypted remote directory." + :group 'tramp + :version "28.1" + :type 'booleanp) + +;;;###tramp-autoload +(defvar tramp-crypt-directories nil + "List of crypted remote directories.") + +;; It must be a `defsubst' in order to push the whole code into +;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. +;;;###tramp-autoload +(defsubst tramp-crypt-file-name-p (name) + "Return the crypted remote directory NAME belongs to. +If NAME doesn't belong to a crypted remote directory, retun nil." + (catch 'crypt-file-name-p + (and tramp-crypt-enabled (stringp name) + (not (tramp-compat-file-name-quoted-p name)) + (not (string-suffix-p tramp-crypt-encfs-config name)) + (dolist (dir tramp-crypt-directories) + (and (string-prefix-p + dir (file-name-as-directory (expand-file-name name))) + (throw 'crypt-file-name-p dir)))))) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-crypt-file-name-handler-alist + '((access-file . tramp-crypt-handle-access-file) + (add-name-to-file . tramp-handle-add-name-to-file) + ;; `byte-compiler-base-file-name' performed by default handler. + (copy-directory . tramp-handle-copy-directory) + (copy-file . tramp-crypt-handle-copy-file) + (delete-directory . tramp-crypt-handle-delete-directory) + (delete-file . tramp-crypt-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + ;; `directory-file-name' performed by default handler. + (directory-files . tramp-crypt-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-crypt-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-crypt-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-crypt-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . tramp-crypt-handle-file-ownership-preserved-p) + (file-readable-p . tramp-crypt-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . ignore) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-crypt-handle-file-system-info) + ;; `file-truename' performed by default handler. + (file-writable-p . tramp-crypt-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-crypt-handle-insert-directory) + ;; `insert-file-contents' performed by default handler. + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-crypt-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-crypt-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . tramp-crypt-handle-set-file-modes) + (set-file-selinux-context . ignore) + (set-file-times . tramp-crypt-handle-set-file-times) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . ignore) + (start-file-process . ignore) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-handle-temporary-file-directory) + ;; `tramp-get-remote-gid' performed by default handler. + ;; `tramp-get-remote-uid' performed by default handler. + (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-handle-write-region)) + "Alist of handler functions for crypt method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +(defsubst tramp-crypt-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for crypted remote files." + (let ((tfnfo (apply #'tramp-file-name-for-operation operation args))) + ;; `tramp-file-name-for-operation' returns already the first argument + ;; if it is remote. So we check a possible second argument. + (unless (tramp-crypt-file-name-p tfnfo) + (setq tfnfo (apply + #'tramp-file-name-for-operation operation + (cons (tramp-compat-temporary-file-directory) (cdr args))))) + tfnfo)) + +(defun tramp-crypt-run-real-handler (operation args) + "Invoke normal file name handler for OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (let* ((inhibit-file-name-handlers + `(tramp-crypt-file-name-handler + . + ,(and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;;;###tramp-autoload +(defun tramp-crypt-file-name-handler (operation &rest args) + "Invoke the crypted remote file related OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (if-let ((filename + (apply #'tramp-crypt-file-name-for-operation operation args)) + (fn (and (tramp-crypt-file-name-p filename) + (assoc operation tramp-crypt-file-name-handler-alist)))) + (save-match-data (apply (cdr fn) args)) + (tramp-crypt-run-real-handler operation args))) + +;;;###tramp-autoload +(progn (defun tramp-register-crypt-file-name-handler () + "Add crypt file name handler to `file-name-handler-alist'." + (when (and tramp-crypt-enabled tramp-crypt-directories) + (add-to-list 'file-name-handler-alist + (cons tramp-file-name-regexp #'tramp-crypt-file-name-handler)) + (put #'tramp-crypt-file-name-handler 'safe-magic t)))) + +(tramp-register-file-name-handlers) + +;; Mark `operations' the handler is responsible for. +(put #'tramp-crypt-file-name-handler 'operations + (mapcar #'car tramp-crypt-file-name-handler-alist)) + + +;; File name conversions. + +(defun tramp-crypt-config-file-name (vec) + "Return the encfs config file name for VEC." + (expand-file-name + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config) + user-emacs-directory)) + +(defun tramp-crypt-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + ;; For password handling, we need a process bound to the connection + ;; buffer. Therefore, we create a dummy process. Maybe there is a + ;; better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil))) + + ;; The following operations must be performed w/o + ;; `tramp-crypt-file-name-handler'. + (let* (tramp-crypt-enabled + ;; Don't check for a proper method. + (non-essential t) + (remote-config + (expand-file-name + tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) + (local-config (tramp-crypt-config-file-name vec))) + ;; There is no local encfs6 config file. + (when (not (file-exists-p local-config)) + (if (and tramp-crypt-save-encfs-config-remote + (file-exists-p remote-config)) + ;; Copy remote encfs6 config file if possible. + (copy-file remote-config local-config 'ok 'keep) + + ;; Create local encfs6 config file otherwise. + (let* ((default-directory (tramp-compat-temporary-file-directory)) + (tmpdir1 (file-name-as-directory + (tramp-compat-make-temp-file " .crypt" 'dir-flag))) + (tmpdir2 (file-name-as-directory + (tramp-compat-make-temp-file " .nocrypt" 'dir-flag)))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (with-temp-buffer + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format + "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when + (zerop + (tramp-call-process-region + vec (point-min) (point-max) + tramp-crypt-encfs-program nil (tramp-get-connection-buffer vec) + nil tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2)) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))))) + + ;; Write local config file. Suppress file name IV chaining mode. + (with-temp-file local-config + (insert-file-contents + (expand-file-name tramp-crypt-encfs-config tmpdir1)) + (when (search-forward + "<chainedNameIV>1</chainedNameIV>" nil 'noerror) + (replace-match "<chainedNameIV>0</chainedNameIV>"))) + + ;; Unmount encfs. Delete temporary directories. + (tramp-call-process + vec tramp-crypt-encfs-program nil nil nil + "--unmount" tmpdir1 tmpdir2) + (delete-directory tmpdir1 'recursive) + (delete-directory tmpdir2) + + ;; Copy local encfs6 config file to remote. + (when tramp-crypt-save-encfs-config-remote + (copy-file local-config remote-config 'ok 'keep))))))) + +(defun tramp-crypt-send-command (vec &rest args) + "Send encfsctl command to connection VEC. +ARGS are the arguments. It returns t if ran successful, and nil otherwise." + (tramp-crypt-maybe-open-connection vec) + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (set-buffer-multibyte nil)) + (with-temp-buffer + (let* (;; Don't check for a proper method. + (non-essential t) + (default-directory (tramp-compat-temporary-file-directory)) + ;; We cannot add it to `process-environment', because + ;; `tramp-call-process-region' doesn't use it. + (encfs-config + (format "ENCFS6_CONFIG=%s" (tramp-crypt-config-file-name vec))) + (args (delq nil args))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format "EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when (zerop + (apply + #'tramp-call-process-region vec (point-min) (point-max) + "env" nil (tramp-get-connection-buffer vec) + nil encfs-config tramp-crypt-encfsctl-program + (car args) "--extpass=cat" (cdr args))) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))) + t)))) + +(defun tramp-crypt-do-encrypt-or-decrypt-file-name (op name) + "Return encrypted / decrypted NAME if NAME belongs to a crypted directory. +OP must be `encrypt' or `decrypt'. Raise an error if this fails. +Otherwise, return NAME." + (if-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p name)) + ;; It must be absolute for the cache. + (localname (substring name (1- (length dir)))) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + ;; Preserve trailing "/". + (funcall + (if (directory-name-p name) #'file-name-as-directory #'identity) + (concat + dir + (unless (string-equal localname "/") + (with-tramp-file-property + crypt-vec localname (concat (symbol-name op) "-file-name") + (unless (tramp-crypt-send-command + crypt-vec (if (eq op 'encrypt) "encode" "decode") + (tramp-compat-temporary-file-directory) localname) + (tramp-error + crypt-vec 'file-error "%s of file name %s failed." + (if (eq op 'encrypt) "Encoding" "Decoding") name)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (goto-char (point-min)) + (buffer-substring (point-min) (point-at-eol))))))) + ;; Nothing to do. + name)) + +(defsubst tramp-crypt-encrypt-file-name (name) + "Return encrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'encrypt name)) + +(defsubst tramp-crypt-decrypt-file-name (name) + "Return decrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'decrypt name)) + +(defun tramp-crypt-do-encrypt-or-decrypt-file (op root infile outfile) + "Encrypt / decrypt file INFILE to OUTFILE according to crypted directory ROOT. +Both files must be local files. OP must be `encrypt' or `decrypt'. +If OP ist `decrypt', the basename of INFILE must be an encrypted file name. +Raise an error if this fails." + (when-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p root)) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + (let ((coding-system-for-read + (if (eq op 'decrypt) 'binary coding-system-for-read)) + (coding-system-for-write + (if (eq op 'encrypt) 'binary coding-system-for-write))) + (unless (tramp-crypt-send-command + crypt-vec "cat" (and (eq op 'encrypt) "--reverse") + (file-name-directory infile) + (concat "/" (file-name-nondirectory infile))) + (tramp-error + crypt-vec 'file-error "%s of file %s failed." + (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (write-region nil nil outfile))))) + +(defsubst tramp-crypt-encrypt-file (root infile outfile) + "Encrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'encrypt root infile outfile)) + +(defsubst tramp-crypt-decrypt-file (root infile outfile) + "Decrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'decrypt root infile outfile)) + +;;;###tramp-autoload +(defun tramp-crypt-add-directory (name) + "Mark remote directory NAME for encryption. +Files in that directory and all subdirectories will be encrypted +before copying to, and decrypted after copying from that +directory. File names will be also encrypted." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (unless (and (tramp-tramp-file-p name) (file-directory-p name)) + (tramp-user-error nil "%s must be an existing remote directory." name)) + (when (tramp-compat-file-name-quoted-p name) + (tramp-user-error nil "%s must not be quoted." name)) + (setq name (file-name-as-directory (expand-file-name name))) + (unless (member name tramp-crypt-directories) + (setq tramp-crypt-directories (cons name tramp-crypt-directories))) + (tramp-register-file-name-handlers)) + +(defun tramp-crypt-remove-directory (name) + "Unmark remote directory NAME for encryption. +Existing files in that directory and its subdirectories will be +kept in their encrypted form." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (setq name (file-name-as-directory (expand-file-name name))) + (when (and (member name tramp-crypt-directories) + (delete + tramp-crypt-encfs-config + (directory-files name nil directory-files-no-dot-files-regexp)) + (yes-or-no-p + "There exist encrypted files, do you want to continue? ")) + (setq tramp-crypt-directories (delete name tramp-crypt-directories)) + (tramp-register-file-name-handlers))) + +;; `auth-source' requires a user. +(defun tramp-crypt-dissect-file-name (name) + "Return a `tramp-file-name' structure for NAME. +The structure consists of the `tramp-crypt-method' method, the +local user name, the hexlified directory NAME as host, and the +localname." + (save-match-data + (if-let ((dir (tramp-crypt-file-name-p name))) + (make-tramp-file-name + :method tramp-crypt-method :user (user-login-name) + :host (url-hexify-string dir)) + (tramp-user-error nil "Not a crypted remote directory: \"%s\"" name)))) + +(defun tramp-crypt-get-remote-dir (vec) + "Return the name of the crypted remote directory to be used for encfs." + (url-unhex-string (tramp-file-name-host vec))) + + +;; File name primitives. + +(defun tramp-crypt-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-regexp (concat (regexp-quote encrypt-filename) "\\'")) + tramp-crypt-enabled) + (condition-case err + (access-file encrypt-filename string) + (error + (when (and (eq (car err) 'file-missing) (stringp (cadr err)) + (string-match-p encrypt-regexp (cadr err))) + (setcar + (cdr err) + (replace-regexp-in-string encrypt-regexp filename (cadr err)))) + (signal (car err) (cdr err)))))) + +(defun tramp-crypt-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-crypt-handle-copy-file' and +`tramp-crypt-handle-rename-file'. It is an error if OP is +neither of `copy' and `rename'. FILENAME and NEWNAME must be +absolute file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (let ((t1 (tramp-crypt-file-name-p filename)) + (t2 (tramp-crypt-file-name-p newname)) + (encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-newname (tramp-crypt-encrypt-file-name newname)) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) + (delete-directory filename 'recursive))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (unless (file-exists-p filename) + (tramp-error + v tramp-file-missing + "%s file" msg-operation "No such file or directory" filename)) + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (if (and t1 t2 (string-equal t1 t2)) + ;; Both files are on the same crypted remote directory. + (let (tramp-crypt-enabled) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + + (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) + (tmpfile1 + (expand-file-name + (file-name-nondirectory encrypt-filename) tmpdir)) + (tmpfile2 + (expand-file-name + (file-name-nondirectory encrypt-newname) tmpdir)) + tramp-crypt-enabled) + (cond + ;; Source and target file are on a crypted remote directory. + ((and t1 t2) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + ;; Source file is on a crypted remote directory. + (t1 + (if (eq op 'copy) + (copy-file + encrypt-filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file encrypt-filename tmpfile1 t)) + (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) + (rename-file tmpfile2 newname ok-if-already-exists)) + ;; Target file is on a crypted remote directory. + (t2 + (if (eq op 'copy) + (copy-file + filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile1 t)) + (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2) + (rename-file tmpfile2 encrypt-newname ok-if-already-exists))) + (delete-directory tmpdir 'recursive)))))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))) + +(defun tramp-crypt-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-crypt-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-crypt-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (tramp-flush-directory-properties v localname) + (let (tramp-crypt-enabled) + (delete-directory + (tramp-crypt-encrypt-file-name directory) recursive trash)))) + +(defun tramp-crypt-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (delete-file (tramp-crypt-encrypt-file-name filename) trash)))) + +(defun tramp-crypt-handle-directory-files (directory &optional full match nosort) + "Like `directory-files' for Tramp files." + (unless (file-exists-p directory) + (tramp-error + (tramp-dissect-file-name directory) tramp-file-missing + "No such file or directory" directory)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let* (tramp-crypt-enabled + (result + (directory-files (tramp-crypt-encrypt-file-name directory) 'full))) + (setq result + (mapcar (lambda (x) (tramp-crypt-decrypt-file-name x)) result)) + (when match + (setq result + (delq + nil + (mapcar + (lambda (x) + (when (string-match-p match (substring x (length directory))) + x)) + result)))) + (unless full + (setq result + (mapcar + (lambda (x) + (replace-regexp-in-string + (concat "^" (regexp-quote directory)) "" x)) + result))) + (if nosort result (sort result #'string<))))) + +(defun tramp-crypt-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (let (tramp-crypt-enabled) + (file-attributes (tramp-crypt-encrypt-file-name filename) id-format))) + +(defun tramp-crypt-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-executable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (let* (completion-regexp-list + tramp-crypt-enabled + (directory (file-name-as-directory directory)) + (enc-dir (tramp-crypt-encrypt-file-name directory))) + (mapcar + (lambda (x) + (substring + (tramp-crypt-decrypt-file-name (concat enc-dir x)) + (length directory))) + (file-name-all-completions "" enc-dir))))) + +(defun tramp-crypt-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-readable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-ownership-preserved-p (filename &optional group) + "Like `file-ownership-preserved-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-ownership-preserved-p (tramp-crypt-encrypt-file-name filename) group))) + +(defun tramp-crypt-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (let (tramp-crypt-enabled) + ;; `file-system-info' exists since Emacs 27.1. + (tramp-compat-funcall + 'file-system-info (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-writable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files. +WILDCARD is not supported." + ;; This package has been added to Emacs 27.1. + (when (load "text-property-search" 'noerror 'nomessage) + (let (tramp-crypt-enabled) + (tramp-handle-insert-directory + (tramp-crypt-encrypt-file-name filename) + switches wildcard full-directory-p) + (let* ((filename (file-name-as-directory filename)) + (enc (tramp-crypt-encrypt-file-name filename)) + match string) + (goto-char (point-min)) + (while (setq match (text-property-search-forward 'dired-filename t t)) + (setq string + (buffer-substring + (prop-match-beginning match) (prop-match-end match)) + string (if (file-name-absolute-p string) + (tramp-crypt-decrypt-file-name string) + (substring + (tramp-crypt-decrypt-file-name (concat enc string)) + (length filename)))) + (delete-region (prop-match-beginning match) (prop-match-end match)) + (insert (propertize string 'dired-filename t))))))) + +(defun tramp-crypt-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (when (and (null parents) (file-exists-p dir)) + (tramp-error v 'file-already-exists "Directory already exists %s" dir)) + (let (tramp-crypt-enabled) + (make-directory (tramp-crypt-encrypt-file-name dir) parents)) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))))) + +(defun tramp-crypt-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-crypt-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) + (tramp-run-real-handler + #'rename-file (list filename newname ok-if-already-exists)))) + +(defun tramp-crypt-handle-set-file-modes (filename mode &optional flag) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-modes + (tramp-crypt-encrypt-file-name filename) mode flag)))) + +(defun tramp-crypt-handle-set-file-times (filename &optional time flag) + "Like `set-file-times' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-times + (tramp-crypt-encrypt-file-name filename) time flag)))) + +(defun tramp-crypt-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-set-file-uid-gid + (tramp-crypt-encrypt-file-name filename) uid gid)))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-crypt 'force))) + +(provide 'tramp-crypt) + +;;; TODO: + +;; * I suggest having a feature where the user can specify to always +;; use encryption for certain host names. So if you specify a host +;; name which is on that list (of names, or perhaps regexps?), tramp +;; would modify the request so as to do the encryption. (Richard Stallman) + +;;; tramp-crypt.el ends here diff --git a/lisp/net/tramp-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 34a234c47f0..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") @@ -121,16 +124,19 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (or (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) + (or ;; Until Emacs 25, `process-attributes' could crash Emacs + ;; for some processes. Better we don't check. + (<= emacs-major-version 25) + (tramp-process-running-p "gvfs-fuse-daemon") + (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp") + '("afp" "dav" "davs" "gdrive" "media" "nextcloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "27.1" + :version "28.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") @@ -138,10 +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.") @@ -151,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" @@ -169,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.") @@ -457,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. @@ -470,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:]]*" @@ -600,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) @@ -625,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) @@ -642,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." @@ -680,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. @@ -689,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 @@ -704,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 @@ -712,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 @@ -728,6 +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))) ;; File name primitives. @@ -758,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) @@ -772,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 @@ -833,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)) @@ -950,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))))) @@ -1054,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))) @@ -1063,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))) @@ -1244,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)) @@ -1281,7 +1512,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; If the user is different from what we guess to be ;; the user, we don't know. Let's check, whether ;; access is restricted explicitly. - (and (/= (tramp-gvfs-get-remote-uid v 'integer) + (and (/= (tramp-get-remote-uid v 'integer) (tramp-compat-file-attribute-user-id (file-attributes filename 'integer))) (not @@ -1301,10 +1532,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) - (when (and (stringp size) (stringp used) (stringp free)) - (list (string-to-number size) - (- (string-to-number size) (string-to-number used)) - (string-to-number free)))))) + (when (or size used free) + (list (string-to-number (or size "0")) + (string-to-number (or free "0")) + (- (string-to-number (or size "0")) + (string-to-number (or used "0")))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1330,8 +1562,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -1341,78 +1573,110 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-run-real-handler #'rename-file (list filename newname ok-if-already-exists)))) -(defun tramp-gvfs-handle-set-file-modes (filename mode) +(defun tramp-gvfs-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::mode" (number-to-string mode)))) + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint32" + (tramp-gvfs-url-file-name filename) "unix::mode" (number-to-string mode)))) -(defun tramp-gvfs-handle-set-file-times (filename &optional time) +(defun tramp-gvfs-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) - (let ((time - (if (or (null time) + (tramp-gvfs-send-command + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint64" + (tramp-gvfs-url-file-name filename) "time::modified" + (format-time-string + "%s" (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) - time))) - (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint64" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "time::modified" (format-time-string "%s" time))))) + time))))) + +(defun tramp-gvfs-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (if (equal id-format 'string) + (tramp-file-name-user vec) + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-user-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format))))) + +(defun tramp-gvfs-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-group-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format)))) -(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid) +(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (when (natnump uid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::uid" (number-to-string uid))) + (tramp-gvfs-url-file-name filename) "unix::uid" (number-to-string uid))) (when (natnump gid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + (tramp-gvfs-url-file-name filename) "unix::gid" (number-to-string gid))))) ;; File name conversions. +(defun tramp-gvfs-activation-uri (filename) + "Return activation URI to be used in gio commands." + (if (tramp-tramp-file-p filename) + (with-parsed-tramp-file-name filename nil + ;; Ensure that media devices are cached. + (when (string-equal method "media") + (tramp-get-media-device v)) + (with-tramp-connection-property v "activation-uri" + (setq localname "/") + (when (string-equal "gdrive" method) + (setq method "google-drive")) + (when (string-equal "nextcloud" method) + (setq method "davs" + localname + (concat (tramp-gvfs-get-remote-prefix v) localname))) + (when (string-equal "media" method) + (when-let + ((media (tramp-get-connection-property v "media-device" nil))) + (setq method (tramp-media-device-method media) + host (tramp-media-device-host media) + port (tramp-media-device-port media)))) + (when (and user domain) + (setq user (concat domain ";" user))) + (url-recreate-url + (url-parse-make-urlobj + method (and user (url-hexify-string user)) + nil (and host (url-hexify-string host)) + (if (stringp port) (string-to-number port) port) + localname nil nil t)))) + ;; Local URI. + (url-recreate-url + (url-parse-make-urlobj "file" nil nil nil nil nil nil nil t)))) + (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - ;; "/" must NOT be hexified. (setq filename (tramp-compat-file-name-unquote filename)) - (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) - result) - (setq - result - (url-recreate-url - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (when (string-equal "gdrive" method) - (setq method "google-drive")) - (when (string-equal "nextcloud" method) - (setq method "davs" - localname - (concat (tramp-gvfs-get-remote-prefix v) localname))) - (when (and user domain) - (setq user (concat domain ";" user))) - (url-parse-make-urlobj - method (and user (url-hexify-string user)) - nil (and host (url-hexify-string host)) - (if (stringp port) (string-to-number port) port) - (and localname (url-hexify-string localname)) nil nil t)) - (url-parse-make-urlobj - "file" nil nil nil nil - (url-hexify-string (file-truename filename)) nil nil t)))) + (let* (;; "/" must NOT be hexified. + (url-unreserved-chars (cons ?/ url-unreserved-chars)) + (result + (concat (substring (tramp-gvfs-activation-uri filename) 0 -1) + (url-hexify-string (tramp-file-local-name filename))))) (when (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (tramp-message v 10 "remote file `%s' is URL `%s'" filename result))) + (tramp-message + (tramp-dissect-file-name filename) 10 + "remote file `%s' is URL `%s'" filename result)) result)) (defun tramp-gvfs-object-path (filename) @@ -1424,6 +1688,14 @@ If FILE-SYSTEM is non-nil, return file system attributes." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) +(defun tramp-gvfs-url-host (url) + "Return the host name part of URL, a string. +We cannot use `url-host', because `url-generic-parse-url' returns +a downcased host name only." + (and (stringp url) + (string-match "^[[:alnum:]]+://\\([^/:]+\\)" url) + (match-string 1 url))) + ;; D-Bus GVFS functions. @@ -1490,8 +1762,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (list t ;; handled. nil ;; no abort of D-Bus. - (with-tramp-connection-property - (tramp-get-connection-process v) message + (with-tramp-connection-property (tramp-get-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether ;; to accept an unknown host signature or certificate. @@ -1564,11 +1835,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices nil) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user domain host port "") nil @@ -1654,11 +1936,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices vec) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) @@ -1683,8 +1976,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) (while (tramp-gvfs-connection-mounted-p vec) (read-event nil nil 0.1)) - (tramp-flush-connection-properties vec) - (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. @@ -1696,11 +1988,16 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (defun tramp-gvfs-mount-spec (vec) "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." - (let* ((method (tramp-file-name-method vec)) + (let* ((media (tramp-get-media-device vec)) + (method (if media + (tramp-media-device-method media) + (tramp-file-name-method vec))) (user (tramp-file-name-user vec)) (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) + (host (if media + (tramp-media-device-host media) (tramp-file-name-host vec))) + (port (if media + (tramp-media-device-port media) (tramp-file-name-port vec))) (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) @@ -1751,42 +2048,41 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) +(defun tramp-gvfs-handler-volumeadded-volumeremoved (_dbus-name _id volume) + "Signal handler for the \"org.gtk.Private.RemoteVolumeMonitor.VolumeAdded\" \ +and \"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals." + (ignore-errors + (let* ((signal-name (dbus-event-member-name last-input-event)) + (uri (url-generic-parse-url (nth 5 volume))) + (method (url-type uri)) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri))))) + (when (member method tramp-media-methods) + (tramp-message + vec 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message volume)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties media) + (tramp-get-media-devices nil))))) + +(when tramp-gvfs-enabled + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeAdded" + #'tramp-gvfs-handler-volumeadded-volumeremoved) + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeRemoved" + #'tramp-gvfs-handler-volumeadded-volumeremoved)) + ;; Connection functions. -(defun tramp-gvfs-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((user (tramp-file-name-user vec)) - (localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - ((and (equal id-format 'string) user)) - (localname - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defun tramp-gvfs-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - (localname - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil - "Indication, that remote uid and gid determination is in progress.") - (defun tramp-gvfs-get-remote-prefix (vec) "The prefix of the remote connection VEC. This is relevant for GNOME Online Accounts." @@ -1794,7 +2090,7 @@ This is relevant for GNOME Online Accounts." ;; Ensure that GNOME Online Accounts are cached. (when (member (tramp-file-name-method vec) tramp-goa-methods) (tramp-get-goa-accounts vec)) - (tramp-get-connection-property (tramp-make-goa-name vec) "prefix" "/"))) + (tramp-get-connection-property (tramp-get-goa-account vec) "prefix" "/"))) (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -1843,7 +2139,7 @@ connection if a previous connection has died for some reason." ;; Ensure that GNOME Online Accounts are cached. (tramp-get-goa-accounts vec) (when (tramp-get-connection-property - (tramp-make-goa-name vec) "FilesDisabled" t) + (tramp-get-goa-account vec) "FilesDisabled" t) (tramp-user-error vec "There is no Online Account `%s'" (tramp-make-tramp-file-name vec 'noloc)))) @@ -1926,16 +2222,7 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t)))) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (unless tramp-gvfs-get-remote-uid-gid-in-progress - (let ((tramp-gvfs-get-remote-uid-gid-in-progress t)) - (tramp-gvfs-get-remote-uid vec 'integer) - (tramp-gvfs-get-remote-gid vec 'integer) - (tramp-gvfs-get-remote-uid vec 'string) - (tramp-gvfs-get-remote-gid vec 'string)))) + (tramp-get-connection-process vec) "connected" t))))) (defun tramp-gvfs-gio-tool-p (vec) "Check, whether the gio tool is available." @@ -1968,12 +2255,12 @@ is applied, and it returns t if the return code is zero." (and (tramp-flush-file-properties vec "/") nil))))) -;; D-Bus GNOME Online Accounts functions. +;; GNOME Online Accounts functions. -(defun tramp-make-goa-name (vec) - "Transform VEC into a `tramp-goa-name' structure." +(defun tramp-get-goa-account (vec) + "Transform VEC into a `tramp-goa-account' structure." (when (tramp-file-name-p vec) - (make-tramp-goa-name + (make-tramp-goa-account :method (tramp-file-name-method vec) :user (tramp-file-name-user vec) :host (tramp-file-name-host vec) @@ -1981,12 +2268,12 @@ is applied, and it returns t if the return code is zero." (defun tramp-get-goa-accounts (vec) "Retrieve GNOME Online Accounts, and cache them. -The hash key is a `tramp-goa-name' structure. The value is an +The hash key is a `tramp-goa-account' structure. The value is an alist of the properties of `tramp-goa-interface-account' and -`tramp-goa-interface-files' of the corresponding GNOME online -account. Additionally, a property \"prefix\" is added. +`tramp-goa-interface-files' of the corresponding GNOME Online +Account. Additionally, a property \"prefix\" is added. VEC is used only for traces." - (with-tramp-connection-property (tramp-make-goa-name vec) "goa-accounts" + (with-tramp-connection-property nil "goa-accounts" (dolist (object-path (mapcar @@ -2012,15 +2299,15 @@ VEC is used only for traces." (cdr (assoc "ProviderType" account-properties)) '("google" "owncloud")) (string-match tramp-goa-identity-regexp identity)) - (setq key (make-tramp-goa-name + (setq key (make-tramp-goa-account :method (cdr (assoc "ProviderType" account-properties)) :user (match-string 1 identity) :host (match-string 2 identity) :port (match-string 3 identity))) - (when (string-equal (tramp-goa-name-method key) "google") - (setf (tramp-goa-name-method key) "gdrive")) - (when (string-equal (tramp-goa-name-method key) "owncloud") - (setf (tramp-goa-name-method key) "nextcloud")) + (when (string-equal (tramp-goa-account-method key) "google") + (setf (tramp-goa-account-method key) "gdrive")) + (when (string-equal (tramp-goa-account-method key) "owncloud") + (setf (tramp-goa-account-method key) "nextcloud")) ;; Cache all properties. (dolist (prop (nconc account-properties files-properties)) (tramp-set-connection-property key (car prop) (cdr prop))) @@ -2036,6 +2323,80 @@ VEC is used only for traces." ;; Mark, that goa accounts have been cached. "cached")) +(defun tramp-parse-goa-accounts (service) + "Return a list of (user host) tuples allowed to access. +It checks for registered GNOME Online Accounts." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-goa-account-p key) + (string-equal service (tramp-goa-account-method key)) + (list (tramp-goa-account-user key) + (tramp-goa-account-host key)))) + (hash-table-keys tramp-cache-data))) + + +;; Media devices functions. + +(defun tramp-get-media-device (vec) + "Transform VEC into a `tramp-media-device' structure. +Check, that respective cache values do exist." + (if-let ((media (tramp-get-connection-property vec "media-device" nil)) + (prop (tramp-get-connection-property media "vector" nil))) + media + (tramp-get-media-devices vec) + (tramp-get-connection-property vec "media-device" nil))) + +(defun tramp-get-media-devices (vec) + "Retrieve media devices, and cache them. +The hash key is a `tramp-media-device' structure. +VEC is used only for traces." + (let (devices) + (dolist (method tramp-media-methods) + (dolist (volume (cadr (with-tramp-dbus-call-method vec t + :session (tramp-gvfs-service-volumemonitor method) + tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "List"))) + (let* ((uri (url-generic-parse-url (nth 5 volume))) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri) + (number-to-string (url-portspec uri)))))) + (push (tramp-file-name-host vec) devices) + (tramp-set-connection-property vec "activation-uri" (nth 5 volume)) + (tramp-set-connection-property vec "media-device" media) + (tramp-set-connection-property media "vector" vec)))) + + ;; Adapt default host name, supporting /media:: when possible. + (setq tramp-default-host-alist + (append + `(("media" nil ,(if (= (length devices) 1) (car devices) ""))) + (delete + (assoc "media" tramp-default-host-alist) + tramp-default-host-alist))))) + +(defun tramp-parse-media-names (service) + "Return a list of (user host) tuples allowed to access. +It checks for mounted media devices." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-media-device-p key) + (string-equal service (tramp-media-device-method key)) + (tramp-get-connection-property key "vector" nil) + (list nil (tramp-file-name-host + (tramp-get-connection-property key "vector" nil))))) + (hash-table-keys tramp-cache-data))) + ;; D-Bus zeroconf functions. @@ -2080,39 +2441,62 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (list user host))) result)))) -;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods. (when tramp-gvfs-enabled - ;; Suppress D-Bus error messages. - (let (tramp-gvfs-dbus-event-vector) + ;; Suppress D-Bus error messages and Tramp traces. + (let ((tramp-verbose 0) + tramp-gvfs-dbus-event-vector fun) + ;; Add completion functions for services announced by DNS-SD. + ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types. (zeroconf-init tramp-gvfs-zeroconf-domain) - (if (zeroconf-list-service-types) - (progn - (tramp-set-completion-function - "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp"))) - (tramp-set-completion-function - "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp") - (tramp-zeroconf-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp"))))) - - (when (executable-find "avahi-browse") + (when (setq fun (or (and (zeroconf-list-service-types) + #'tramp-zeroconf-parse-device-names) + (and (executable-find "avahi-browse") + #'tramp-gvfs-parse-device-names))) + (when (member "afp" tramp-gvfs-methods) + (tramp-set-completion-function + "afp" `((,fun "_afpovertcp._tcp")))) + (when (member "dav" tramp-gvfs-methods) + (tramp-set-completion-function + "dav" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "davs" tramp-gvfs-methods) + (tramp-set-completion-function + "davs" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "ftp" tramp-gvfs-methods) (tramp-set-completion-function - "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp"))) + "ftp" `((,fun "_ftp._tcp")))) + (when (member "http" tramp-gvfs-methods) (tramp-set-completion-function - "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "http" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "https" tramp-gvfs-methods) (tramp-set-completion-function - "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "https" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "sftp" tramp-gvfs-methods) (tramp-set-completion-function - "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp") - (tramp-gvfs-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) + "sftp" `((,fun "_sftp-ssh._tcp") + (,fun "_ssh._tcp") + (,fun "_workstation._tcp")))) + (when (member "smb" tramp-gvfs-methods) + (tramp-set-completion-function + "smb" `((,fun "_smb._tcp"))))) + + ;; Add completion functions for GNOME Online Accounts. + (tramp-get-goa-accounts nil) + (dolist (method tramp-goa-methods) + (when (member method tramp-gvfs-methods) + (tramp-set-completion-function + method `((tramp-parse-goa-accounts ,(format "_%s._tcp" method)))))) + + ;; Add completion functions for media devices. + (tramp-get-media-devices nil) + (tramp-set-completion-function + "media" + (mapcar + (lambda (method) `(tramp-parse-media-names ,(format "_%s._tcp" method))) + tramp-media-methods)))) (add-hook 'tramp-unload-hook (lambda () @@ -2125,7 +2509,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." ;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. ;; ;; * Host name completion for existing mount points (afp-server, -;; smb-server, google-drive, nextcloud) or via smb-network or network. +;; smb-server) or via smb-network or network. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 9f539850139..3701bfc22c9 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -135,6 +135,8 @@ (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -157,10 +159,9 @@ Operations not mentioned here will be handled by the default Emacs primitives.") "Invoke the rclone handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (tramp--with-startup @@ -220,7 +221,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and t1 (not (tramp-rclone-file-name-p filename))) @@ -271,8 +272,8 @@ file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -429,8 +430,8 @@ file names." (defun tramp-rclone-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -458,7 +459,7 @@ file names." ;; to cache a nil result. (or (tramp-get-connection-property (tramp-get-connection-process vec) "mounted" nil) - (let* ((default-directory temporary-file-directory) + (let* ((default-directory (tramp-compat-temporary-file-directory)) (mount (shell-command-to-string "mount -t fuse.rclone"))) (tramp-message vec 6 "%s" "mount -t fuse.rclone") (tramp-message vec 6 "\n%s" mount) @@ -478,7 +479,19 @@ file names." (with-tramp-connection-property (tramp-get-connection-process vec) "rclone-pid" (catch 'pid - (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (dolist + (pid + ;; Until Emacs 25, `process-attributes' could + ;; crash Emacs for some processes. So we use + ;; "pidof", which might not work everywhere. + (if (<= emacs-major-version 25) + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (mapcar + #'string-to-number + (split-string + (shell-command-to-string "pidof rclone")))) + (list-system-processes))) (and (string-match-p (regexp-quote (format "rclone mount %s:" (tramp-file-name-host vec))) @@ -564,7 +577,7 @@ connection if a previous connection has died for some reason." ,(tramp-rclone-mount-point vec) ;; This could be nil. ,(tramp-get-method-parameter vec 'tramp-mount-args)))) - (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname))) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) (tramp-cleanup-connection vec 'keep-debug 'keep-password)) ;; Mark it as connected. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index af97328b3d3..4dc95b1bb05 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -90,10 +90,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 @@ -481,6 +481,7 @@ The string is used in `tramp-methods'.") ;; Darwin: /usr/bin:/bin:/usr/sbin:/sbin ;; IRIX64: /usr/bin ;; QNAP QTS: --- +;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin ;;;###tramp-autoload (defcustom tramp-remote-path '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" @@ -491,8 +492,8 @@ The string is used in `tramp-methods'.") For every remote host, this variable will be set buffer local, keeping the list of existing directories on that host. -You can use `~' in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with `~' will be ignored. +You can use \"~\" in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with \"~\" will be ignored. `Default Directories' represent the list of directories given by the command \"getconf PATH\". It is recommended to use this @@ -537,12 +538,13 @@ based on the Tramp and Emacs versions, and should not be set here." ;;;###tramp-autoload (defcustom tramp-sh-extra-args - '(("/bash\\'" . "-norc -noprofile") + '(("/bash\\'" . "-noediting -norc -noprofile") ("/zsh\\'" . "-f +Z -V")) "Alist specifying extra arguments to pass to the remote shell. Entries are (REGEXP . ARGS) where REGEXP is a regular expression matching the shell file name and ARGS is a string specifying the -arguments. +arguments. These arguments shall disable line editing, see +`tramp-open-shell'. This variable is only used when Tramp needs to start up another shell for tilde expansion. The extra arguments should typically prevent the @@ -866,8 +868,12 @@ Escape sequence %s is replaced with name of Perl binary.") "Perl program to use for decoding a file. Escape sequence %s is replaced with name of Perl binary.") +(defconst tramp-hexdump-encode "%h -v -e '16/1 \" %%02x\" \"\\n\"'" + "`hexdump' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + (defconst tramp-awk-encode - "od -v -t x1 -A n | busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" b16 = \"0123456789abcdef\" @@ -897,11 +903,25 @@ END { } printf tail }'" - "Awk program to use for encoding a file. + "`awk' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-hexdump-awk-encode + (format "%s | %s" tramp-hexdump-encode tramp-awk-encode) + "`hexdump' / `awk' pipe to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-encode "%o -v -t x1 -A n" + "`od' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-awk-encode + (format "%s | %s" tramp-od-encode tramp-awk-encode) + "`od' / `awk' pipe to use for encoding a file. This string is passed to `format', so percent characters need to be doubled.") (defconst tramp-awk-decode - "busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" } @@ -926,12 +946,6 @@ BEGIN { "Awk program to use for decoding a file. This string is passed to `format', so percent characters need to be doubled.") -(defconst tramp-awk-coding-test - "test -c /dev/zero && \ -od -v -t x1 -A n </dev/null && \ -busybox awk '{}' </dev/null" - "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") - (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do @@ -1025,6 +1039,8 @@ of command line.") (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) @@ -1051,9 +1067,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1104,8 +1118,7 @@ component is used as the target of the symlink." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -1142,59 +1155,9 @@ component is used as the target of the symlink." (tramp-shell-quote-argument localname))))) ;; Do it yourself. - (t (let ((steps (split-string localname "/" 'omit)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/") - 'nohop)))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message - v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - (setq steps - (append - (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result (string-join (cons "" result) "/") "/")) - (when (string-empty-p result) (setq result "/"))))) + (t (setq + result + (tramp-file-local-name (tramp-handle-file-truename filename))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1263,8 +1226,8 @@ component is used as the target of the symlink." (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." (let (symlinkp dirp - res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) + res-inode res-filemodes res-numlinks + res-uid res-gid res-size res-symlink-target) (tramp-message vec 5 "file attributes with ls: %s" localname) ;; We cannot send all three commands combined, it could exceed ;; NAME_MAX or PATH_MAX. Happened on macOS, for example. @@ -1366,20 +1329,12 @@ component is used as the target of the symlink." (tramp-send-command-and-read vec (format - (eval-when-compile - (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we - ;; add a space. Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape - ;; of them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) + (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) @@ -1390,7 +1345,8 @@ component is used as the target of the symlink." (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) - tramp-stat-quoted-marker))) + tramp-stat-quoted-marker) + 'noerror)) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -1468,17 +1424,24 @@ of." ;; only if that agrees with the buffer's record. (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) -(defun tramp-sh-handle-set-file-modes (filename mode) +(defun tramp-sh-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - ;; FIXME: extract the proper text from chmod's stderr. - (tramp-barf-unless-okay - v - (format "chmod %o %s" mode (tramp-shell-quote-argument localname)) - "Error while changing file's mode %s" filename))) + ;; We need "chmod -h" when the flag is set. + (when (or (not (eq flag 'nofollow)) + (not (file-symlink-p filename)) + (tramp-get-remote-chmod-h v)) + (tramp-flush-file-properties v localname) + ;; FIXME: extract the proper text from chmod's stderr. + (tramp-barf-unless-okay + v + (format + "chmod %s %o %s" + (if (and (eq flag 'nofollow) (tramp-get-remote-chmod-h v)) "-h" "") + mode (tramp-shell-quote-argument localname)) + "Error while changing file's mode %s" filename)))) -(defun tramp-sh-handle-set-file-times (filename &optional time) +(defun tramp-sh-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) @@ -1491,13 +1454,34 @@ of." time))) (tramp-send-command-and-check v (format - "env TZ=UTC %s %s %s" + "env TZ=UTC %s %s %s %s" (tramp-get-remote-touch v) (if (tramp-get-connection-property v "touch-t" nil) (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t)) "") + (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-uid-with-python vec id-format))))) + +(defun tramp-sh-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-gid-with-python vec id-format))))) + (defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." ;; Modern Unices allow chown only for root. So we might need @@ -1521,7 +1505,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) @@ -1529,9 +1513,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 @@ -1570,7 +1553,7 @@ of." (defun tramp-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (tramp-send-command-and-check vec "getfacl /"))) (defun tramp-sh-handle-file-acl (filename) @@ -1700,8 +1683,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) @@ -1779,21 +1764,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 @@ -1834,13 +1817,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)))) @@ -1948,7 +1930,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; scp or rsync DTRT. (progn (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (setq dirname (directory-file-name (expand-file-name dirname)) newname (directory-file-name (expand-file-name newname))) @@ -1961,7 +1943,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (unless (file-directory-p (file-name-directory newname)) (make-directory (file-name-directory newname) parents)) (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname keep-date)) + 'copy dirname newname 'ok-if-already-exists keep-date)) ;; We must do it file-wise. (tramp-run-real-handler @@ -1978,8 +1960,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -2030,7 +2012,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -2057,7 +2039,7 @@ file names." (tramp-method-out-of-band-p v1 length) (tramp-method-out-of-band-p v2 length)) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; No shortcut was possible. So we copy the file ;; first. If the operation was `rename', we go back @@ -2070,7 +2052,7 @@ file names." ;; source and target file. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))))) + op filename newname ok-if-already-exists keep-date)))))) ;; One file is a Tramp file, the other one is local. ((or t1 t2) @@ -2085,11 +2067,11 @@ file names." ;; corresponding copy-program can be invoked. ((tramp-method-out-of-band-p v length) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; Use the inline method via a Tramp buffer. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) + op filename newname ok-if-already-exists keep-date)))) (t ;; One of them must be a Tramp file. @@ -2111,7 +2093,8 @@ file names." (with-parsed-tramp-file-name newname v2 (tramp-flush-file-properties v2 v2-localname)))))))) -(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-via-buffer + (op filename newname ok-if-already-exists keep-date) "Use an Emacs buffer to copy or rename a file. First arg OP is either `copy' or `rename' and indicates the operation. FILENAME is the source file, NEWNAME the target file. @@ -2139,10 +2122,11 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (insert-file-contents-literally filename))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) ;; If the operation was `rename', delete the original file. @@ -2171,8 +2155,8 @@ the uid and gid from FILENAME." v 'file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) - (localname1 (tramp-compat-file-local-name filename)) - (localname2 (tramp-compat-file-local-name newname)) + (localname1 (tramp-file-local-name filename)) + (localname2 (tramp-file-local-name newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) (when (and (eq op 'copy) (file-directory-p filename)) @@ -2296,10 +2280,12 @@ the uid and gid from FILENAME." ;; Set the time and mode. Mask possible errors. (ignore-errors (when keep-date - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes)))))) -(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-out-of-band + (op filename newname ok-if-already-exists keep-date) "Invoke `scp' program to copy. The method used must be an out-of-band method." (let* ((t1 (tramp-tramp-file-p filename)) @@ -2322,9 +2308,9 @@ The method used must be an out-of-band method." (unwind-protect (progn (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile keep-date) + op filename tmpfile ok-if-already-exists keep-date) (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname keep-date)) + 'rename tmpfile newname ok-if-already-exists keep-date)) ;; Save exit. (ignore-errors (if dir-flag @@ -2498,10 +2484,11 @@ The method used must be an out-of-band method." ;; Handle KEEP-DATE argument. (when (and keep-date (not copy-keep-date)) - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless (and keep-date copy-keep-date) @@ -2714,7 +2701,7 @@ The method used must be an out-of-band method." (when (file-symlink-p filename) (goto-char (search-backward "->" beg 'noerror))) (search-backward - (if (tramp-compat-directory-name-p filename) + (if (directory-name-p filename) "." (file-name-nondirectory filename)) beg 'noerror) @@ -2724,12 +2711,11 @@ The method used must be an out-of-band method." (goto-char (point-min)) ;; First find the line to put it on. (when (re-search-forward "^\\([[:space:]]*total\\)" nil t) - (let ((available (get-free-disk-space "."))) - (when available - ;; Replace "total" with "total used", to avoid confusion. - (replace-match "\\1 used in directory") - (end-of-line) - (insert " available " available)))) + (when-let ((available (get-free-disk-space "."))) + ;; Replace "total" with "total used", to avoid confusion. + (replace-match "\\1 used in directory") + (end-of-line) + (insert " available " available))) (goto-char (point-max))))))) @@ -2796,8 +2782,11 @@ the result will be a local, non-Tramp, file name." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-sh-handle-make-process (&rest args) - "Like `make-process' for Tramp files." + "Like `make-process' for Tramp files. +STDERR can also be a file name." (when args (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((name (plist-get args :name)) @@ -2829,14 +2818,23 @@ the result will be a local, non-Tramp, file name." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - (stderr (and stderr (get-buffer-create stderr))) - (tmpstderr (and stderr (tramp-make-tramp-temp-file v))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -2877,6 +2875,11 @@ the result will be a local, non-Tramp, file name." (setq uenv (cons elt uenv))))))) (command (when (stringp program) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) (format "cd %s && %s exec %s %s env %s %s" (tramp-shell-quote-argument localname) (if uenv @@ -2965,21 +2968,35 @@ the result will be a local, non-Tramp, file name." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Provide error buffer. This shows only ;; initial error messages; messages arriving - ;; later on shall be inserted by `auto-revert'. - ;; The temporary file will still be existing. - ;; TODO: Write a sentinel, which deletes the - ;; temporary file. - (when tmpstderr - ;; We must flush them here already; otherwise - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + ;; later on will be inserted when the process is + ;; deleted. The temporary file will exist until + ;; the process is deleted. + (when (bufferp stderr) (with-current-buffer stderr - (insert-file-contents - (tramp-make-tramp-file-name v tmpstderr) 'visit) - (auto-revert-mode))) + (insert-file-contents-literally remote-tmpstderr)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (when (file-exists-p remote-tmpstderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace)) + (delete-file remote-tmpstderr))))) ;; Return process. p))) @@ -3012,6 +3029,11 @@ the result will be a local, non-Tramp, file name." (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) (setq uenv (cons elt uenv)))))) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) (when env (setq command (format @@ -3028,7 +3050,7 @@ the result will be a local, non-Tramp, file name." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input 'nohop)) @@ -3059,8 +3081,7 @@ the result will be a local, non-Tramp, file name." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -3078,13 +3099,12 @@ the result will be a local, non-Tramp, file name." ;; directory. (condition-case nil (unwind-protect - (setq ret - (if (tramp-send-command-and-check - v (format "cd %s && %s" - (tramp-shell-quote-argument localname) - command) - t t) - 0 1)) + (setq ret (tramp-send-command-and-check + v (format + "cd %s && %s" + (tramp-shell-quote-argument localname) command) + t t t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -3102,6 +3122,12 @@ the result will be a local, non-Tramp, file name." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (>= ret 128)) + (setq ret (nth (- ret 128) (tramp-get-signal-strings)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -3122,7 +3148,7 @@ the result will be a local, non-Tramp, file name." (append (tramp-get-remote-path (tramp-dissect-file-name default-directory)) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -3236,7 +3262,8 @@ the result will be a local, non-Tramp, file name." #'write-region (list start end localname append 'no-message lockname)) - (let* ((modes (save-excursion (tramp-default-file-modes filename))) + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) ;; We use this to save the value of ;; `last-coding-system-used' after writing the tmp ;; file. At the end of the function, we set @@ -3258,7 +3285,8 @@ the result will be a local, non-Tramp, file name." ;; If `append' is non-nil, we copy the file locally, and let ;; the native `write-region' implementation do the job. - (when append (copy-file filename tmpfile 'ok)) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the ;; visited file modtime data to be clobbered from the temp @@ -3354,9 +3382,8 @@ the result will be a local, non-Tramp, 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 @@ -3401,9 +3428,8 @@ the result will be a local, non-Tramp, 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. @@ -3413,9 +3439,8 @@ the result will be a local, non-Tramp, 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. @@ -3468,8 +3493,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-handle-vc-registered (file) "Like `vc-registered' for Tramp files." (when vc-handled-backends - (let ((tramp-message-show-message - (and (not revert-buffer-in-progress-p) tramp-message-show-message)) + (let ((inhibit-message (or revert-buffer-in-progress-p inhibit-message)) (temp-message (unless revert-buffer-in-progress-p ""))) (with-temp-message temp-message (with-parsed-tramp-file-name file nil @@ -3528,27 +3552,30 @@ the result will be a local, non-Tramp, file name." ;; calls shall be answered from the file cache. We unset ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' ;; in order to keep the cache. - (let ((vc-handled-backends vc-handled-backends) + (let ((vc-handled-backends (copy-sequence vc-handled-backends)) remote-file-name-inhibit-cache process-file-side-effects) ;; Reduce `vc-handled-backends' in order to minimize ;; process calls. - (when (and (memq 'Bzr vc-handled-backends) - (boundp 'vc-bzr-program) + (when (and + (memq 'Bzr vc-handled-backends) + (or (not (require 'vc-bzr nil 'noerror)) (not (with-tramp-connection-property v vc-bzr-program (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) + v vc-bzr-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) - (when (and (memq 'Git vc-handled-backends) - (boundp 'vc-git-program) + (when (and + (memq 'Git vc-handled-backends) + (or (not (require 'vc-git nil 'noerror)) (not (with-tramp-connection-property v vc-git-program (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) + v vc-git-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Git vc-handled-backends))) - (when (and (memq 'Hg vc-handled-backends) - (boundp 'vc-hg-program) + (when (and + (memq 'Hg vc-handled-backends) + (or (not (require 'vc-hg nil 'noerror)) (not (with-tramp-connection-property v vc-hg-program (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) + v vc-hg-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Hg vc-handled-backends))) ;; Run. (tramp-with-demoted-errors @@ -3559,10 +3586,9 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-file-name-handler (operation &rest args) "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." - (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload @@ -3614,13 +3640,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. @@ -3762,12 +3786,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)) @@ -3803,10 +3826,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)) @@ -3842,11 +3864,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))) @@ -3915,13 +3936,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. @@ -3936,7 +3960,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)) @@ -3947,19 +3971,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") @@ -3983,21 +4006,22 @@ variable PATH." (format "PATH=%s; export PATH" (string-join (tramp-get-remote-path vec) ":"))) (pipe-buf - (or (with-tramp-connection-property vec "pipe-buf" - (tramp-send-command-and-read - vec "getconf PIPE_BUF / 2>/dev/null || echo nil" 'noerror)) - 4096)) + (with-tramp-connection-property vec "pipe-buf" + (tramp-send-command-and-read + vec "getconf PIPE_BUF / 2>/dev/null || echo 4096" 'noerror))) tmpfile) (tramp-message vec 5 "Setting $PATH environment variable") (if (< (length command) pipe-buf) (tramp-send-command vec command) ;; Use a temporary file. - (setq tmpfile - (tramp-make-tramp-file-name vec (tramp-make-tramp-temp-file vec))) - (write-region command nil tmpfile) - (tramp-send-command - vec (format ". %s" (tramp-compat-file-local-name tmpfile))) - (delete-file tmpfile)))) + (setq tmpfile (tramp-make-tramp-temp-file vec)) + (tramp-send-command vec (format + "cat >%s <<'%s'\n%s\n%s" + (tramp-shell-quote-argument tmpfile) + tramp-end-of-heredoc + command tramp-end-of-heredoc)) + (tramp-send-command vec (format ". %s" tmpfile)) + (tramp-send-command vec (format "rm -f %s" tmpfile))))) ;; ------------------------------------------------------------ ;; -- Communication with external shell -- @@ -4069,99 +4093,98 @@ file exists and nonzero exit status otherwise." (defun tramp-open-shell (vec shell) "Open shell SHELL." + ;; Find arguments for this shell. (with-tramp-progress-reporter vec 5 (format-message "Opening remote shell `%s'" shell) - ;; Find arguments for this shell. - (let ((extra-args (tramp-get-sh-extra-args shell))) - ;; doesn't know about and thus /bin/sh will display a strange - ;; prompt. For example, if $PS1 has "${CWD}" in the value, then - ;; ksh will display the current working directory but /bin/sh - ;; will display a dollar sign. The following command line sets - ;; $PS1 to a sane value, and works under Bourne-ish shells as - ;; well as csh-like shells. We also unset the variable $ENV - ;; because that is read by some sh implementations (eg, bash - ;; when called as sh) on startup; this way, we avoid the startup - ;; file clobbering $PS1. $PROMPT_COMMAND is another way to set - ;; the prompt in /bin/bash, it must be discarded as well. - ;; $HISTFILE is set according to `tramp-histfile-override'. - ;; $TERM and $INSIDE_EMACS set here to ensure they have the - ;; correct values when the shell starts, not just processes - ;; run within the shell. (Which processes include 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")) - tramp-terminal-type - emacs-version tramp-version ; INSIDE_EMACS - (or (getenv-internal "ENV" tramp-remote-process-environment) "") - (if (stringp tramp-histfile-override) - (format "HISTFILE=%s" - (tramp-shell-quote-argument tramp-histfile-override)) - (if tramp-histfile-override - "HISTFILE='' HISTFILESIZE=0 HISTSIZE=0" - "")) - (tramp-shell-quote-argument tramp-end-of-output) - shell (or extra-args "")) - t) - ;; Check proper HISTFILE setting. We give up when not working. - (when (and (stringp tramp-histfile-override) - (file-name-directory tramp-histfile-override)) - (tramp-barf-unless-okay - vec - (format - "(cd %s)" - (tramp-shell-quote-argument - (file-name-directory tramp-histfile-override))) - "`tramp-histfile-override' uses invalid file `%s'" - tramp-histfile-override))) + ;; It is useful to set the prompt in the following command because + ;; some people have a setting for $PS1 which /bin/sh doesn't know + ;; about and thus /bin/sh will display a strange prompt. For + ;; example, if $PS1 has "${CWD}" in the value, then ksh will + ;; display the current working directory but /bin/sh will display + ;; a dollar sign. The following command line sets $PS1 to a sane + ;; value, and works under Bourne-ish shells as well as csh-like + ;; shells. We also unset the variable $ENV because that is read + ;; by some sh implementations (eg, bash when called as sh) on + ;; startup; this way, we avoid the startup file clobbering $PS1. + ;; $PROMPT_COMMAND is another way to set the prompt in /bin/bash, + ;; it must be discarded as well. $HISTFILE is set according to + ;; `tramp-histfile-override'. $TERM and $INSIDE_EMACS set here to + ;; ensure they have the correct values when the shell starts, not + ;; just processes run within the shell. (Which processes include + ;; our initial probes to ensure the remote shell is usable.) + (tramp-send-command + vec (format + (concat + "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") + tramp-terminal-type + (or (getenv "INSIDE_EMACS") emacs-version) tramp-version + (or (getenv-internal "ENV" tramp-remote-process-environment) "") + (if (stringp tramp-histfile-override) + (format "HISTFILE=%s" + (tramp-shell-quote-argument tramp-histfile-override)) + (if tramp-histfile-override + "HISTFILE='' HISTFILESIZE=0 HISTSIZE=0" + "")) + (tramp-shell-quote-argument tramp-end-of-output) + shell (or (tramp-get-sh-extra-args shell) "")) + t) + ;; Check proper HISTFILE setting. We give up when not working. + (when (and (stringp tramp-histfile-override) + (file-name-directory tramp-histfile-override)) + (tramp-barf-unless-okay + vec + (format + "(cd %s)" + (tramp-shell-quote-argument + (file-name-directory tramp-histfile-override))) + "`tramp-histfile-override' uses invalid file `%s'" + tramp-histfile-override)) (tramp-set-connection-property (tramp-get-connection-process vec) "remote-shell" shell))) (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. @@ -4187,9 +4210,16 @@ process to set up. VEC specifies the connection." (let ((tramp-end-of-output tramp-initial-end-of-output) (case-fold-search t)) (tramp-open-shell vec (tramp-get-method-parameter vec 'tramp-remote-shell)) + (tramp-message vec 5 "Setting up remote shell environment") + + ;; Disable line editing. + (tramp-send-command vec "set +o vi +o emacs" t) + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-send-command vec "set -o" t)) ;; Disable echo expansion. - (tramp-message vec 5 "Setting up remote shell environment") (tramp-send-command vec "stty -inlcr -onlcr -echo kill '^U' erase '^H'" t) ;; Check whether the echo has really been disabled. Some @@ -4216,11 +4246,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 @@ -4259,8 +4293,6 @@ process to set up. VEC specifies the connection." (tramp-message vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))) - (tramp-send-command vec "set +o vi +o emacs" t) - ;; Check whether the remote host suffers from buggy ;; `send-process-string'. This is known for FreeBSD (see comment ;; in `send_process', file process.c). I've tested sending 624 @@ -4383,7 +4415,7 @@ and end of region, and are expected to replace the region contents with the encoded or decoded results, respectively.") (defconst tramp-remote-coding-commands - `((b64 "base64" "base64 -d -i") + '((b64 "base64" "base64 -d -i") ;; "-i" is more robust with older base64 from GNU coreutils. ;; However, I don't know whether all base64 versions do supports ;; this option. @@ -4394,8 +4426,9 @@ with the encoded or decoded results, respectively.") (b64 "recode data..base64" "recode base64..data") (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) (b64 tramp-perl-encode tramp-perl-decode) - ;; This is painful slow, so we put it on the end. - (b64 tramp-awk-encode tramp-awk-decode ,tramp-awk-coding-test) + ;; These are painfully slow, so we put them on the end. + (b64 tramp-hexdump-awk-encode tramp-awk-decode) + (b64 tramp-od-awk-encode tramp-awk-decode) (uu "uuencode xxx" "uudecode -o /dev/stdout" "test -c /dev/stdout") (uu "uuencode xxx" "uudecode -o -") (uu "uuencode xxx" "uudecode -p") @@ -4421,6 +4454,8 @@ Perl or Shell implementation for this functionality. This program will be transferred to the remote host, and it is available as shell function with the same name. A \"%t\" format specifier in the variable value denotes a temporary file. +\"%a\", \"%h\" and \"%o\" format specifiers are replaced by the +respective `awk', `hexdump' and `od' commands. The optional TEST command can be used for further tests, whether ENCODING and DECODING are applicable.") @@ -4439,8 +4474,8 @@ Goes through the list `tramp-local-coding-commands' and (catch 'wont-work-local (let ((format (nth 0 litem)) (remote-commands tramp-remote-coding-commands)) - (setq loc-enc (nth 1 litem)) - (setq loc-dec (nth 2 litem)) + (setq loc-enc (nth 1 litem) + loc-dec (nth 2 litem)) ;; If the local encoder or decoder is a string, the ;; corresponding command has to work locally. (if (not (stringp loc-enc)) @@ -4462,20 +4497,15 @@ Goes through the list `tramp-local-coding-commands' and (setq ritem (pop remote-commands)) (catch 'wont-work-remote (when (equal format (nth 0 ritem)) - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq rem-test (nth 3 ritem)) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + rem-test (nth 3 ritem)) ;; Check the remote test command if exists. (when (stringp rem-test) (tramp-message vec 5 "Checking remote test command `%s'" rem-test) (unless (tramp-send-command-and-check vec rem-test t) (throw 'wont-work-remote nil))) - ;; Check if remote perl exists when necessary. - (when (and (symbolp rem-enc) - (string-match-p "perl" (symbol-name rem-enc)) - (not (tramp-get-remote-perl vec))) - (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be ;; called remotely with null input and output. This makes ;; sure there are no syntax errors and the command is really @@ -4485,10 +4515,36 @@ Goes through the list `tramp-local-coding-commands' and ;; redirecting "mimencode" output to /dev/null, then as root ;; it might change the permissions of /dev/null! (unless (stringp rem-enc) - (let ((name (symbol-name rem-enc))) + (let ((name (symbol-name rem-enc)) + (value (symbol-value rem-enc))) + ;; Check if remote perl exists when necessary. + (and (string-match-p "perl" name) + (not (tramp-get-remote-perl vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote awk exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%a" value) + (not (tramp-get-remote-awk vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote hexdump exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%h" value) + (not (tramp-get-remote-hexdump vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote od exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%o" value) + (not (tramp-get-remote-od vec)) + (throw 'wont-work-remote nil)) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-enc) name) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) + (tramp-maybe-send-script vec value name) (setq rem-enc name))) (tramp-message vec 5 @@ -4503,17 +4559,22 @@ Goes through the list `tramp-local-coding-commands' and tmpfile) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) (when (string-match-p "\\(^\\|[^%]\\)%t" value) - (setq tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-get-remote-tmpdir vec))) + (setq tmpfile (tramp-make-tramp-temp-name vec) value (format-spec value (format-spec-make - ?t (tramp-compat-file-local-name tmpfile))))) + ?t (tramp-file-local-name tmpfile))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4531,9 +4592,9 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq found t))))))) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + found t))))))) (when found ;; Set connection properties. Since the commands are risky @@ -4796,8 +4857,8 @@ If there is just some editing, retry it after 5 seconds." vec 5 "Cannot timeout session, trying it again in %s seconds." 5) (run-at-time 5 nil 'tramp-timeout-session vec)) (tramp-message - vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname)) - (tramp-cleanup-connection vec 'keep-debug))) + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) + (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes))) (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -4818,11 +4879,8 @@ connection if a previous connection has died for some reason." (not (tramp-file-name-equal-p vec (car tramp-current-connection))) (time-less-p - ;; `current-time' can be removed once we get rid of Emacs 24. - (time-since (or (cdr tramp-current-connection) (current-time))) - ;; `seconds-to-time' can be removed once we get rid - ;; of Emacs 24. - (seconds-to-time (or tramp-connection-min-time-diff 0)))) + (time-since (cdr tramp-current-connection)) + (or tramp-connection-min-time-diff 0))) (throw 'suppress 'suppress)) ;; If too much time has passed since last command was sent, look @@ -4833,11 +4891,9 @@ connection if a previous connection has died for some reason." ;; try to send a command from time to time, then look again ;; whether the process is really alive. (condition-case nil - ;; `seconds-to-time' can be removed once we get rid of Emacs 24. - (when (and (time-less-p (seconds-to-time 60) - (time-since - (tramp-get-connection-property - p "last-cmd-time" (seconds-to-time 0)))) + (when (and (time-less-p + 60 (time-since + (tramp-get-connection-property p "last-cmd-time" 0))) (process-live-p p)) (tramp-send-command vec "echo are you awake" t t) (unless (and (process-live-p p) @@ -4951,11 +5007,8 @@ connection if a previous connection has died for some reason." ;; we cannot use `tramp-get-connection-process'. (tmpfile (with-tramp-connection-property - (get-process (tramp-buffer-name vec)) "temp-file" - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (tramp-get-process vec) "temp-file" + (tramp-compat-make-temp-name))) spec r-shell) ;; Add arguments for asynchronous processes. @@ -5116,7 +5169,7 @@ function waits for output unless NOOUTPUT is set." found))) (defun tramp-send-command-and-check - (vec command &optional subshell dont-suppress-err) + (vec command &optional subshell dont-suppress-err exit-status) "Run COMMAND and check its exit status. Send `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just send `echo $?'. Return t if the exit @@ -5124,7 +5177,9 @@ status is 0, and nil otherwise. If the optional argument SUBSHELL is non-nil, the command is executed in a subshell, ie surrounded by parentheses. If -DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." +DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null. +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-send-command vec (concat (if subshell "( " "") @@ -5133,12 +5188,14 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." "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 "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) @@ -5171,7 +5228,10 @@ raises an error." command marker (buffer-string)))))) ;; Read the expression. (condition-case nil - (prog1 (read (current-buffer)) + (prog1 + (let ((signal-hook-function + (unless noerror signal-hook-function))) + (read (current-buffer))) ;; Error handling. (when (re-search-forward "\\S-" (point-at-eol) t) (error nil))) @@ -5324,7 +5384,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)) @@ -5532,8 +5592,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))) @@ -5579,10 +5638,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-message vec 5 "Finding a suitable `touch' command") (let ((result (tramp-find-executable vec "touch" (tramp-get-remote-path vec))) - (tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + (tmpfile (tramp-make-tramp-temp-name vec))) ;; Busyboxes do support the "-t" option only when they have been ;; built with the DESKTOP config option. Let's check it. (when result @@ -5594,7 +5650,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (tramp-compat-file-local-name tmpfile)))) + (tramp-file-local-name tmpfile)))) (delete-file tmpfile)) result))) @@ -5697,27 +5753,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "import os; print (os.getuid())" "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) -(defun tramp-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-uid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-uid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-uid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) - (defun tramp-get-remote-gid-with-id (vec id-format) "Implement `tramp-get-remote-gid' for Tramp files using `id'." (tramp-send-command-and-read @@ -5748,26 +5783,59 @@ ID-FORMAT valid values are `string' and `integer'." "import os; print (os.getgid())" "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) -(defun tramp-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-gid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-gid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-gid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) +(defun tramp-get-remote-busybox (vec) + "Determine remote `busybox' command." + (with-tramp-connection-property vec "busybox" + (tramp-message vec 5 "Finding a suitable `busybox' command") + (tramp-find-executable vec "busybox" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-awk (vec) + "Determine remote `awk' command." + (with-tramp-connection-property vec "awk" + (tramp-message vec 5 "Finding a suitable `awk' command") + (or (tramp-find-executable vec "awk" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "awk"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " {} </dev/null")) + command))))) + +(defun tramp-get-remote-hexdump (vec) + "Determine remote `hexdump' command." + (with-tramp-connection-property vec "hexdump" + (tramp-message vec 5 "Finding a suitable `hexdump' command") + (or (tramp-find-executable vec "hexdump" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "hexdump"))) + (and busybox + (tramp-send-command-and-check vec (concat command " </dev/null")) + command))))) + +(defun tramp-get-remote-od (vec) + "Determine remote `od' command." + (with-tramp-connection-property vec "od" + (tramp-message vec 5 "Finding a suitable `od' command") + (or (tramp-find-executable vec "od" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "od"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " -A n </dev/null")) + command))))) + +(defun tramp-get-remote-chmod-h (vec) + "Check whether remote `chmod' supports nofollow argument." + (with-tramp-connection-property vec "chmod-h" + (tramp-message vec 5 "Finding a suitable `chmod' command with nofollow") + (let ((tmpfile (tramp-make-tramp-temp-name vec))) + (prog1 + (tramp-send-command-and-check + vec + (format + "ln -s foo %s && chmod -h %s 0777" + (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile))) + (delete-file tmpfile))))) (defun tramp-get-env-with-u-option (vec) "Check, whether the remote `env' command supports the -u option." @@ -5786,10 +5854,9 @@ the length of the file to be compressed. If no corresponding command is found, nil is returned." (when (and (integerp tramp-inline-compress-start-size) (> size tramp-inline-compress-start-size)) - (with-tramp-connection-property (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-compress vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil)))) + (tramp-get-connection-property (tramp-get-process vec) prop nil)))) (defun tramp-get-inline-coding (vec prop size) "Return the coding command related to PROP. @@ -5807,11 +5874,9 @@ function cell is returned to be applied on a buffer." ;; no inline coding is found. (ignore-errors (let ((coding - (with-tramp-connection-property - (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil))) + (tramp-get-connection-property (tramp-get-process vec) prop nil))) (prop1 (if (string-match-p "encoding" prop) "inline-compress" "inline-decompress")) compress) @@ -5889,9 +5954,6 @@ function cell is returned to be applied on a buffer." ;; likely to produce long command lines, and some shells choke on ;; long command lines. ;; -;; * Don't search for perl5 and perl. Instead, only search for perl and -;; then look if it's the right version (with `perl -v'). -;; ;; * When editing a remote CVS controlled file as a different user, VC ;; gets confused about the file locking status. Try to find out why ;; the workaround doesn't work. diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index bf77ab9dee8..1b6af2a2e33 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -75,12 +75,23 @@ ;;;###tramp-autoload (defcustom tramp-smb-conf "/dev/null" - "Path of the smb.conf file. -If it is nil, no smb.conf will be added to the `tramp-smb-program' + "Path of the \"smb.conf\" file. +If it is nil, no \"smb.conf\" will be added to the `tramp-smb-program' call, letting the SMB client use the default one." :group 'tramp :type '(choice (const nil) (file :must-match t))) +;;;###tramp-autoload +(defcustom tramp-smb-options nil + "List of additional options. +They are added to the `tramp-smb-program' call via \"--option '...'\". + +For example, if the deprecated SMB1 protocol shall be used, add to +this variable (\"client min protocol=NT1\") ." + :group 'tramp + :type '(repeat string) + :version "28.1") + (defvar tramp-smb-version nil "Version string of the SMB client.") @@ -135,6 +146,7 @@ call, letting the SMB client use the default one." "NT_STATUS_HOST_UNREACHABLE" "NT_STATUS_IMAGE_ALREADY_LOADED" "NT_STATUS_INVALID_LEVEL" + "NT_STATUS_INVALID_PARAMETER" "NT_STATUS_INVALID_PARAMETER_MIX" "NT_STATUS_IO_TIMEOUT" "NT_STATUS_LOGON_FAILURE" @@ -281,6 +293,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -329,10 +343,9 @@ This can be used to disable echo etc." "Invoke the SMB related OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-smb-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) @@ -420,16 +433,12 @@ pass to the OPERATION." v tramp-file-missing "Copying directory" "No such file or directory" dirname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (cond ;; We must use a local temporary directory. ((and t1 t2) - (let ((tmpdir - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (let ((tmpdir (tramp-compat-make-temp-name))) (unwind-protect (progn (make-directory tmpdir) @@ -457,11 +466,9 @@ pass to the OPERATION." (localname (file-name-as-directory (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E"))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -471,6 +478,10 @@ pass to the OPERATION." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (if t1 ;; Source is remote. @@ -539,10 +550,11 @@ pass to the OPERATION." ;; Handle KEEP-DATE argument. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes dirname)))) + (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless keep-date @@ -581,47 +593,47 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." tramp-file-missing "Copying file" "No such file or directory" filename)) - (let ((tmpfile (file-local-copy filename))) - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (tramp-compat-directory-name-p newname)) - (setq newname - (expand-file-name (file-name-nondirectory filename) newname))) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - (unless (tramp-smb-get-share v) - (tramp-error - v 'file-error "Target `%s' must contain a share name" newname)) - (unless (tramp-smb-send-command - v (format "put \"%s\" \"%s\"" - (tramp-compat-file-name-unquote filename) - (tramp-smb-get-localname v))) - (tramp-error - v 'file-error "Cannot copy `%s' to `%s'" filename newname)))))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (tramp-smb-get-share v) + (tramp-error + v 'file-error "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v (format "put \"%s\" \"%s\"" + (tramp-compat-file-name-unquote filename) + (tramp-smb-get-localname v))) + (tramp-error + v 'file-error "Cannot copy `%s' to `%s'" filename newname))))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive _trash) "Like `delete-directory' for Tramp files." @@ -692,11 +704,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (delete nil (mapcar (lambda (x) (when (string-match-p match x) x)) result)))) - ;; Append directory. + ;; Prepend directory. (when full (setq result (mapcar - (lambda (x) (format "%s/%s" directory x)) + (lambda (x) (format "%s/%s" (directory-file-name directory) x)) result))) ;; Sort them if necessary. (unless nosort (setq result (sort result #'string-lessp))) @@ -760,7 +772,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E"))) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -770,6 +783,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -858,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 @@ -884,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 @@ -894,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 @@ -970,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))))) @@ -1003,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 @@ -1188,9 +1218,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1244,7 +1272,7 @@ component is used as the target of the symlink." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -1357,7 +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 @@ -1414,7 +1442,8 @@ component is used as the target of the symlink." "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string)))) + "\n" "," acl-string))) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1424,6 +1453,10 @@ component is used as the target of the symlink." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -1454,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)) @@ -1468,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) +(defun tramp-smb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-properties v localname) - (unless (tramp-smb-send-command - v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename))))) + ;; smbclient chmod does not support nofollow. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (when (tramp-smb-get-cifs-capabilities v) + (tramp-flush-file-properties v localname) + (unless (tramp-smb-send-command + v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename)))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -1557,9 +1592,6 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1579,6 +1611,10 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Cannot write `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -1696,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: @@ -1758,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)) @@ -1772,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)) @@ -1789,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 @@ -1844,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) @@ -1861,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 \"/\"")))) @@ -1924,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) @@ -1949,6 +1983,7 @@ If ARGUMENT is non-nil, use it as argument for (host (tramp-file-name-host vec)) (domain (tramp-file-name-domain vec)) (port (tramp-file-name-port vec)) + (options tramp-smb-options) args) (cond @@ -1967,6 +2002,10 @@ If ARGUMENT is non-nil, use it as argument for (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (when argument (setq args (append args (list argument)))) @@ -1994,7 +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 @@ -2132,7 +2171,5 @@ Removes smb prompt. Returns nil if an error message has appeared." ;; ;; * Try to remove the inclusion of dummy "" directory. Seems to be at ;; several places, especially in `tramp-smb-handle-insert-directory'. -;; -;; * Ignore case in file names. ;;; tramp-smb.el ends here diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 08188cefde3..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)) @@ -265,10 +266,8 @@ absolute file names." v 0 (format "%s %s to %s" msg-operation filename newname) (unless (tramp-sudoedit-send-command v sudoedit-operation - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename)) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name newname))) + (tramp-unquote-file-local-name filename) + (tramp-unquote-file-local-name newname)) (tramp-error v 'file-error "Error %s `%s' `%s'" msg-operation filename newname)))) @@ -284,7 +283,8 @@ absolute file names." ;; Set the time and mode. Mask possible errors. (when keep-date (ignore-errors - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes))) ;; Handle `preserve-extended-attributes'. We ignore possible @@ -305,8 +305,8 @@ absolute file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -375,7 +375,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (zerop (tramp-call-process vec "getfacl" nil nil nil "/")))) (defun tramp-sudoedit-handle-file-acl (filename) @@ -466,19 +466,21 @@ the result will be a local, non-Tramp, file name." (tramp-sudoedit-send-command v "test" "-r" (tramp-compat-file-name-unquote localname))))) -(defun tramp-sudoedit-handle-set-file-modes (filename mode) +(defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (unless (tramp-sudoedit-send-command - v "chmod" (format "%o" mode) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) + ;; It is unlikely that "chmod -h" works. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (unless (tramp-sudoedit-send-command + v "chmod" (format "%o" mode) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename))))) (defun tramp-sudoedit-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (zerop (tramp-call-process vec "selinuxenabled")))) (defun tramp-sudoedit-handle-file-selinux-context (filename) @@ -486,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" @@ -513,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. @@ -524,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) +(defun tramp-sudoedit-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -537,14 +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) @@ -615,9 +615,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -646,8 +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)) @@ -691,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." @@ -713,22 +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))) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename))))) + (or uid (tramp-get-remote-uid v 'integer)) + (or gid (tramp-get-remote-gid v 'integer))) + (tramp-unquote-file-local-name filename)))) (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (with-parsed-tramp-file-name filename nil - (let ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-gid v 'integer))) - (modes (tramp-default-file-modes filename))) + (let* ((uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer))) + (flag (and (eq mustbenew 'excl) 'nofollow)) + (modes (tramp-default-file-modes filename flag))) (prog1 (tramp-handle-write-region start end filename append visit lockname mustbenew) @@ -742,7 +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. @@ -787,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 4f3249d966a..19cf3334502 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.4.3 -;; Package-Requires: ((emacs "24.4")) +;; Version: 2.5.0-pre +;; Package-Requires: ((emacs "25.1")) ;; Package-Type: multi ;; URL: https://savannah.gnu.org/projects/tramp @@ -37,7 +37,7 @@ ;; For more detailed instructions, please see the info file. ;; ;; Notes: -;; ----- +;; ------ ;; ;; Also see the todo list at the bottom of this file. ;; @@ -46,6 +46,7 @@ ;; ;; There's a mailing list for this, as well. Its name is: ;; tramp-devel@gnu.org + ;; You can use the Web to subscribe, under the following URL: ;; https://lists.gnu.org/mailman/listinfo/tramp-devel ;; @@ -63,6 +64,7 @@ ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function file-notify-rm-watch "filenotify") (declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) @@ -558,7 +560,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 @@ -599,7 +601,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." @@ -744,7 +746,7 @@ to be set, depending on VALUE." tramp-postfix-host-format (tramp-build-postfix-host-format) tramp-postfix-host-regexp (tramp-build-postfix-host-regexp) tramp-remote-file-name-spec-regexp - (tramp-build-remote-file-name-spec-regexp) + (tramp-build-remote-file-name-spec-regexp) tramp-file-name-structure (tramp-build-file-name-structure) tramp-file-name-regexp (tramp-build-file-name-regexp) tramp-completion-file-name-regexp @@ -795,9 +797,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 () @@ -841,7 +843,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 @@ -858,7 +860,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 @@ -886,7 +888,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 @@ -918,7 +920,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 @@ -1258,7 +1260,7 @@ calling HANDLER.") ;; data structure. ;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 24 and 25. +;; in order to be compatible with Emacs 25. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1306,9 +1308,10 @@ entry does not exist, return nil." ;; We use the cached property. (tramp-get-connection-property vec hash-entry nil) ;; Use the static value from `tramp-methods'. - (let ((methods-entry - (assoc param (assoc (tramp-file-name-method vec) tramp-methods)))) - (when methods-entry (cadr methods-entry)))))) + (when-let ((methods-entry + (assoc + param (assoc (tramp-file-name-method vec) tramp-methods)))) + (cadr methods-entry))))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-file-name-unquote-localname (vec) @@ -1347,6 +1350,11 @@ of `process-file', `start-file-process', or `shell-command'." (match-string (nth 4 tramp-file-name-structure) name)) (tramp-compat-file-local-name name))) +;; The localname can be quoted with "/:". Extract this. +(defun tramp-unquote-file-local-name (name) + "Return unquoted localname of NAME." + (tramp-compat-file-name-unquote (tramp-file-local-name name))) + (defun tramp-find-method (method user host) "Return the right method string to use depending on USER and HOST. This is METHOD, if non-nil. Otherwise, do a lookup in @@ -1363,8 +1371,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or host "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lmethod (nth 2 item)) - (setq choices nil))) + (setq lmethod (nth 2 item) + choices nil))) lmethod) tramp-default-method))) ;; We must mark, whether a default value has been used. @@ -1384,8 +1392,8 @@ This is USER, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or host ""))) - (setq luser (nth 2 item)) - (setq choices nil))) + (setq luser (nth 2 item) + choices nil))) luser) tramp-default-user))) ;; We must mark, whether a default value has been used. @@ -1405,8 +1413,8 @@ This is HOST, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lhost (nth 2 item)) - (setq choices nil))) + (setq lhost (nth 2 item) + choices nil))) lhost) tramp-default-host))) ;; We must mark, whether a default value has been used. @@ -1468,7 +1476,7 @@ default values are used." :method method :user user :domain domain :host host :port port :localname localname :hop hop)) ;; The method must be known. - (unless (or nodefault (tramp-completion-mode-p) + (unless (or nodefault non-essential (string-equal method tramp-default-method-marker) (assoc method tramp-methods)) (tramp-user-error @@ -1592,7 +1600,7 @@ necessary only. This function will be used in file name completion." tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host) tramp-postfix-host-format)) - (when localname localname))) + localname)) (defun tramp-get-buffer (vec &optional dont-create) "Get the connection buffer to be used for VEC. @@ -1625,6 +1633,15 @@ from the default one." (or (tramp-get-connection-property vec "process-name" nil) (tramp-buffer-name vec))) +(defun tramp-get-process (vec-or-proc) + "Get the default connection process to be used for VEC-OR-PROC. +Return `tramp-cache-undefined' in case it doesn't exist." + (or (and (tramp-file-name-p vec-or-proc) + (get-buffer-process (tramp-buffer-name vec-or-proc))) + (and (processp vec-or-proc) + (tramp-get-process (process-get vec-or-proc 'vector))) + tramp-cache-undefined)) + (defun tramp-get-connection-process (vec) "Get the connection process to be used for VEC. In case a second asynchronous communication has been started, it is different @@ -1648,7 +1665,7 @@ version, the function does nothing." "Set connection-local variables in the current buffer. If connection-local variables are not supported by this Emacs version, the function does nothing." - (when (file-remote-p default-directory) + (when (tramp-tramp-file-p default-directory) ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. (tramp-compat-funcall 'hack-connection-local-variables-apply @@ -1667,11 +1684,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 @@ -1744,29 +1760,10 @@ ARGUMENTS to actually emit the message (if applicable)." (setq btf (nth 1 (backtrace-frame btn))) (if (not btf) (setq fn "") - (when (symbolp btf) - (setq fn (symbol-name btf)) - (unless - (and - (string-match-p "^tramp" fn) - (not - (string-match-p - (eval-when-compile - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-funcall" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message" - "tramp-signal-hook-function" - "tramp-user-error") - t) - "$")) - fn))) - (setq fn nil))) + (and (symbolp btf) (setq fn (symbol-name btf)) + (or (not (string-match-p "^tramp" fn)) + (get btf 'tramp-suppress-trace)) + (setq fn nil)) (setq btn (1+ btn)))) ;; The following code inserts filename and line number. Should ;; be inactive by default, because it is time consuming. @@ -1781,11 +1778,11 @@ ARGUMENTS to actually emit the message (if applicable)." ;; The message. (insert (apply #'format-message fmt-string arguments)))) -(defvar tramp-message-show-message (null noninteractive) - "Show Tramp message in the minibuffer. -This variable is used to suppress progress reporter output, and -to disable messages from `tramp-error'. Those messages are -visible anyway, because an error is raised.") +(put #'tramp-debug-message 'tramp-suppress-trace t) + +(defvar tramp-inhibit-progress-reporter nil + "Show Tramp progress reporter in the minibuffer. +This variable is used to disable concurrent progress reporter messages.") (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -1802,8 +1799,9 @@ control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (ignore-errors (when (<= level tramp-verbose) - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) + ;; Display only when there is a minimum level, and the progress + ;; reporter doesn't suppress further messages. + (when (and (<= level 3) (null tramp-inhibit-progress-reporter)) (apply #'message (concat (cond @@ -1835,6 +1833,8 @@ applicable)." (concat (format "(%d) # " level) fmt-string) arguments)))))) +(put #'tramp-message 'tramp-suppress-trace t) + (defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This @@ -1845,13 +1845,16 @@ function is meant for debugging purposes." vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) +(put #'tramp-backtrace 'tramp-suppress-trace t) + (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised with FMT-STRING and ARGUMENTS." - (let (tramp-message-show-message signal-hook-function) + (let ((inhibit-message t) + signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments ;; FMT-STRING could be just a file name, as in @@ -1869,6 +1872,8 @@ FMT-STRING and ARGUMENTS." (signal signal (list (substring-no-properties (apply #'format-message fmt-string arguments)))))) +(put #'tramp-error 'tramp-suppress-trace t) + (defsubst tramp-error-with-buffer (buf vec-or-proc signal fmt-string &rest arguments) "Emit an error, and show BUF. @@ -1886,13 +1891,13 @@ an input event arrives. The other arguments are passed to `tramp-error'." (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. (when (and buf - tramp-message-show-message (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + inhibit-message) ;; `tramp-error' does not show messages. So we must do it ;; ourselves. (apply #'message fmt-string arguments) @@ -1904,19 +1909,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +(put #'tramp-error-with-buffer 'tramp-suppress-trace t) + ;; We must make it a defun, because it is used earlier already. (defun tramp-user-error (vec-or-proc fmt-string &rest arguments) "Signal a user error (or \"pilot error\")." (unwind-protect (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) ;; Save exit. - (when (and tramp-message-show-message - (not (zerop tramp-verbose)) + (when (and (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + inhibit-message) ;; `tramp-error' does not show messages. So we must do it ourselves. (apply #'message fmt-string arguments) (discard-input) @@ -1926,18 +1933,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +(put #'tramp-user-error 'tramp-suppress-trace t) + (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) "Execute BODY while redirecting the error message to `tramp-message'. BODY is executed like wrapped by `with-demoted-errors'. FORMAT is a format-string containing a %-sequence meaning to substitute the resulting error message." - (declare (debug (symbolp body)) - (indent 2)) + (declare (indent 2) (debug (symbolp form body))) (let ((err (make-symbol "err"))) `(condition-case-unless-debug ,err (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) +(put #'tramp-with-demoted-errors 'tramp-suppress-trace t) + ;; This function provides traces in case of errors not triggered by ;; Tramp functions. (defun tramp-signal-hook-function (error-symbol data) @@ -1949,6 +1959,8 @@ the resulting error message." (car tramp-current-connection) error-symbol "%s" (mapconcat (lambda (x) (format "%s" x)) data " ")))) +(put #'tramp-signal-hook-function 'tramp-suppress-trace t) + (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -1965,12 +1977,14 @@ Remaining args are Lisp expressions to be evaluated (inside an implicit If VAR is nil, then we bind `v' to the structure and `method', `user', `domain', `host', `port', `localname', `hop' to the components." + (declare (indent 2) (debug (form symbolp body))) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(tramp-compat-tramp-file-name-slots)))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))) `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, @@ -1979,8 +1993,6 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (ignore ,@(mapcar #'car bindings)) ,@body))) -(put 'with-parsed-tramp-file-name 'lisp-indent-function 2) -(put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defun tramp-progress-reporter-update (reporter &optional value suffix) @@ -1991,25 +2003,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))))) @@ -2020,6 +2037,7 @@ without a visible progress reporter." (defmacro with-tramp-file-property (vec file property &rest body) "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. FILE must be a local file name on a connection identified via VEC." + (declare (indent 3) (debug t)) `(if (file-name-absolute-p ,file) (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) (when (eq value 'undef) @@ -2031,12 +2049,11 @@ FILE must be a local file name on a connection identified via VEC." value) ,@body)) -(put 'with-tramp-file-property 'lisp-indent-function 3) -(put 'with-tramp-file-property 'edebug-form-spec t) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) (defmacro with-tramp-connection-property (key property &rest body) "Check in Tramp for property PROPERTY, otherwise execute BODY and set." + (declare (indent 2) (debug t)) `(let ((value (tramp-get-connection-property ,key ,property 'undef))) (when (eq value 'undef) ;; We cannot pass ,@body as parameter to @@ -2046,8 +2063,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\\>")) @@ -2060,12 +2075,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). @@ -2098,10 +2116,10 @@ Example: (zerop (tramp-call-process v "reg" nil nil nil "query" (nth 1 (car v)))))) - ;; Zeroconf service type. + ;; DNS-SD service type. ((string-match-p - "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v)))) - ;; Configuration file. + tramp-dns-sd-service-regexp (nth 1 (car v)))) + ;; Configuration file or empty string. (t (file-exists-p (nth 1 (car v)))))) (setq r (delete (car v) r))) (setq v (cdr v))) @@ -2139,11 +2157,13 @@ For definition of that list see `tramp-set-completion-function'." (defvar tramp-devices 0 "Keeps virtual device numbers.") -(defun tramp-default-file-modes (filename) +(defun tramp-default-file-modes (filename &optional flag) "Return file modes of FILENAME as integer. -If the file modes of FILENAME cannot be determined, return the -value of `default-file-modes', without execute permissions." - (or (file-modes filename) +If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a +symbolic link. If the file modes of FILENAME cannot be +determined, return the value of `default-file-modes', without +execute permissions." + (or (tramp-compat-file-modes filename flag) (logand (default-file-modes) #o0666))) (defun tramp-replace-environment-variables (filename) @@ -2174,6 +2194,7 @@ arguments to pass to the OPERATION." tramp-vc-file-name-handler tramp-completion-file-name-handler tramp-archive-file-name-handler + tramp-crypt-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . @@ -2239,7 +2260,7 @@ Must be handled by the callers." file-newer-than-file-p rename-file)) (cond ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + ((file-name-absolute-p (nth 1 args)) (nth 1 args)) (t default-directory))) ;; FILE DIRECTORY resp FILE1 FILE2. ((eq operation 'expand-file-name) @@ -2267,13 +2288,13 @@ Must be handled by the callers." exec-path make-process)) default-directory) ;; PROC. - ((member operation - '(file-notify-rm-watch - ;; Emacs 25+ only. - file-notify-valid-p)) + ((member operation '(file-notify-rm-watch file-notify-valid-p)) (when (processp (nth 0 args)) (with-current-buffer (process-buffer (nth 0 args)) default-directory))) + ;; VEC. + ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) + (tramp-make-tramp-file-name (nth 0 args))) ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) @@ -2390,7 +2411,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (cons operation args)) (tramp-run-real-handler operation args)) ((eq result 'suppress) - (let (tramp-message-show-message) + (let ((inhibit-message t)) (tramp-message v 1 "Suppress received in operation %s" (cons operation args)) @@ -2419,18 +2440,21 @@ Fall back to normal file name handler if no Tramp file name handler exists." (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler for OPERATION and ARGS. Falls back to normal file name handler if no Tramp file name handler exists." - (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) - (if (and fn tramp-mode) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let + ((fn (and tramp-mode + (assoc operation tramp-completion-file-name-handler-alist)))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) - (if tramp-mode - (let ((default-directory temporary-file-directory)) - (load "tramp" 'noerror 'nomessage))) + (when tramp-mode + ;; We cannot use `tramp-compat-temporary-file-directory' here due + ;; to autoload. + (let ((default-directory temporary-file-directory)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2442,7 +2466,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) - (put 'tramp-autoload-file-name-handler 'safe-magic t))) + (put #'tramp-autoload-file-name-handler 'safe-magic t))) ;;;###autoload (tramp-register-autoload-file-name-handlers) @@ -2478,34 +2502,36 @@ remote file names." (tramp-unload-file-name-handlers) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler' and - ;; `tramp-archive-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler', + ;; `tramp-archive-file-name-handler' and + ;; `tramp-crypt-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp #'tramp-file-name-handler)) - (put 'tramp-file-name-handler 'safe-magic t) + (put #'tramp-file-name-handler 'safe-magic t) + + (tramp-register-crypt-file-name-handler) (add-to-list 'file-name-handler-alist (cons tramp-completion-file-name-regexp #'tramp-completion-file-name-handler)) - (put 'tramp-completion-file-name-handler 'safe-magic t) + (put #'tramp-completion-file-name-handler 'safe-magic t) ;; Mark `operations' the handler is responsible for. - (put 'tramp-completion-file-name-handler 'operations + (put #'tramp-completion-file-name-handler 'operations (mapcar #'car tramp-completion-file-name-handler-alist)) (when (bound-and-true-p tramp-archive-enabled) (add-to-list 'file-name-handler-alist (cons tramp-archive-file-name-regexp #'tramp-archive-file-name-handler)) - (put 'tramp-archive-file-name-handler 'safe-magic t)) + (put #'tramp-archive-file-name-handler 'safe-magic t)) ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) - (let ((entry (rassoc fnh file-name-handler-alist))) - (when entry - (setq file-name-handler-alist - (cons entry (delete entry file-name-handler-alist))))))) + (when-let ((entry (rassoc fnh file-name-handler-alist))) + (setq file-name-handler-alist + (cons entry (delete entry file-name-handler-alist)))))) (tramp--with-startup (tramp-register-file-name-handlers)) @@ -2517,7 +2543,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (add-to-list 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) ;; Mark `operations' the handler is responsible for. - (put 'tramp-file-name-handler + (put #'tramp-file-name-handler 'operations (delete-dups (append @@ -2558,24 +2584,11 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;; File name handler functions for completion mode: -;;;###autoload -(defvar tramp-completion-mode nil - "If non-nil, external packages signal that they are in file name completion.") -(make-obsolete-variable 'tramp-completion-mode 'non-essential "26.1") - -(defun tramp-completion-mode-p () - "Check, whether method / user name / host name completion is active." - (or - ;; Signal from outside. - non-essential - ;; This variable has been obsoleted in Emacs 26. - tramp-completion-mode)) - (defun tramp-connectable-p (vec-or-filename) "Check, whether it is possible to connect the remote host w/o side-effects. This is true, if either the remote host is already connected, or if we are not in completion mode." - (let (tramp-verbose + (let ((tramp-verbose 0) (vec (cond ((tramp-file-name-p vec-or-filename) vec-or-filename) @@ -2585,7 +2598,7 @@ not in completion mode." ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. (and vec (process-live-p (get-process (tramp-buffer-name vec)))) - (not (tramp-completion-mode-p))))) + (not non-essential)))) ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of @@ -2864,7 +2877,7 @@ User is always nil." (let ((default-directory (tramp-compat-temporary-file-directory))) (when (file-readable-p filename) (with-temp-buffer - (insert-file-contents filename) + (insert-file-contents-literally filename) (goto-char (point-min)) (cl-loop while (not (eobp)) collect (funcall function)))))) @@ -2876,7 +2889,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 "\\)" @@ -2926,7 +2939,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. @@ -2961,7 +2974,7 @@ Host is always \"localhost\"." (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (regexp (concat "^\\(" tramp-user-regexp "\\):"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list (match-string 1) "localhost"))) @@ -2983,7 +2996,7 @@ Host is always \"localhost\"." (defun tramp-parse-etc-group-group () "Return a (group host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (split (split-string (buffer-substring (point) (point-at-eol)) ":"))) (when (member (user-login-name) (split-string (nth 3 split) "," 'omit)) (setq result (list (nth 0 split) "localhost"))) @@ -3020,7 +3033,7 @@ User is always nil." (defun tramp-parse-putty-group (registry) "Return a (user host) tuple allowed to access. User is always nil." - (let ((result) + (let (result (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list nil (match-string 1)))) @@ -3199,12 +3212,13 @@ User is always nil." (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) -(defun tramp-handle-file-modes (filename) +(defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." - ;; Starting with Emacs 25.1, `when-let' can be used. - (let ((attrs (file-attributes (or (file-truename filename) filename)))) - (when attrs - (tramp-mode-string-to-int (tramp-compat-file-attribute-modes attrs))))) + (when-let ((attrs (file-attributes filename)) + (mode-string (tramp-compat-file-attribute-modes attrs))) + (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) + (file-modes (file-truename filename)) + (tramp-mode-string-to-int mode-string)))) ;; Localname manipulation functions that grok Tramp localnames... (defun tramp-handle-file-name-as-directory (file) @@ -3242,12 +3256,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-compat-file-local-name candidate)) + "[[:lower:]]" (tramp-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3256,9 +3271,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-compat-file-local-name candidate)) + (unless (string-match-p + "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3271,7 +3285,7 @@ User is always nil." (file-exists-p (concat (file-remote-p candidate) - (upcase (tramp-compat-file-local-name candidate)))) + (upcase (tramp-file-local-name candidate)))) ;; Cleanup. (when tmpfile (delete-file tmpfile))))))))))) @@ -3323,21 +3337,18 @@ User is always nil." (cond ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) - (t (time-less-p (tramp-compat-file-attribute-modification-time - (file-attributes file2)) - (tramp-compat-file-attribute-modification-time - (file-attributes file1)))))) + (t (time-less-p + (tramp-compat-file-attribute-modification-time (file-attributes file2)) + (tramp-compat-file-attribute-modification-time + (file-attributes file1)))))) (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." (and (file-exists-p filename) ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. - (ignore-errors - (eq ?- - (aref - (tramp-compat-file-attribute-modes (file-attributes filename)) - 0))))) + (when-let ((attr (file-attributes filename))) + (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3376,8 +3387,7 @@ User is always nil." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -3389,6 +3399,8 @@ User is always nil." ;; something is wrong; otherwise they might think that Emacs ;; is hung. Of course, correctness has to come first. (numchase-limit 20) + ;; Unquoting could enable encryption. + tramp-crypt-enabled symlink-target) (with-parsed-tramp-file-name result v1 ;; We cache only the localname. @@ -3413,7 +3425,7 @@ User is always nil." (tramp-error v1 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (tramp-compat-file-local-name (directory-file-name result))))))))) + (tramp-file-local-name (directory-file-name result))))))))) (defun tramp-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -3448,7 +3460,7 @@ User is always nil." "Like `insert-directory' for Tramp files." (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (tramp-compat-directory-name-p filename) + (when (and (directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) ;; Check, whether directory is accessible. @@ -3458,7 +3470,7 @@ User is always nil." (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (let (ls-lisp-use-insert-directory-program start) ;; Silence byte compiler. - ls-lisp-use-insert-directory-program + (ignore ls-lisp-use-insert-directory-program) (tramp-run-real-handler #'insert-directory (list filename switches wildcard full-directory-p)) @@ -3509,6 +3521,9 @@ User is always nil." ;; copy this part. This works only for the shell file ;; name handlers. (when (and (or beg end) + ;; Direct actions aren't possible for + ;; crypted directories. + (null tramp-crypt-enabled) (tramp-get-method-parameter v 'tramp-login-program)) (setq remote-copy (tramp-make-tramp-temp-file v)) @@ -3582,8 +3597,8 @@ User is always nil." ;; Save exit. (progn (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) + (setq buffer-file-name filename + buffer-read-only (not (file-writable-p filename))) (set-visited-file-modtime) (set-buffer-modified-p nil)) (when (and (stringp local-copy) @@ -3617,7 +3632,8 @@ User is always nil." v tramp-file-missing "Cannot load nonexistent file `%s'" file)) (if (not (file-exists-p file)) nil - (let ((tramp-message-show-message (not nomessage))) + (let ((signal-hook-function (unless noerror signal-hook-function)) + (inhibit-message (or inhibit-message nomessage))) (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) (unwind-protect @@ -3645,10 +3661,16 @@ support symbolic links." (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) (command (substring command 0 asynchronous)) current-buffer-p + (output-buffer-p output-buffer) (output-buffer (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) + ((bufferp output-buffer) + (setq current-buffer-p (eq (current-buffer) output-buffer)) + output-buffer) + ((stringp output-buffer) + (setq current-buffer-p + (eq (buffer-name (current-buffer)) output-buffer)) + (get-buffer-create output-buffer)) (output-buffer (setq current-buffer-p t) (current-buffer)) @@ -3660,13 +3682,19 @@ support symbolic links." (cond ((bufferp error-buffer) error-buffer) ((stringp error-buffer) (get-buffer-create error-buffer)))) + (error-file + (and error-buffer + (with-parsed-tramp-file-name default-directory nil + (tramp-make-tramp-file-name + v (tramp-make-tramp-temp-file v))))) (bname (buffer-name output-buffer)) (p (get-buffer-process output-buffer)) + (dir default-directory) buffer) ;; The following code is taken from `shell-command', slightly ;; adapted. Shouldn't it be factored out? - (when p + (when (and (integerp asynchronous) p) (cond ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. @@ -3698,22 +3726,25 @@ support symbolic links." (rename-uniquely)) (setq output-buffer (get-buffer-create bname))))) - (setq buffer (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer - (tramp-make-tramp-file-name - v (tramp-make-tramp-temp-file v)))) - output-buffer)) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) + (unless output-buffer-p (with-current-buffer output-buffer + (setq default-directory dir))) + + (setq buffer (if error-file (list output-buffer error-file) output-buffer)) + + (with-current-buffer output-buffer + (when current-buffer-p + (barf-if-buffer-read-only) + (push-mark nil t)) + ;; `shell-command-save-pos-or-erase' has been introduced with + ;; Emacs 27.1. + (if (fboundp 'shell-command-save-pos-or-erase) + (tramp-compat-funcall + 'shell-command-save-pos-or-erase current-buffer-p) (setq buffer-read-only nil) (erase-buffer))) - (if (and (not current-buffer-p) (integerp asynchronous)) + (if (integerp asynchronous) (let ((tramp-remote-process-environment ;; `async-shell-command-width' has been introduced with ;; Emacs 27.1. @@ -3726,42 +3757,69 @@ support symbolic links." ;; Run the process. (setq p (start-file-process-shell-command (buffer-name output-buffer) buffer command)) - ;; Display output. - (with-current-buffer output-buffer - (display-buffer output-buffer '(nil (allow-no-window . t))) - (setq mode-line-process '(":%s")) - (shell-mode) - (set-process-sentinel p #'shell-command-sentinel) - (set-process-filter p #'comint-output-filter)))) + ;; Insert error messages if they were separated. + (when error-file + (with-current-buffer error-buffer + (insert-file-contents-literally error-file))) + (if (process-live-p p) + ;; Display output. + (with-current-buffer output-buffer + (setq mode-line-process '(":%s")) + (unless (eq major-mode 'shell-mode) + (shell-mode)) + (set-process-filter p #'comint-output-filter) + (set-process-sentinel p #'shell-command-sentinel) + (when error-file + (add-function + :after (process-sentinel p) + (lambda (_proc _string) + (with-current-buffer error-buffer + (insert-file-contents-literally + error-file nil nil nil 'replace)) + (delete-file error-file)))) + (display-buffer output-buffer '(nil (allow-no-window . t)))) + + (when error-file + (delete-file error-file))))) (prog1 ;; Run the process. (process-file-shell-command command nil buffer nil) ;; Insert error messages if they were separated. - (when (listp buffer) + (when error-file (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) + (insert-file-contents-literally error-file)) + (delete-file error-file)) (if current-buffer-p ;; This is like exchange-point-and-mark, but doesn't ;; activate the mark. It is cleaner to avoid activation, ;; even though the command loop would deactivate the mark ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) + (progn + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) + (current-buffer)))) + ;; `shell-command-set-point-after-cmd' has been + ;; introduced with Emacs 27.1. + (if (fboundp 'shell-command-set-point-after-cmd) + (tramp-compat-funcall + 'shell-command-set-point-after-cmd))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) (defun tramp-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - ;; `make-process' knows the `:file-handler' argument since Emacs 27.1 only. + "Like `start-file-process' for Tramp files. +BUFFER might be a list, in this case STDERR is separated." + ;; `make-process' knows the `:file-handler' argument since Emacs + ;; 27.1 only. Therefore, we invoke it via `tramp-file-name-handler'. (tramp-file-name-handler 'make-process :name name - :buffer buffer + :buffer (if (consp buffer) (car buffer) buffer) :command (and program (cons program args)) + ;; `shell-command' adds an errfile to `buffer'. + :stderr (when (consp buffer) (cadr buffer)) :noquery nil :file-handler t)) @@ -3862,7 +3920,14 @@ of." (tramp-error v 'file-already-exists filename)) (let ((tmpfile (tramp-compat-make-temp-file filename)) - (modes (save-excursion (tramp-default-file-modes filename)))) + (modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + (uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -3881,15 +3946,18 @@ of." (error (delete-file tmpfile) (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) + v 'file-error "Couldn't write region to `%s'" filename))) - (tramp-flush-file-properties v localname) + (tramp-flush-file-properties v localname) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; Set the ownership. + (tramp-set-file-uid-gid filename uid gid)) ;; The end. (when (and (null noninteractive) @@ -3943,7 +4011,7 @@ of." "Call `file-notify-rm-watch'." (unless (process-live-p proc) (tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-compat-funcall 'file-notify-rm-watch proc))) + (file-notify-rm-watch proc))) ;;; Functions for establishing connection: @@ -4044,6 +4112,8 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." (unless (process-live-p proc) + ;; There might be pending output. + (while (tramp-accept-process-output proc 0)) (throw 'tramp-action 'process-died))) (defun tramp-action-out-of-band (proc vec) @@ -4083,9 +4153,9 @@ See `tramp-process-actions' for the format of ACTIONS." (while (tramp-accept-process-output proc 0)) (setq todo actions) (while todo - (setq item (pop todo)) - (setq pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item)))) - (setq action (nth 1 item)) + (setq item (pop todo) + pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item))) + action (nth 1 item)) (tramp-message vec 5 "Looking for regexp \"%s\" from remote shell" pattern) (when (tramp-check-for-regexp proc pattern) @@ -4135,9 +4205,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))) @@ -4158,10 +4227,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" @@ -4176,18 +4244,21 @@ performed successfully. Any other value means an error." (defun tramp-accept-process-output (proc &optional timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set -for process communication also." +for process communication also. +If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." (with-current-buffer (process-buffer proc) (let ((inhibit-read-only t) last-coding-system-used result) - ;; JUST-THIS-ONE is set due to Bug#12145. - (tramp-message - proc 10 "%s %s %s %s\n%s" - proc timeout (process-status proc) - (with-local-quit - (setq result (accept-process-output proc timeout nil t))) - (buffer-string)) + ;; JUST-THIS-ONE is set due to Bug#12145. `with-local-quit' + ;; returns t in order to report success. + (if (with-local-quit + (setq result (accept-process-output proc timeout nil t)) t) + (tramp-message + proc 10 "%s %s %s %s\n%s" + proc timeout (process-status proc) result (buffer-string)) + ;; Propagate quit. + (keyboard-quit)) result))) (defun tramp-search-regexp (regexp) @@ -4362,7 +4433,7 @@ would yield t. On the other hand, the following check results in nil: (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\") If both files are local, the function returns t." - (or (and (null (file-remote-p file1)) (null (file-remote-p file2))) + (or (and (null (tramp-tramp-file-p file1)) (null (tramp-tramp-file-p file2))) (and (tramp-tramp-file-p file1) (tramp-tramp-file-p file2) (string-equal (file-remote-p file1) (file-remote-p file2))))) @@ -4455,9 +4526,9 @@ This is used to map a mode number to a permission string.") (suid (> (logand (ash mode -9) 4) 0)) (sgid (> (logand (ash mode -9) 2) 0)) (sticky (> (logand (ash mode -9) 1) 0))) - (setq user (tramp-file-mode-permissions user suid "s")) - (setq group (tramp-file-mode-permissions group sgid "s")) - (setq other (tramp-file-mode-permissions other sticky "t")) + (setq user (tramp-file-mode-permissions user suid "s") + group (tramp-file-mode-permissions group sgid "s") + other (tramp-file-mode-permissions other sticky "t")) (concat type user group other))) (defun tramp-file-mode-permissions (perm suid suid-text) @@ -4487,16 +4558,15 @@ If FILENAME is remote, a file name handler is called." (when (and modes (not (zerop (logand modes #o2000)))) (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) - (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) - (if handler - (funcall handler #'tramp-set-file-uid-gid filename uid gid) - ;; On W32 systems, "chown" does not work. - (unless (memq system-type '(ms-dos windows-nt)) - (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-call-process - nil "chown" nil nil nil (format "%d:%d" uid gid) - (tramp-unquote-shell-quote-argument filename))))))) + (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) + (funcall handler #'tramp-set-file-uid-gid filename uid gid) + ;; On W32 systems, "chown" does not work. + (unless (memq system-type '(ms-dos windows-nt)) + (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-call-process + nil "chown" nil nil nil (format "%d:%d" uid gid) + (tramp-unquote-shell-quote-argument filename)))))) (defun tramp-get-local-uid (id-format) "The uid of the local user, in ID-FORMAT. @@ -4562,12 +4632,8 @@ be granted." (concat "file-attributes-" suffix) nil) (file-attributes (tramp-make-tramp-file-name vec) (intern suffix)))) - (remote-uid - (tramp-get-connection-property - vec (concat "uid-" suffix) nil)) - (remote-gid - (tramp-get-connection-property - vec (concat "gid-" suffix) nil)) + (remote-uid (tramp-get-remote-uid vec (intern suffix))) + (remote-gid (tramp-get-remote-gid vec (intern suffix))) (unknown-id (if (string-equal suffix "string") tramp-unknown-id-string tramp-unknown-id-integer))) @@ -4601,6 +4667,32 @@ be granted." (tramp-compat-file-attribute-group-id file-attr)))))))))))) +(defun tramp-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "uid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-uid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + +(defun tramp-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "gid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-gid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise. This handles also chrooted environments, which are not regarded as local." @@ -4615,15 +4707,15 @@ This handles also chrooted environments, which are not regarded as local." ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. (tramp-get-method-parameter vec 'tramp-login-program) + ;; Direct actions aren't possible for crypted directories. + (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) - ;; This is defined in tramp-sh.el. Let's assume this is - ;; loaded already. - (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer)))))) + (zerop (tramp-get-remote-uid vec 'integer)))))) (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." @@ -4632,22 +4724,25 @@ This handles also chrooted environments, which are not regarded as local." (tramp-make-tramp-file-name vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) - (tramp-compat-file-local-name dir)) + (tramp-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) +(defun tramp-make-tramp-temp-name (vec) + "Generate a temporary file name on the remote host identified by VEC." + (make-temp-name + (expand-file-name tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))) + (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." - (let ((prefix (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))) - result) + (let (result) (while (not result) ;; `make-temp-file' would be the natural choice for ;; implementation. But it calls `write-region' internally, ;; which also needs a temporary file - we would end in an ;; infinite loop. - (setq result (make-temp-name prefix)) + (setq result (tramp-make-tramp-temp-name vec)) (if (file-exists-p result) (setq result nil) ;; This creates the file by side effect. @@ -4655,7 +4750,7 @@ Return the local name of the temporary file." (set-file-modes result #o0700))) ;; Return the local part. - (with-parsed-tramp-file-name result nil localname))) + (tramp-file-local-name result))) (defun tramp-delete-temp-file-function () "Remove temporary files related to current buffer." @@ -4682,7 +4777,7 @@ this file, if that variable is non-nil." (let ((system-type (if (and (stringp tramp-auto-save-directory) - (file-remote-p tramp-auto-save-directory)) + (tramp-tramp-file-p tramp-auto-save-directory)) 'not-windows system-type)) (auto-save-file-name-transforms @@ -4820,11 +4915,29 @@ verbosity of 6." (tramp-message vec 6 "%s" result) result)) +(defun tramp-process-running-p (process-name) + "Return t if system process PROCESS-NAME is running for `user-login-name'." + (when (stringp process-name) + (catch 'result + (dolist (pid (list-system-processes)) + (when-let ((attributes (process-attributes pid)) + (comm (cdr (assoc 'comm attributes)))) + (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) + ;; The returned command name could be truncated to 15 + ;; characters. Therefore, we cannot check for `string-equal'. + (string-prefix-p comm process-name) + (throw 'result t))))))) + (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." - (let* ((case-fold-search t) + (let* (;; If `auth-sources' contains "~/.authinfo.gpg", and + ;; `exec-path' contains a relative file name like ".", it + ;; could happen that the "gpg" command is not found. So we + ;; adapt `default-directory'. (Bug#39389, Bug#39489) + (default-directory (tramp-compat-temporary-file-directory)) + (case-fold-search t) (key (tramp-make-tramp-file-name ;; In tramp-sh.el, we must use "password-vector" due to ;; multi-hop. @@ -4976,10 +5089,12 @@ name of a process or buffer, or nil to default to the current buffer." (tramp-error proc 'error "Process %s is not active" proc) (tramp-message proc 5 "Interrupt process %s with pid %s" proc pid) ;; This is for tramp-sh.el. Other backends do not support this (yet). + ;; Not all "kill" implementations support process groups by + ;; negative pid, so we try both variants. (tramp-compat-funcall 'tramp-send-command (process-get proc 'vector) - (format "kill -2 -%d" pid)) + (format "(\\kill -2 -%d || \\kill -2 %d) 2>/dev/null" pid pid)) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. (while (tramp-accept-process-output proc 0)) @@ -4993,6 +5108,23 @@ name of a process or buffer, or nil to default to the current buffer." (lambda () (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(defun tramp-get-signal-strings () + "Strings to return by `process-file' in case of signals." + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil "signal-strings" + (let (result) + (if (and (stringp shell-file-name) (executable-find shell-file-name)) + (dotimes (i 128) + (push + (if (= i 19) 1 ;; SIGSTOP + (call-process + shell-file-name nil nil nil "-c" (format "kill -%d $$" i))) + result)) + (dotimes (i 128) + (push (format "Signal %d" i) result))) + ;; Due to Bug#41287, we cannot add this to the `dotimes' clause. + (reverse result)))) + ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' @@ -5034,16 +5166,5 @@ name of a process or buffer, or nil to default to the current buffer." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. -;; -;; * Get rid of `shell-command'. In its primary implementation, it -;; uses `process-file-shell-command' and -;; `start-file-process-shell-command', which is sufficient due to -;; connection-local `shell-file-name'. - ;;; tramp.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index dacdd44102f..8d21133b3b1 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -35,11 +35,8 @@ ;; Emacs version check is defined in macro AC_EMACS_INFO of ;; aclocal.m4; should be changed only there. -;; Needed for Emacs 24. -(defvar inhibit-message) - ;;;###tramp-autoload -(defconst tramp-version "2.4.3.27.1" +(defconst tramp-version "2.5.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -51,6 +48,7 @@ ;; Suppress message from `emacs-repository-get-branch'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. @@ -64,6 +62,7 @@ ;; Suppress message from `emacs-repository-get-version'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) (and (stringp dir) (file-directory-p dir) @@ -71,9 +70,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "24.4")) +(let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.4.3.27.1 is not fit for %s" + (format "Tramp 2.5.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) @@ -102,8 +101,3 @@ (provide 'trampver) ;;; trampver.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 6edd03c39cc..8bb156199c5 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -1,4 +1,4 @@ -;;; webjump.el --- programmable Web hotlist +;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc. @@ -323,8 +323,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (defun webjump-read-url-choice (what urls &optional default) ;; Note: Convert this to use `webjump-read-choice' someday. - (let* ((completions (mapcar (function (lambda (n) (cons n n))) - urls)) + (let* ((completions (mapcar (lambda (n) (cons n n)) urls)) (input (completing-read (concat what ;;(if default " (RET for default)" "") ": ") |