diff options
Diffstat (limited to 'lisp/net')
38 files changed, 2136 insertions, 2014 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 4d97dbcc96a..9937c022d9f 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1230,8 +1230,9 @@ only return the directory part of FILE." ;; found another machine with the same user. ;; Try that account. (read-passwd - (format "passwd for %s@%s (default same as %s@%s): " - user host user other) + (format-prompt "passwd for %s@%s" + (format "same as %s@%s" user other) + user host) nil (ange-ftp-lookup-passwd other user)) @@ -2546,13 +2547,16 @@ can parse the output from a DIR listing for a host of type TYPE.") (defvar ange-ftp-after-parse-ls-hook nil "Normal hook run after parsing the text of an FTP directory listing.") +(declare-function ls-lisp--sanitize-switches "ls-lisp" (switches)) + (defun ange-ftp-ls (file lsargs parse &optional no-error wildcard) "Return the output of a `DIR' or `ls' command done over FTP. FILE is the full name of the remote file, LSARGS is any args to pass to the `ls' command, and PARSE specifies that the output should be parsed and stored away in the internal cache." - (while (string-match "^--dired\\s-+" lsargs) - (setq lsargs (replace-match "" nil t lsargs))) + (while (string-match "--" lsargs) + (require 'ls-lisp) + (setq lsargs (ls-lisp--sanitize-switches lsargs))) ;; If parse is t, we assume that file is a directory. i.e. we only parse ;; full directory listings. (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file)) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index ccfbf51e48c..776f774172f 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,6 +39,7 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany GNOME Web (Epiphany) Don't know +;; browse-url-webpositive WebPositive 1.2-alpha (Haiku R1/beta3) ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -156,6 +157,7 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "GNOME Web (Epiphany)" :value browse-url-epiphany) + (function-item :tag "WebPositive" :value browse-url-webpositive) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -219,7 +221,7 @@ be used instead." (defcustom browse-url-button-regexp (concat - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|gemini\\|" "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" "\\(//[-a-z0-9_.]+:[0-9]*\\)?" (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") @@ -238,33 +240,6 @@ be used instead." :version "27.1" :type 'regexp) -(defcustom browse-url-netscape-program "netscape" - ;; Info about netscape-remote from Karl Berry. - "The name by which to invoke Netscape. - -The free program `netscape-remote' from -<URL:http://home.netscape.com/newsref/std/remote.c> is said to start -up very much quicker than `netscape'. Reported to compile on a GNU -system, given vroot.h from the same directory, with cc flags - -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11." - :type 'string) - -(make-obsolete-variable 'browse-url-netscape-program nil "25.1") - -(defcustom browse-url-netscape-arguments nil - "A list of strings to pass to Netscape as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-arguments nil "25.1") - -(defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments - "A list of strings to pass to Netscape when it starts up. -Defaults to the value of `browse-url-netscape-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-startup-arguments nil "25.1") - (defcustom browse-url-browser-display nil "The X display for running the browser, if not same as Emacs's." :type '(choice string (const :tag "Default" nil))) @@ -283,11 +258,13 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) +(defun browse-url--find-executable (candidates default) + (while (and candidates (not (executable-find (car candidates)))) + (setq candidates (cdr candidates))) + (or (car candidates) default)) + (defcustom browse-url-firefox-program - (let ((candidates '("icecat" "iceweasel" "firefox"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "firefox")) + (browse-url--find-executable '("icecat" "iceweasel") "firefox") "The name by which to invoke Firefox or a variant of it." :type 'string) @@ -305,10 +282,8 @@ Defaults to the value of `browse-url-firefox-arguments' at the time "it no longer has any effect." "24.5") (defcustom browse-url-chrome-program - (let ((candidates '("google-chrome-stable" "google-chrome"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("google-chrome-stable" "google-chrome") + "chromium") "The name by which to invoke the Chrome browser." :type 'string :version "25.1") @@ -319,10 +294,7 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :version "25.1") (defcustom browse-url-chromium-program - (let ((candidates '("chromium" "chromium-browser"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("chromium" "chromium-browser") "chromium") "The name by which to invoke Chromium." :type 'string :version "24.1") @@ -332,26 +304,6 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :type '(repeat (string :tag "Argument")) :version "24.1") -(defcustom browse-url-galeon-program "galeon" - "The name by which to invoke Galeon." - :type 'string) - -(make-obsolete-variable 'browse-url-galeon-program nil "25.1") - -(defcustom browse-url-galeon-arguments nil - "A list of strings to pass to Galeon as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-arguments nil "25.1") - -(defcustom browse-url-galeon-startup-arguments browse-url-galeon-arguments - "A list of strings to pass to Galeon when it starts up. -Defaults to the value of `browse-url-galeon-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-startup-arguments nil "25.1") - (defcustom browse-url-epiphany-program "epiphany" "The name by which to invoke GNOME Web (Epiphany)." :type 'string) @@ -366,7 +318,12 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) -;; GNOME means of invoking either Mozilla or Netscape. +(defcustom browse-url-webpositive-program "WebPositive" + "The name by which to invoke WebPositive." + :type 'string + :version "29.1") + +;; GNOME means of invoking Mozilla. (defvar browse-url-gnome-moz-program "gnome-moz-remote") (make-obsolete-variable 'browse-url-gnome-moz-program nil "25.1") @@ -399,29 +356,12 @@ If non-nil, then open the URL in a new buffer rather than a new window if (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 -`browse-url-galeon' is asked to open it in a new window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1") - (defcustom browse-url-epiphany-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 `browse-url-epiphany' is asked to open it in a new window." :type 'boolean) -(defcustom browse-url-netscape-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 `browse-url-netscape' is asked to open it in a new -window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1") - (defcustom browse-url-new-window-flag nil "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser @@ -518,14 +458,6 @@ You might want to set this to somewhere with restricted read permissions for privacy's sake." :type 'string) -(defcustom browse-url-netscape-version 3 - "The version of Netscape you are using. -This affects how URL reloading is done; the mechanism changed -incompatibly at version 4." - :type 'number) - -(make-obsolete-variable 'browse-url-netscape-version nil "25.1") - (defcustom browse-url-text-browser "lynx" "The name of the text browser to invoke." :type 'string @@ -769,21 +701,36 @@ interactively. Turn the filename into a URL with function (cond ((not (buffer-modified-p))) (browse-url-save-file (save-buffer)) (t (message "%s modified since last save" file)))))) - (when (file-remote-p file) - (setq file (file-local-copy file))) + (when (and (file-remote-p file) + (not browse-url-temp-file-name)) + (setq browse-url-temp-file-name (file-local-copy file) + file browse-url-temp-file-name)) (browse-url (browse-url-file-url file)) (run-hooks 'browse-url-of-file-hook)) +(defun browse-url--file-name-coding-system () + (if (equal system-type 'windows-nt) + ;; W32 pretends that file names are UTF-8 encoded. + 'utf-8 + (or file-name-coding-system default-file-name-coding-system))) + (defun browse-url-file-url (file) "Return the URL corresponding to FILE. Use variable `browse-url-filename-alist' to map filenames to URLs." - (let ((coding (if (equal system-type 'windows-nt) - ;; W32 pretends that file names are UTF-8 encoded. - 'utf-8 - (and (or file-name-coding-system - default-file-name-coding-system))))) - (if coding (setq file (encode-coding-string file coding)))) - (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) + (when-let ((coding (browse-url--file-name-coding-system))) + (setq file (encode-coding-string file coding))) + (if (and (file-remote-p file) + ;; We're applying special rules for FTP URLs for historical + ;; reasons. + (seq-find (lambda (match) + (and (string-match-p (car match) file) + (not (string-match "\\`file:" (cdr match))))) + browse-url-filename-alist)) + (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) + ;; Encode all other file names properly. + (setq file (mapconcat #'url-hexify-string + (file-name-split file) + "/"))) (dolist (map browse-url-filename-alist) (when (and map (string-match (car map) file)) (setq file (replace-match (cdr map) t nil file)))) @@ -858,6 +805,8 @@ See `browse-url' for details." ;; A generic command to call the current browse-url-browser-function +(declare-function pgtk-backend-display-class "pgtkfns.c" (&optional terminal)) + ;;;###autoload (defun browse-url (url &rest args) "Open URL using a configurable method. @@ -895,8 +844,17 @@ If ARGS are omitted, the default is to pass ;; When connected to various displays, be careful to use the display of ;; the currently selected frame, rather than the original start display, ;; which may not even exist any more. - (if (stringp (frame-parameter nil 'display)) - (setenv "DISPLAY" (frame-parameter nil 'display))) + (let ((dpy (frame-parameter nil 'display)) + classname) + (if (stringp dpy) + (cond + ((featurep 'pgtk) + (setq classname (pgtk-backend-display-class)) + (if (equal classname "GdkWaylandDisplay") + (setenv "WAYLAND_DISPLAY" dpy) + (setenv "DISPLAY" dpy))) + (t + (setenv "DISPLAY" dpy))))) (if (functionp function) (apply function url args) (error "No suitable browser for URL %s" url)))) @@ -1005,8 +963,6 @@ The optional NEW-WINDOW argument is not used." (function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind 'external) -;; --- Netscape --- - (defun browse-url-process-environment () "Set DISPLAY in the environment to the X display the browser will use. This is either the value of variable `browse-url-browser-display' if @@ -1014,7 +970,13 @@ non-nil, or the same display as Emacs if different from the current environment, otherwise just use the current environment." (let ((display (or browse-url-browser-display (browse-url-emacs-display)))) (if display - (cons (concat "DISPLAY=" display) process-environment) + (cons (concat (if (and (eq window-system 'pgtk) + (equal (pgtk-backend-display-class) + "GdkWaylandDisplay")) + "WAYLAND_DISPLAY=" + "DISPLAY=") + display) + process-environment) process-environment))) (defun browse-url-emacs-display () @@ -1049,10 +1011,9 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) ((executable-find browse-url-firefox-program) 'browse-url-firefox) ((executable-find browse-url-chromium-program) 'browse-url-chromium) -;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon) ((executable-find browse-url-kde-program) 'browse-url-kde) -;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ((executable-find browse-url-chrome-program) 'browse-url-chrome) + ((executable-find browse-url-webpositive-program) 'browse-url-webpositive) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) (t @@ -1085,82 +1046,6 @@ The optional argument IGNORED is not used." (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. -Default to the URL around or before point. The strings in variable -`browse-url-netscape-arguments' are also passed to Netscape. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Netscape window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-netscape-new-window-is-tab' is non-nil, then -whenever a document would otherwise be loaded in a new window, it -is loaded in a new tab in an existing window instead. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process - (apply #'start-process - (concat "netscape " url) nil - browse-url-netscape-program - (append - browse-url-netscape-arguments - (if (eq window-system 'w32) - (list url) - (append - (if new-window '("-noraise")) - (list "-remote" - (concat "openURL(" url - (if (browse-url-maybe-new-window - new-window) - (if browse-url-netscape-new-window-is-tab - ",new-tab" - ",new-window")) - ")")))))))) - (set-process-sentinel process - (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")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Netscape not running - start it - (message "Starting %s..." browse-url-netscape-program) - (apply #'start-process (concat "netscape" url) nil - browse-url-netscape-program - (append browse-url-netscape-startup-arguments (list url)))))) - -(defun browse-url-netscape-reload () - "Ask Netscape to reload its current document. -How depends on `browse-url-netscape-version'." - (declare (obsolete nil "25.1")) - (interactive) - ;; Backwards incompatibility reported by - ;; <peter.kruse@psychologie.uni-regensburg.de>. - (browse-url-netscape-send (if (>= browse-url-netscape-version 4) - "xfeDoCommand(reload)" - "reload"))) - -(defun browse-url-netscape-send (command) - "Send a remote control command to Netscape." - (declare (obsolete nil "25.1")) - (let* ((process-environment (browse-url-process-environment))) - (apply #'start-process "netscape" nil - browse-url-netscape-program - (append browse-url-netscape-arguments - (list "-remote" command))))) - -;;;###autoload (defun browse-url-mozilla (url &optional new-window) "Ask the Mozilla WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1280,56 +1165,6 @@ The optional argument NEW-WINDOW is not used." (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. -Default to the URL around or before point. The strings in variable -`browse-url-galeon-arguments' are also passed to Galeon. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Galeon window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-galeon-new-window-is-tab' is non-nil, then whenever a -document would otherwise be loaded in a new window, it is loaded in a -new tab in an existing window instead. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process (apply #'start-process - (concat "galeon " url) - nil - browse-url-galeon-program - (append - browse-url-galeon-arguments - (if (browse-url-maybe-new-window new-window) - (if browse-url-galeon-new-window-is-tab - '("--new-tab") - '("--new-window" "--noraise")) - '("--existing")) - (list url))))) - (set-process-sentinel process - (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")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Galeon is not running - start it - (message "Starting %s..." browse-url-galeon-program) - (apply #'start-process (concat "galeon " url) nil - browse-url-galeon-program - (append browse-url-galeon-startup-arguments (list url)))))) - (defun browse-url-epiphany (url &optional new-window) "Ask the GNOME Web (Epiphany) WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1380,6 +1215,18 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) ;;;###autoload +(defun browse-url-webpositive (url &optional _new-window) + "Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((process-environment (browse-url-process-environment))) + (start-process (concat "WebPositive " url) nil "WebPositive" url))) + +(function-put 'browse-url-webpositive 'browse-url-browser-kind 'external) + +;;;###autoload (defun browse-url-emacs (url &optional same-window) "Ask Emacs to load URL into a buffer and show it in another window. Optional argument SAME-WINDOW non-nil means show the URL in the @@ -1388,10 +1235,12 @@ currently selected window instead." (require 'url-handlers) (let ((parsed (url-generic-parse-url url)) (func (if same-window 'find-file 'find-file-other-window))) - (if (and (equal (url-type parsed) "file") - (file-directory-p (url-filename parsed))) - ;; It's a directory; just open it. - (funcall func (url-filename parsed)) + (if (equal (url-type parsed) "file") + ;; It's a file; just open it. + (let ((file (url-unhex-string (url-filename parsed)))) + (when-let ((coding (browse-url--file-name-coding-system))) + (setq file (decode-coding-string file 'utf-8))) + (funcall func file)) (let ((file-name-handler-alist (cons (cons url-handler-regexp 'url-file-handler) file-name-handler-alist))) @@ -1401,7 +1250,7 @@ currently selected window instead." ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) - "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. + "Ask Mozilla to load URL via the GNOME program `gnome-moz-remote'. Default to the URL around or before point. The strings in variable `browse-url-gnome-moz-arguments' are also passed. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 54e8d0c5d4e..6a8bf879671 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -36,6 +36,7 @@ ;; Declare used subroutines and variables. (declare-function dbus-message-internal "dbusbind.c") (declare-function dbus--init-bus "dbusbind.c") +(declare-function libxml-parse-xml-region "xml.c") (defvar dbus-message-type-invalid) (defvar dbus-message-type-method-call) (defvar dbus-message-type-method-return) @@ -2102,7 +2103,7 @@ has been handled by this function." (interface (dbus-event-interface-name event)) (member (dbus-event-member-name event)) (arguments (dbus-event-arguments event)) - (time (time-to-seconds (current-time)))) + (time (float-time))) (save-excursion ;; Check for matching method-call. (goto-char (point-max)) @@ -2252,15 +2253,19 @@ keywords `:system-private' or `:session-private', respectively." bus nil dbus-path-local dbus-interface-local "Disconnected" #'dbus-handle-bus-disconnect))) - -;; Initialize `:system' and `:session' buses. This adds their file -;; descriptors to input_wait_mask, in order to detect incoming -;; messages immediately. -(when (featurep 'dbusbind) - (dbus-ignore-errors - (dbus-init-bus :system)) - (dbus-ignore-errors - (dbus-init-bus :session))) + +(defun dbus--init () + ;; Initialize `:system' and `:session' buses. This adds their file + ;; descriptors to input_wait_mask, in order to detect incoming + ;; messages immediately. + (when (featurep 'dbusbind) + (dbus-ignore-errors + (dbus-init-bus :system)) + (dbus-ignore-errors + (dbus-init-bus :session)))) + +(add-hook 'after-pdump-load-hook #'dbus--init) +(dbus--init) (provide 'dbus) diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index 3122b26cd81..997b9e30fd4 100644 --- a/lisp/net/eudc-vars.el +++ b/lisp/net/eudc-vars.el @@ -42,7 +42,7 @@ A port number may be specified by appending a colon and a number to the name of the server. Use `localhost' if the directory server resides on your computer (BBDB backend). -To specify multiple servers, customize eudc-server-hotlist +To specify multiple servers, customize `eudc-server-hotlist' instead." :type '(choice (string :tag "Server") (const :tag "None" nil))) @@ -179,10 +179,15 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and (symbol :menu-tag "Other" :tag "Attribute name")))) :version "25.1") -;; Default to nil so that the most common use of eudc-expand-inline, -;; where replace is nil, does not affect the kill ring. -(defcustom eudc-expansion-overwrites-query nil - "If non-nil, expanding a query overwrites the query string." +(define-obsolete-variable-alias + 'eudc-expansion-overwrites-query + 'eudc-expansion-save-query-as-kill + "29.1") + +;; Default to nil so that the most common use of `eudc-expand-inline', +;; where `save-query-as-kill' is nil, does not affect the kill ring. +(defcustom eudc-expansion-save-query-as-kill nil + "If non-nil, expansion saves the query string to the kill ring." :type 'boolean :version "25.1") diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 5258947902d..98d0565c2f5 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -46,16 +46,9 @@ ;;; Code: (require 'wid-edit) - (require 'cl-lib) - -(unless (fboundp 'custom-menu-create) - (autoload 'custom-menu-create "cus-edit")) - (require 'eudc-vars) - - ;;{{{ Internal cooking ;;{{{ Internal variables and compatibility tricks @@ -748,9 +741,18 @@ If none try N - 1 and so forth." (setq n (1- n))) formats)) +;;;###autoload +(defun eudc-expand-try-all (&optional try-all-servers) + "Wrap `eudc-expand-inline' with a prefix argument. +If TRY-ALL-SERVERS -- the prefix argument when called +interactively -- is non-nil, collect results from all servers. +If TRY-ALL-SERVERS is nil, do not try subsequent servers after +one server returns any match." + (interactive "P") + (eudc-expand-inline (not eudc-expansion-save-query-as-kill) try-all-servers)) ;;;###autoload -(defun eudc-expand-inline (&optional replace) +(defun eudc-expand-inline (&optional save-query-as-kill try-all-servers) "Query the directory server, and expand the query string before point. The query string consists of the buffer substring from the point back to the preceding comma, colon or beginning of line. @@ -758,8 +760,9 @@ The variable `eudc-inline-query-format' controls how to associate the individual inline query words with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is inserted in the buffer at point. -If REPLACE is non-nil, then this expansion replaces the name in the buffer. -`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE. +If SAVE-QUERY-AS-KILL is non-nil, then save the pre-expansion +text to the kill ring. `eudc-expansion-save-query-as-kill' being +non-nil inverts the meaning of SAVE-QUERY-AS-KILL. Multiple servers can be tried with the same query until one finds a match, see `eudc-inline-expansion-servers'." (interactive) @@ -771,13 +774,13 @@ see `eudc-inline-expansion-servers'." (point))) (query-words (split-string (buffer-substring-no-properties beg end) "[ \t]+")) - (response-strings (eudc-query-with-words query-words))) + (response-strings (eudc-query-with-words query-words try-all-servers))) (if (null response-strings) (error "No match") (if (or - (and replace (not eudc-expansion-overwrites-query)) - (and (not replace) eudc-expansion-overwrites-query)) + (and save-query-as-kill (not eudc-expansion-save-query-as-kill)) + (and (not save-query-as-kill) eudc-expansion-save-query-as-kill)) (kill-ring-save beg end)) (cond ((or (= (length response-strings) 1) @@ -794,7 +797,7 @@ see `eudc-inline-expansion-servers'." (error "There is more than one match for the query")))))) ;;;###autoload -(defun eudc-query-with-words (query-words) +(defun eudc-query-with-words (query-words &optional try-all-servers) "Query the directory server, and return the matching responses. The variable `eudc-inline-query-format' controls how to associate the individual QUERY-WORDS with directory attribute names. @@ -802,7 +805,8 @@ After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is applied to the matches before returning them.inserted in the buffer at point. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'." +see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil, +keep collecting results from subsequent servers after the first match." (cond ((eq eudc-inline-expansion-servers 'current-server) (or eudc-server @@ -819,6 +823,7 @@ see `eudc-inline-expansion-servers'." (error "Wrong value for `eudc-inline-expansion-servers': %S" eudc-inline-expansion-servers))) (let* (query-formats + response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) ;; Prepare the list of servers to query @@ -830,7 +835,7 @@ see `eudc-inline-expansion-servers'." (if eudc-server (cons (cons eudc-server eudc-protocol) (delete (cons eudc-server eudc-protocol) - (copy-sequence eudc-server-hotlist))) + (copy-sequence eudc-server-hotlist))) eudc-server-hotlist)) ((eq eudc-inline-expansion-servers 'current-server) (list (cons eudc-server eudc-protocol)))))) @@ -840,46 +845,49 @@ see `eudc-inline-expansion-servers'." (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil)) (unwind-protect - (let ((response - (catch 'found - ;; Loop on the servers - (dolist (server servers) - (eudc-set-server (car server) (cdr server) t) - - ;; Determine which formats apply in the query-format list - (setq query-formats - (or - (eudc-extract-n-word-formats eudc-inline-query-format - (length query-words)) - (if (null eudc-protocol-has-default-query-attributes) - '(name)))) - - ;; Loop on query-formats - (while query-formats - (let ((response - (eudc-query - (eudc-format-query query-words (car query-formats)) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (if response - (throw 'found response))) - (setq query-formats (cdr query-formats)))) - ;; No more servers to try... no match found - nil)) - (response-strings '())) - - ;; Process response through eudc-inline-expansion-format - (dolist (r response) - (let ((response-string - (apply #'format - (car eudc-inline-expansion-format) - (mapcar (lambda (field) - (or (cdr (assq field r)) - "")) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format)))))) - (if (> (length response-string) 0) - (push response-string response-strings)))) + (cl-flet + ((run-query + (query-formats) + (let ((response + (eudc-query + (eudc-format-query query-words (car query-formats)) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format))))) + (if response + ;; Process response through eudc-inline-expansion-format. + (dolist (r response) + (let ((response-string + (apply #'format + (car eudc-inline-expansion-format) + (mapcar + (lambda (field) + (or (cdr (assq field r)) + "")) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + (if (> (length response-string) 0) + (push response-string response-strings)) + (when (not try-all-servers) + (throw 'found nil)))))))) + (catch 'found + ;; Loop on the servers. + (dolist (server servers) + (eudc-set-server (car server) (cdr server) t) + + ;; Determine which formats apply in the query-format list. + (setq query-formats + (or + (eudc-extract-n-word-formats eudc-inline-query-format + (length query-words)) + (if (null eudc-protocol-has-default-query-attributes) + '(name)))) + + ;; Loop on query-formats. + (while query-formats + (run-query query-formats) + (setq query-formats (cdr query-formats)))) + ;; No more servers to try... no match found. + nil) response-strings) (or (and (equal eudc-server eudc-former-server) (equal eudc-protocol eudc-former-protocol)) @@ -1059,6 +1067,8 @@ queries the server for the existing fields and displays a corresponding form." `(["---" nil nil] ["Query with Form" eudc-query-form :help "Display a form to query the directory server"] + ["Expand Inline Query Trying All Servers" eudc-expand-try-all + :help "Query all directory servers and expand the query string before point"] ["Expand Inline Query" eudc-expand-inline :help "Query the directory server, and expand the query string before point"] ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb diff --git a/lisp/net/eww.el b/lisp/net/eww.el index c39f6e3e1e1..700a6c3e82f 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -32,6 +32,7 @@ (require 'thingatpt) (require 'url) (require 'url-queue) +(require 'url-file) (require 'xdg) (eval-when-compile (require 'subr-x)) @@ -178,6 +179,40 @@ the tab bar is enabled." :group 'eww :type 'hook) +(defcustom eww-auto-rename-buffer nil + "Automatically rename EWW buffers once the page is rendered. + +When nil, do not rename the buffer. With a non-nil value +determine the renaming scheme, as follows: + +- `title': Use the web page's title. +- `url': Use the web page's URL. +- a function's symbol: Run a user-defined function that returns a + string with which to rename the buffer. Sample of a + user-defined function: + + (defun my-eww-rename-buffer () + (when (eq major-mode 'eww-mode) + (when-let ((string (or (plist-get eww-data :title) + (plist-get eww-data :url)))) + (format \"*%s*\" string)))) + +The string of `title' and `url' is always truncated to the value +of `eww-buffer-name-length'." + :version "29.1" + :type '(choice + (const :tag "Do not rename buffers (default)" nil) + (const :tag "Rename buffer to web page title" title) + (const :tag "Rename buffer to web page URL" url) + (function :tag "A user-defined function to rename the buffer")) + :group 'eww) + +(defcustom eww-buffer-name-length 40 + "Length of renamed buffer name, per `eww-auto-rename-buffer'." + :type 'natnum + :version "29.1" + :group 'eww) + (defcustom eww-form-checkbox-selected-symbol "[X]" "Symbol used to represent a selected checkbox. See also `eww-form-checkbox-symbol'." @@ -197,8 +232,15 @@ See also `eww-form-checkbox-selected-symbol'." (const "☐") ; Unicode BALLOT BOX string)) +(defcustom eww-url-transformers '(eww-remove-tracking) + "This is a list of transforming functions applied to an URL before usage. +The functions will be called with the URL as the single +parameter, and should return the (possibly) transformed URL." + :type '(repeat function) + :version "29.1") + (defface eww-form-submit - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -206,7 +248,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-file - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -214,7 +256,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-checkbox - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -222,7 +264,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-select - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -271,15 +313,13 @@ See also `eww-form-checkbox-selected-symbol'." "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" "Value used for the HTTP 'Accept' header.") -(defvar eww-link-keymap - (let ((map (copy-keymap shr-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-link-keymap + :parent shr-map + "RET" #'eww-follow-link) -(defvar eww-image-link-keymap - (let ((map (copy-keymap shr-image-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-image-link-keymap + :parent shr-map + "RET" #'eww-follow-link) (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. @@ -313,13 +353,13 @@ will start Emacs and browse the GNU web site." ;;;###autoload -(defun eww (url &optional arg buffer) +(defun eww (url &optional new-buffer 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. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing 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 @@ -329,11 +369,11 @@ killed after rendering." (list (read-string (format-prompt "Enter URL or keywords" (and uris (car uris))) nil 'eww-prompt-history uris) - (prefix-numeric-value current-prefix-arg)))) + current-prefix-arg))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window (cond - ((eq arg 4) + (new-buffer (generate-new-buffer "*eww*")) ((eq major-mode 'eww-mode) (current-buffer)) @@ -353,9 +393,10 @@ killed after rendering." (while (string-match "\\`/[.][.]/" (url-filename parsed)) (setf (url-filename parsed) (substring (url-filename parsed) 3)))) (setq url (url-recreate-url parsed))) + (setq url (eww--transform-url url)) (plist-put eww-data :url url) (plist-put eww-data :title "") - (eww-update-header-line-format) + (eww--after-page-change) (let ((inhibit-read-only t)) (insert (format "Loading %s..." url)) (goto-char (point-min))) @@ -447,22 +488,21 @@ killed after rendering." (defun eww-open-file (file) "Render FILE using EWW." (interactive "fFile: ") - (eww (concat "file://" - (and (memq system-type '(windows-nt ms-dos)) - "/") - (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)))) + (let ((url-allow-non-local-files t)) + (eww (concat "file://" + (and (memq system-type '(windows-nt ms-dos)) + "/") + (expand-file-name file))))) + +(defun eww--file-buffer (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 () @@ -504,6 +544,30 @@ Currently this means either text/html or application/xhtml+xml." (member content-type '("text/html" "application/xhtml+xml"))) +(defun eww--rename-buffer () + "Rename the current EWW buffer. +The renaming scheme is performed in accordance with +`eww-auto-rename-buffer'." + (let ((rename-string) + (formatter + (lambda (string) + (format "*%s # eww*" (truncate-string-to-width + string eww-buffer-name-length)))) + (site-title (plist-get eww-data :title)) + (site-url (plist-get eww-data :url))) + (cond ((null eww-auto-rename-buffer)) + ((eq eww-auto-rename-buffer 'url) + (setq rename-string (funcall formatter site-url))) + ((functionp eww-auto-rename-buffer) + (setq rename-string (funcall eww-auto-rename-buffer))) + (t (setq rename-string + (funcall formatter (if (or (equal site-title "") + (null site-title)) + "Untitled" + site-title))))) + (when rename-string + (rename-buffer rename-string t)))) + (defun eww-render (status url &optional point buffer encode) (let* ((headers (eww-parse-headers)) (content-type @@ -554,7 +618,7 @@ Currently this means either text/html or application/xhtml+xml." (eww-display-raw buffer (or encode charset 'utf-8)))) (with-current-buffer buffer (plist-put eww-data :url url) - (eww-update-header-line-format) + (eww--after-page-change) (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) @@ -638,14 +702,15 @@ Currently this means either text/html or application/xhtml+xml." (meta . eww-tag-meta) (a . eww-tag-a))))) (erase-buffer) - (shr-insert-document document) + (with-delayed-message (2 "Rendering HTML...") + (shr-insert-document document)) (cond (point (goto-char point)) (shr-target-id (goto-char (point-min)) (let ((match (text-property-search-forward - 'shr-target-id shr-target-id t))) + 'shr-target-id shr-target-id #'member))) (when match (goto-char (prop-match-beginning match))))) (t @@ -798,12 +863,16 @@ Currently this means either text/html or application/xhtml+xml." `((?u . ,(or url "")) (?t . ,title)))))))) +(defun eww--after-page-change () + (eww-update-header-line-format) + (eww--rename-buffer)) + (defun eww-tag-title (dom) (plist-put eww-data :title (replace-regexp-in-string "^ \\| $" "" (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom)))) - (eww-update-header-line-format)) + (eww--after-page-change)) (defun eww-display-raw (buffer &optional encode) (let ((data (buffer-substring (point) (point-max)))) @@ -931,7 +1000,7 @@ the like." nil (current-buffer)) (dolist (elem '(:source :url :title :next :previous :up)) (plist-put eww-data elem (plist-get old-data elem))) - (eww-update-header-line-format))) + (eww--after-page-change))) (defun eww-score-readability (node) (let ((score -1)) @@ -973,67 +1042,67 @@ the like." (setq result highest)))) result)) -(defvar eww-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead! - (define-key map "G" 'eww) - (define-key map [?\M-\r] 'eww-open-in-new-buffer) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - (define-key map [delete] 'scroll-down-command) - (define-key map "l" 'eww-back-url) - (define-key map "r" 'eww-forward-url) - (define-key map "n" 'eww-next-url) - (define-key map "p" 'eww-previous-url) - (define-key map "u" 'eww-up-url) - (define-key map "t" 'eww-top-url) - (define-key map "&" 'eww-browse-with-external-browser) - (define-key map "d" 'eww-download) - (define-key map "w" 'eww-copy-page-url) - (define-key map "C" 'url-cookie-list) - (define-key map "v" 'eww-view-source) - (define-key map "R" 'eww-readable) - (define-key map "H" 'eww-list-histories) - (define-key map "E" 'eww-set-character-encoding) - (define-key map "s" 'eww-switch-to-buffer) - (define-key map "S" 'eww-list-buffers) - (define-key map "F" 'eww-toggle-fonts) - (define-key map "D" 'eww-toggle-paragraph-direction) - (define-key map [(meta C)] 'eww-toggle-colors) - (define-key map [(meta I)] 'eww-toggle-images) - - (define-key map "b" 'eww-add-bookmark) - (define-key map "B" 'eww-list-bookmarks) - (define-key map [(meta n)] 'eww-next-bookmark) - (define-key map [(meta p)] 'eww-previous-bookmark) - - (easy-menu-define nil map "" - '("Eww" - ["Exit" quit-window t] - ["Close browser" quit-window t] - ["Reload" eww-reload t] - ["Follow URL in new buffer" eww-open-in-new-buffer] - ["Back to previous page" eww-back-url - :active (not (zerop (length eww-history)))] - ["Forward to next page" eww-forward-url - :active (not (zerop eww-history-position))] - ["Browse with external browser" eww-browse-with-external-browser t] - ["Download" eww-download t] - ["View page source" eww-view-source] - ["Copy page URL" eww-copy-page-url t] - ["List histories" eww-list-histories t] - ["Switch to buffer" eww-switch-to-buffer t] - ["List buffers" eww-list-buffers t] - ["Add bookmark" eww-add-bookmark t] - ["List bookmarks" eww-list-bookmarks t] - ["List cookies" url-cookie-list t] - ["Toggle fonts" eww-toggle-fonts t] - ["Toggle colors" eww-toggle-colors t] - ["Toggle images" eww-toggle-images t] - ["Character Encoding" eww-set-character-encoding] - ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) - map)) +(defvar-keymap eww-mode-map + "g" #'eww-reload ;FIXME: revert-buffer-function instead! + "G" #'eww + "M-RET" #'eww-open-in-new-buffer + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<backtab>" #'shr-previous-link + "<delete>" #'scroll-down-command + "l" #'eww-back-url + "r" #'eww-forward-url + "n" #'eww-next-url + "p" #'eww-previous-url + "u" #'eww-up-url + "t" #'eww-top-url + "&" #'eww-browse-with-external-browser + "d" #'eww-download + "w" #'eww-copy-page-url + "C" #'url-cookie-list + "v" #'eww-view-source + "R" #'eww-readable + "H" #'eww-list-histories + "E" #'eww-set-character-encoding + "s" #'eww-switch-to-buffer + "S" #'eww-list-buffers + "F" #'eww-toggle-fonts + "D" #'eww-toggle-paragraph-direction + "M-C" #'eww-toggle-colors + "M-I" #'eww-toggle-images + + "b" #'eww-add-bookmark + "B" #'eww-list-bookmarks + "M-n" #'eww-next-bookmark + "M-p" #'eww-previous-bookmark + + "<mouse-8>" #'eww-back-url + "<mouse-9>" #'eww-forward-url + + :menu '("Eww" + ["Exit" quit-window t] + ["Close browser" quit-window t] + ["Reload" eww-reload t] + ["Follow URL in new buffer" eww-open-in-new-buffer] + ["Back to previous page" eww-back-url + :active (not (zerop (length eww-history)))] + ["Forward to next page" eww-forward-url + :active (not (zerop eww-history-position))] + ["Browse with external browser" eww-browse-with-external-browser t] + ["Download" eww-download t] + ["View page source" eww-view-source] + ["Copy page URL" eww-copy-page-url t] + ["List histories" eww-list-histories t] + ["Switch to buffer" eww-switch-to-buffer t] + ["List buffers" eww-list-buffers t] + ["Add bookmark" eww-add-bookmark t] + ["List bookmarks" eww-list-bookmarks t] + ["List cookies" url-cookie-list t] + ["Toggle fonts" eww-toggle-fonts t] + ["Toggle colors" eww-toggle-colors t] + ["Toggle images" eww-toggle-images t] + ["Character Encoding" eww-set-character-encoding] + ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) (defun eww-context-menu (menu click) "Populate MENU with eww commands at CLICK." @@ -1135,7 +1204,8 @@ instead of `browse-url-new-window-flag'." (format "*eww-%s*" (url-host (url-generic-parse-url (eww--dwim-expand-url url)))))) (eww-mode)) - (eww url)) + (let ((url-allow-non-local-files t)) + (eww url))) (defun eww-back-url () "Go to the previously displayed page." @@ -1166,7 +1236,7 @@ instead of `browse-url-new-window-flag'." (goto-char (plist-get elem :point)) ;; Make buffer listings more informative. (setq list-buffers-directory (plist-get elem :url)) - (eww-update-header-line-format)))) + (eww--after-page-change)))) (defun eww-next-url () "Go to the page marked `next'. @@ -1222,62 +1292,58 @@ just re-display the HTML already fetched." (error "No current HTML data") (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) - (let ((url-mime-accept-string eww-accept-content-types)) - (eww-retrieve url #'eww-render - (list url (point) (current-buffer) encode)))))) + (let ((parsed (url-generic-parse-url url))) + (if (equal (url-type parsed) "file") + ;; Use Tramp instead of url.el for files (since url.el + ;; doesn't work well with Tramp files). + (let ((eww-buffer (current-buffer))) + (with-current-buffer (eww--file-buffer (url-filename parsed)) + (eww-render nil url nil eww-buffer))) + (let ((url-mime-accept-string eww-accept-content-types)) + (eww-retrieve url #'eww-render + (list url (point) (current-buffer) encode)))))))) ;; Form support. (defvar eww-form nil) -(defvar eww-submit-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-submit) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-submit-file - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-select-file) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-checkbox-map - (let ((map (make-sparse-keymap))) - (define-key map " " 'eww-toggle-checkbox) - (define-key map "\r" 'eww-toggle-checkbox) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-text-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'eww-submit) - (define-key map [(control a)] 'eww-beginning-of-text) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [(control e)] 'eww-end-of-text) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-textarea-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'forward-line) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-select-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-change-select) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'eww-change-select) - (define-key map [(control c) (control c)] 'eww-submit) - map)) +(defvar-keymap eww-submit-map + "RET" #'eww-submit + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-submit-file + "RET" #'eww-select-file + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-checkbox-map + "SPC" #'eww-toggle-checkbox + "RET" #'eww-toggle-checkbox + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-text-map + :full t :parent text-mode-map + "RET" #'eww-submit + "C-a" #'eww-beginning-of-text + "C-c C-c" #'eww-submit + "C-e" #'eww-end-of-text + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-textarea-map + :full t :parent text-mode-map + "RET" #'forward-line + "C-c C-c" #'eww-submit + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-select-map + :doc "Map for select buttons" + "RET" #'eww-change-select + "<follow-link>" 'mouse-face + "<mouse-2>" #'eww-change-select + "C-c C-c" #'eww-submit) (defun eww-beginning-of-text () "Move to the start of the input field." @@ -1784,6 +1850,17 @@ The browser to used is specified by the (funcall browse-url-secondary-browser-function (or url (plist-get eww-data :url)))) +(defun eww-remove-tracking (url) + "Remove the commong utm_ tracking cookies from URLs." + (replace-regexp-in-string ".utm_.*" "" url)) + +(defun eww--transform-url (url) + "Appy `eww-url-transformers'." + (when url + (dolist (func eww-url-transformers) + (setq url (funcall func url))) + url)) + (defun eww-follow-link (&optional external mouse-event) "Browse the URL under point. If EXTERNAL is single prefix, browse the URL using @@ -1794,7 +1871,8 @@ If EXTERNAL is double prefix, browse in new buffer." (list current-prefix-arg last-nonmenu-event) eww-mode) (mouse-set-point mouse-event) - (let ((url (get-text-property (point) 'shr-url))) + (let* ((orig-url (get-text-property (point) 'shr-url)) + (url (eww--transform-url orig-url))) (cond ((not url) (message "No link under point")) @@ -1813,7 +1891,7 @@ If EXTERNAL is double prefix, browse in new buffer." (plist-put eww-data :url url) (eww-display-html 'utf-8 url dom nil (current-buffer)))) (t - (eww-browse-url url external))))) + (eww-browse-url orig-url external))))) (defun eww-same-page-p (url1 url2) "Return non-nil if URL1 and URL2 represent the same page. @@ -2100,23 +2178,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." 'eww-bookmark))) (eww-browse-url (plist-get bookmark :url)))) -(defvar eww-bookmark-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-bookmark-kill) - (define-key map [(control y)] 'eww-bookmark-yank) - (define-key map "\r" 'eww-bookmark-browse) - - (easy-menu-define nil map - "Menu for `eww-bookmark-mode-map'." - '("Eww Bookmark" - ["Exit" quit-window t] - ["Browse" eww-bookmark-browse - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Kill" eww-bookmark-kill - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Yank" eww-bookmark-yank - :active eww-bookmark-kill-ring])) - map)) +(defvar-keymap eww-bookmark-mode-map + "C-k" #'eww-bookmark-kill + "C-y" #'eww-bookmark-yank + "RET" #'eww-bookmark-browse + :menu '("Eww Bookmark" + ["Exit" quit-window t] + ["Browse" eww-bookmark-browse + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Kill" eww-bookmark-kill + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Yank" eww-bookmark-yank + :active eww-bookmark-kill-ring])) (define-derived-mode eww-bookmark-mode special-mode "eww bookmarks" "Mode for listing bookmarks. @@ -2181,19 +2254,15 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (pop-to-buffer-same-window buffer))) (eww-restore-history history))) -(defvar eww-history-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-history-browse) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - - (easy-menu-define nil map - "Menu for `eww-history-mode-map'." - '("Eww History" - ["Exit" quit-window t] - ["Browse" eww-history-browse - :active (get-text-property (line-beginning-position) 'eww-history)])) - map)) +(defvar-keymap eww-history-mode-map + "RET" #'eww-history-browse + "n" #'next-line + "p" #'previous-line + :menu '("Eww History" + ["Exit" quit-window t] + ["Browse" eww-history-browse + :active (get-text-property (line-beginning-position) + 'eww-history)])) (define-derived-mode eww-history-mode special-mode "eww history" "Mode for listing eww-histories. @@ -2304,22 +2373,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (forward-line -1)) (eww-buffer-show)) -(defvar eww-buffers-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-buffer-kill) - (define-key map "\r" 'eww-buffer-select) - (define-key map "n" 'eww-buffer-show-next) - (define-key map "p" 'eww-buffer-show-previous) - - (easy-menu-define nil map - "Menu for `eww-buffers-mode-map'." - '("Eww Buffers" - ["Exit" quit-window t] - ["Select" eww-buffer-select - :active (get-text-property (line-beginning-position) 'eww-buffer)] - ["Kill" eww-buffer-kill - :active (get-text-property (line-beginning-position) 'eww-buffer)])) - map)) +(defvar-keymap eww-buffers-mode-map + "C-k" #'eww-buffer-kill + "RET" #'eww-buffer-select + "n" #'eww-buffer-show-next + "p" #'eww-buffer-show-previous + :menu '("Eww Buffers" + ["Exit" quit-window t] + ["Select" eww-buffer-select + :active (get-text-property (line-beginning-position) 'eww-buffer)] + ["Kill" eww-buffer-kill + :active (get-text-property (line-beginning-position) + 'eww-buffer)])) (define-derived-mode eww-buffers-mode special-mode "eww buffers" "Mode for listing buffers. @@ -2442,6 +2507,8 @@ Otherwise, the restored buffer will contain a prompt to do so by using "Default bookmark handler for EWW buffers." (eww (bookmark-prop-get bookmark 'location))) +(put 'eww-bookmark-jump 'bookmark-handler-type "EWW") + (provide 'eww) ;;; eww.el ends here diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index 13af2c123f8..0c8a29cc392 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -37,6 +37,7 @@ a string and return a digest of it (in binary form). B is a byte length of a block size of H. (B=64 for both SHA1 and MD5.) L is a byte length of hash outputs. (L=16 for MD5, L=20 for SHA1.) If BIT is non-nil, truncate output to specified bits." + (declare (indent defun)) `(defun ,name (text key) ,(concat "Compute " (upcase (symbol-name name)) diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index a59220c1be8..b65f7c25b83 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -55,7 +55,7 @@ you have an entry for \"image/*\" in your ~/.mailcap file." "A syntax table for parsing SGML attributes.") (defvar mailcap-print-command - (mapconcat 'identity + (mapconcat #'identity (cons (if (boundp 'lpr-command) lpr-command "lpr") @@ -116,8 +116,7 @@ is consulted." (regexp :tag "MIME Type") (sexp :tag "Test (optional)"))) :get #'mailcap--get-user-mime-data - :set #'mailcap--set-user-mime-data - :group 'mailcap) + :set #'mailcap--set-user-mime-data) ;; Postpone using defcustom for this as it's so big and we essentially ;; have to have two copies of the data around then. Perhaps just @@ -320,8 +319,9 @@ attribute name (viewer, test, etc). This looks like: Where VIEWERINFO specifies how the content-type is viewed. Can be a string, in which case it is run through a shell, with appropriate -parameters, or a symbol, in which case the symbol is `funcall'ed if -and only if it exists as a function, with the buffer as an argument. +parameters, or a symbol, in which case the symbol must name a function +of zero arguments which is called in a buffer holding the MIME part's +content. TESTINFO is a test for the viewer's applicability, or nil. If nil, it means the viewer is always valid. If it is a Lisp function, it is @@ -344,8 +344,7 @@ Same format as `mailcap-mime-data'.") "Directory to which `mailcap-save-binary-file' downloads files by default. nil means your home directory." :type '(choice (const :tag "Home directory" nil) - directory) - :group 'mailcap) + directory)) (defvar mailcap-poor-system-types '(ms-dos windows-nt) @@ -423,14 +422,6 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus (interactive (list nil t)) (when (or (not mailcap-parsed-p) force) - ;; Clear out all old data. - (setq mailcap--computed-mime-data nil) - ;; Add the Emacs-distributed defaults (which will be used as - ;; fallbacks). Do it this way instead of just copying the list, - ;; since entries are destructively modified. - (cl-loop for (major . minors) in mailcap-mime-data - do (cl-loop for (minor . entry) in minors - do (mailcap-add-mailcap-entry major minor entry))) (cond (path nil) ((getenv "MAILCAPS") @@ -447,18 +438,27 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ("/etc/mailcap" system) ("/usr/etc/mailcap" system) ("/usr/local/etc/mailcap" system))))) - ;; The ~/.mailcap entries will end up first in the resulting data. - (dolist (spec (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (let ((source (and (consp spec) (cadr spec))) - (file-name (if (stringp spec) - spec - (car spec)))) - (when (and (file-readable-p file-name) - (file-regular-p file-name)) - (mailcap-parse-mailcap file-name source)))) + (when (stringp path) + (setq path (mapcar #'list (split-string path path-separator t)))) + (when (or (null mailcap--computed-mime-data) + (seq-some (lambda (f) + (file-has-changed-p (car f) 'mail-parse-mailcaps)) + path)) + ;; Clear out all old data. + (setq mailcap--computed-mime-data nil) + ;; Add the Emacs-distributed defaults (which will be used as + ;; fallbacks). Do it this way instead of just copying the list, + ;; since entries are destructively modified. + (cl-loop for (major . minors) in mailcap-mime-data + do (cl-loop for (minor . entry) in minors + do (mailcap-add-mailcap-entry major minor entry))) + ;; The ~/.mailcap entries will end up first in the resulting data. + (dolist (spec (reverse path)) + (let ((source (cadr spec)) + (file-name (car spec))) + (when (and (file-readable-p file-name) + (file-regular-p file-name)) + (mailcap-parse-mailcap file-name source))))) (setq mailcap-parsed-p t))) (defun mailcap-parse-mailcap (fname &optional source) @@ -636,7 +636,7 @@ the test clause will be unchanged." ((and (listp test) (symbolp (car test))) test) ((or (stringp test) (and (listp test) (stringp (car test)) - (setq test (mapconcat 'identity test " ")))) + (setq test (mapconcat #'identity test " ")))) (with-temp-buffer (insert test) (goto-char (point-min)) @@ -707,12 +707,12 @@ to supply to the test." (symbol-value test)) ((and (listp test) ; List to be eval'd (symbolp (car test))) - (eval test)) + (eval test t)) (t (setq test (mailcap-unescape-mime-test test type-info) test (list shell-file-name nil nil nil shell-command-switch test) - status (apply 'call-process test)) + status (apply #'call-process test)) (eq 0 status)))) (push (list otest result) mailcap-viewer-test-cache) result)))) @@ -837,7 +837,7 @@ If NO-DECODE is non-nil, don't decode STRING." (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp)) + (setq passed (sort (nreverse passed) #'mailcap-viewer-lessp)) ;; When we want to prefer entries from the user's ;; ~/.mailcap file, then we filter out the system entries ;; and see whether we have anything left. @@ -1065,12 +1065,21 @@ For instance, \"foo.png\" will result in \"image/png\"." (match-string 1 file-name) ""))) +;;;###autoload +(defun mailcap-mime-type-to-extension (mime-type) + "Return a file name extension based on a MIME-TYPE. +For instance, `image/png' will result in `png'." + (intern (cadr (split-string (if (symbolp mime-type) + (symbol-name mime-type) + mime-type) + "/")))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) (delete-dups (nconc - (mapcar 'cdr mailcap-mime-extensions) + (mapcar #'cdr mailcap-mime-extensions) (let (res type) (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) @@ -1167,34 +1176,45 @@ See \"~/.mailcap\", `mailcap-mime-data' and related files and variables." (mailcap-parse-mailcaps) (let ((command (mailcap-mime-info (mailcap-extension-to-mime (file-name-extension file))))) - (unless command - (error "No viewer for %s" (file-name-extension file))) - ;; Remove quotes around the file name - we'll use shell-quote-argument. - (while (string-match "['\"]%s['\"]" command) - (setq command (replace-match "%s" t t command))) - (setq command (replace-regexp-in-string - "%s" - (shell-quote-argument (convert-standard-filename file)) - command - nil t)) - ;; Handlers such as "gio open" and kde-open5 start viewer in background - ;; and exit immediately. Avoid `start-process' since it assumes - ;; :connection-type `pty' and kills children processes with SIGHUP - ;; when temporary terminal session is finished (Bug#44824). - ;; An alternative is `process-connection-type' let-bound to nil for - ;; `start-process-shell-command' call (with no chance to report failure). - (make-process - :name "mailcap-view-file" - :connection-type 'pipe - :buffer nil ; "*Messages*" may be suitable for debugging - :sentinel (lambda (proc event) - (when (and (memq (process-status proc) '(exit signal)) - (/= (process-exit-status proc) 0)) - (message - "Command %s: %s." - (mapconcat #'identity (process-command proc) " ") - (substring event 0 -1)))) - :command (list shell-file-name shell-command-switch command)))) + (if (functionp command) + ;; command is a viewer function (a mode) expecting the file + ;; contents to be in the current buffer. + (let ((buf (generate-new-buffer (file-name-nondirectory file)))) + (set-buffer buf) + (insert-file-contents file) + (setq buffer-file-name file) + (funcall command) + (set-buffer-modified-p nil) + (pop-to-buffer buf)) + ;; command is a program to run with file as an argument. + (unless command + (error "No viewer for %s" (file-name-extension file))) + ;; Remove quotes around the file name - we'll use shell-quote-argument. + (while (string-match "['\"]%s['\"]" command) + (setq command (replace-match "%s" t t command))) + (setq command (replace-regexp-in-string + "%s" + (shell-quote-argument (convert-standard-filename file)) + command + nil t)) + ;; Handlers such as "gio open" and kde-open5 start viewer in background + ;; and exit immediately. Avoid `start-process' since it assumes + ;; :connection-type `pty' and kills children processes with SIGHUP + ;; when temporary terminal session is finished (Bug#44824). + ;; An alternative is `process-connection-type' let-bound to nil for + ;; `start-process-shell-command' call (with no chance to report failure). + (make-process + :name "mailcap-view-file" + :connection-type 'pipe + :buffer nil ; "*Messages*" may be suitable for debugging + :sentinel (lambda (proc event) + (when (and (memq (process-status proc) '(exit signal)) + (/= (process-exit-status proc) 0)) + (message + "Command %s: %s." + (mapconcat #'identity (process-command proc) " ") + (substring event 0 -1)))) + :command (list shell-file-name shell-command-switch command))))) (provide 'mailcap) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 01cbbbbe011..a62a7bd8b7d 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -402,13 +402,6 @@ headline after it has been retrieved for the first time." "Miscellaneous newsticker settings." :group 'newsticker) -(defcustom newsticker-cache-filename - "~/.newsticker-cache" - "Name of the newsticker cache file." - :type 'string - :group 'newsticker-miscellaneous) -(make-obsolete-variable 'newsticker-cache-filename 'newsticker-dir "23.1") - (defcustom newsticker-dir (locate-user-emacs-file "newsticker/" ".newsticker/") "Directory where newsticker saves data." @@ -2114,28 +2107,6 @@ well." (throw 'result t))))) (< (or (newsticker--pos item1) 0) (or (newsticker--pos item2) 0)))) -(defun newsticker--cache-save-version1 () - "Update and save newsticker cache file." - (interactive) - (newsticker--cache-update t)) - -(defun newsticker--cache-update (&optional save) - "Update newsticker cache file. -If optional argument SAVE is not nil the cache file is saved to disk." - (save-excursion - (unless (file-directory-p newsticker-dir) - (make-directory newsticker-dir t)) - (let ((coding-system-for-write 'utf-8) - (buf (find-file-noselect newsticker-cache-filename))) - (when buf - (set-buffer buf) - (setq buffer-undo-list t) - (erase-buffer) - (insert ";; -*- coding: utf-8 -*-\n") - (insert (prin1-to-string newsticker--cache)) - (when save - (save-buffer)))))) - (defun newsticker--cache-get-feed (feed) "Return the cached data for the feed FEED. FEED is a symbol!" @@ -2162,30 +2133,11 @@ FEED is a symbol!" (insert ";; -*- coding: utf-8 -*-\n") (insert (prin1-to-string (cdr feed))))))) -(defun newsticker--cache-read-version1 () - "Read version1 cache data." - (let ((coding-system-for-read 'utf-8)) - (when (file-exists-p newsticker-cache-filename) - (with-temp-buffer - (insert-file-contents newsticker-cache-filename) - (goto-char (point-min)) - (condition-case nil - (setq newsticker--cache (read (current-buffer))) - (error - (message "Error while reading newsticker cache file!") - (setq newsticker--cache nil))))))) - (defun newsticker--cache-read () "Read cache data." (setq newsticker--cache nil) - (if (file-exists-p newsticker-cache-filename) - (progn - (when (y-or-n-p "Old newsticker cache file exists. Read it? ") - (newsticker--cache-read-version1)) - (when (y-or-n-p "Delete old newsticker cache file? ") - (delete-file newsticker-cache-filename))) - (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) - (newsticker--cache-read-feed (car f))))) + (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker--cache-read-feed (car f)))) (defun newsticker--cache-read-feed (feed-name) "Read cache data for feed named FEED-NAME." diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index f026948251d..df574dfa2f4 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -589,7 +589,7 @@ calls `w3m-toggle-inline-image'. It works only if (defun newsticker-close-buffer () "Close the newsticker buffer." (interactive) - (newsticker--cache-update t) + (newsticker--cache-save) (bury-buffer)) (defun newsticker-next-new-item (&optional do-not-wrap-at-eob) @@ -748,7 +748,7 @@ Return new buffer position." (newsticker--cache-replace-age newsticker--cache feed 'new 'old) (newsticker--cache-replace-age newsticker--cache feed 'obsolete 'old) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) (newsticker-buffer-update) @@ -879,7 +879,7 @@ not get changed." (newsticker--cache-replace-age newsticker--cache 'any 'new 'old) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker-buffer-update))) (defun newsticker-hide-extra () diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index d95593da3bc..3146189be63 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -79,8 +79,7 @@ option." (const :tag "Off" nil) (function :tag "Custom function"))) -(defcustom nsm-settings-file (expand-file-name "network-security.data" - user-emacs-directory) +(defcustom nsm-settings-file (locate-user-emacs-file "network-security.data") "The file the security manager settings will be stored in." :version "25.1" :type 'file) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index 1589770f203..b58f0abb56b 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -102,9 +102,7 @@ is not given." (let ((request-ident (concat "NTLMSSP" (make-string 1 0))) (request-msgType (concat (make-string 1 1) (make-string 3 0))) ;0x01 0x00 0x00 0x00 - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) ) (when (and user (string-match "@" user)) (unless domain @@ -245,9 +243,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes ;; match default setting in `ntlm-build-auth-request' - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes ;; Extract domain string from challenge string. diff --git a/lisp/net/puny.el b/lisp/net/puny.el index d22cc88b7bd..3a276791ab2 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -43,6 +43,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." "Encode STRING according to the IDNA/punycode algorithm. This is used to encode non-ASCII domain names. For instance, \"bücher\" => \"xn--bcher-kva\"." + (setq string (downcase (string-glyph-compose string))) (let ((ascii (seq-filter (lambda (char) (< char 128)) string))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 8feef6beebe..9d1600ed72f 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -262,6 +262,7 @@ The ARGUMENTS for each METHOD symbol are: `bitlbee': NICK PASSWORD `quakenet': ACCOUNT PASSWORD `sasl': NICK PASSWORD + `certfp': KEY CERT Examples: ((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\") @@ -291,7 +292,11 @@ Examples: (list :tag "SASL" (const sasl) (string :tag "Nick") - (string :tag "Password"))))) + (string :tag "Password")) + (list :tag "CertFP" + (const certfp) + (string :tag "Key") + (string :tag "Certificate"))))) (defcustom rcirc-auto-authenticate-flag t "Non-nil means automatically send authentication string to server. @@ -547,13 +552,16 @@ If ARG is non-nil, instead prompt for connection parameters." (password (plist-get (cdr c) :password)) (encryption (plist-get (cdr c) :encryption)) (server-alias (plist-get (cdr c) :server-alias)) + (client-cert (when (eq (rcirc-get-server-method (car c)) + 'certfp) + (rcirc-get-server-cert (car c)))) contact) (when-let (((not password)) (auth (auth-source-search :host server :user user-name :port port)) - (fn (plist-get (car auth) :secret))) - (setq password (funcall fn))) + (pwd (auth-info-password (car auth)))) + (setq password pwd)) (when server (let (connected) (dolist (p (rcirc-process-list)) @@ -563,7 +571,7 @@ If ARG is non-nil, instead prompt for connection parameters." (condition-case nil (let ((process (rcirc-connect server port nick user-name full-name channels password encryption - server-alias))) + client-cert server-alias))) (when rcirc-display-server-buffer (pop-to-buffer-same-window (process-buffer process)))) (quit (message "Quit connecting to %s" @@ -646,29 +654,23 @@ See `rcirc-connect' for more details on these variables.") (defun rcirc-get-server-method (server) "Return authentication method for SERVER." - (catch 'method - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (method (cadr i))) - (when (string-match server-i server) - (throw 'method method)))))) + (cadr (assoc server rcirc-authinfo #'string-match))) (defun rcirc-get-server-password (server) "Return password for SERVER." - (catch 'pass - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (args (cdddr i))) - (when (string-match server-i server) - (throw 'pass (car args))))))) + (cadddr (assoc server rcirc-authinfo #'string-match))) + +(defun rcirc-get-server-cert (server) + "Return a list of key and certificate for SERVER." + (cddr (assoc server rcirc-authinfo #'string-match))) ;;;###autoload (defun rcirc-connect (server &optional port nick user-name full-name startup-channels password encryption - server-alias) + certfp server-alias) "Connect to SERVER. The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, -ENCRYPTION, SERVER-ALIAS are interpreted as in +ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in `rcirc-server-alist'. STARTUP-CHANNELS is a list of channels that are joined after authentication." (save-excursion @@ -695,6 +697,7 @@ that are joined after authentication." (setq process (open-network-stream (or server-alias server) nil server port-number :type (or encryption 'plain) + :client-certificate certfp :nowait t)) (set-process-coding-system process 'raw-text 'raw-text) (with-current-buffer (get-buffer-create (rcirc-generate-new-buffer-name process nil)) @@ -713,8 +716,8 @@ that are joined after authentication." (setq rcirc-nick-table (make-hash-table :test 'equal)) (setq rcirc-nick nick) (setq rcirc-startup-channels startup-channels) - (setq rcirc-last-server-message-time (current-time)) (setq rcirc-last-connect-time (current-time)) + (setq rcirc-last-server-message-time rcirc-last-connect-time) ;; Check if the immediate process state (sit-for .1) @@ -2044,6 +2047,13 @@ connection." (run-hook-with-args 'rcirc-print-functions process sender response target text))))) +(defun rcirc-when () + "Show the time of reception of the message at point." + (interactive) + (if-let (time (get-text-property (point) 'rcirc-time)) + (message (format-time-string "%c" time)) + (message "No time information at point."))) + (defun rcirc-generate-log-filename (process target) "Return filename for log file based on PROCESS and TARGET." (if target diff --git a/lisp/net/sasl-scram-rfc.el b/lisp/net/sasl-scram-rfc.el index b8d83627963..ee52ed6e071 100644 --- a/lisp/net/sasl-scram-rfc.el +++ b/lisp/net/sasl-scram-rfc.el @@ -90,6 +90,8 @@ (sasl-mechanism-name (sasl-client-mechanism client)) (sasl-client-name client)))) (salt (base64-decode-string salt-base64)) + (string-xor (lambda (a b) + (apply #'unibyte-string (cl-mapcar #'logxor a b)))) (salted-password ;; Hi(str, salt, i): (let ((digest (concat salt (string 0 0 0 1))) @@ -98,7 +100,7 @@ (setq digest (funcall hmac-fun digest password)) (setq xored (if (null xored) digest - (cl-map 'string 'logxor xored digest)))))) + (funcall string-xor xored digest)))))) (client-key (funcall hmac-fun "Client Key" salted-password)) (stored-key (decode-hex-string (funcall hash-fun client-key))) @@ -108,7 +110,7 @@ step-data "," client-final-message-without-proof)) (client-signature (funcall hmac-fun (encode-coding-string auth-message 'utf-8) stored-key)) - (client-proof (cl-map 'string 'logxor client-key client-signature)) + (client-proof (funcall string-xor client-key client-signature)) (client-final-message (concat client-final-message-without-proof "," "p=" (base64-encode-string client-proof)))) diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index c4ba99f47c8..e0def55ad9f 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -174,21 +174,24 @@ It contain at least 64 bits of entropy." ;; stolen (and renamed) from message.el (defun sasl-unique-id-function () - ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Don't use fractional seconds from timestamp; they may be unsupported. ;; Instead we use this randomly inited counter. (setq sasl-unique-id-char - (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20))))) - ;; (current-time) returns 16-bit ints, - ;; and 2^16*25 just fits into 4 digits i base 36. - (* 25 25))) - (let ((tm (current-time))) + ;; 2^16 * 25 just fits into 4 digits i base 36. + (let ((base (* 25 25))) + (if sasl-unique-id-char + (% (1+ sasl-unique-id-char) base) + (random base)))) + (let ((tm (time-convert nil 'integer))) (concat (sasl-unique-id-number-base36 - (+ (car tm) - (ash (% sasl-unique-id-char 25) 16)) 4) + (+ (ash tm -16) + (ash (% sasl-unique-id-char 25) 16)) + 4) (sasl-unique-id-number-base36 - (+ (nth 1 tm) - (ash (/ sasl-unique-id-char 25) 16)) 4)))) + (+ (logand tm #xffff) + (ash (/ sasl-unique-id-char 25) 16)) + 4)))) (defun sasl-unique-id-number-base36 (num len) (if (if (< len 0) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index faadcb94b11..d8341774e47 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -77,15 +77,17 @@ ;; (secrets-delete-collection "my collection") ;; (secrets-create-collection "my collection") -;; There exists a special collection called "session", which has the -;; lifetime of the corresponding client session (aka Emacs's -;; lifetime). It is created automatically when Emacs uses the Secret -;; Service interface, and it is deleted when Emacs is killed. +;; With GNOME Keyring, there exists a special collection called +;; "session", which has the lifetime of the user being logged in. Its +;; data are not stored on disk and go away when the user logs out. ;; Therefore, it can be used to store and retrieve secret items -;; temporarily. This shall be preferred over creation of a persistent -;; collection, when the information shall not live longer than Emacs. -;; The session collection can be addressed either by the string -;; "session", or by nil, whenever a collection parameter is needed. +;; temporarily. The "session" collection can be addressed either by +;; the string "session", or by nil, whenever a collection parameter is +;; needed. + +;; However, other Secret Service provider don't create this temporary +;; "session" collection. You shall check first that this collection +;; exists, before you use it. ;; As already said, a collection is a group of secret items. A secret ;; item has a label, the "secret" (which is a string), and a set of @@ -98,8 +100,7 @@ ;; => ("this item" "another item") ;; Secret items can be added or deleted to a collection. In the -;; following examples, we use the special collection "session", which -;; is bound to Emacs's lifetime. +;; following examples, we use the special collection "session". ;; ;; (secrets-delete-item "session" "my item") ;; (secrets-create-item "session" "my item" "geheim" @@ -137,7 +138,7 @@ ;; It has been tested with GNOME Keyring 2.29.92. An implementation ;; for KWallet will be available at ;; svn://anonsvn.kde.org/home/kde/trunk/playground/base/ksecretservice; -;; not tested yet. +;; not tested yet. This package has also been tested with KeePassXC 2.6.6. ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used @@ -263,6 +264,7 @@ It returns t if not." ;; </signal> ;; </interface> +;; This exist only for GNOME Keyring. (defconst secrets-session-collection-path "/org/freedesktop/secrets/collection/session" "The D-Bus temporary session collection object path.") @@ -311,43 +313,8 @@ It returns t if not." (defconst secrets-interface-item-type-generic "org.freedesktop.Secret.Generic" "The default item type we are using.") -;; We cannot use introspection, because some servers, like -;; mate-keyring-daemon, don't provide relevant data. Once the dust -;; has settled, we shall assume the new interface, and get rid of the test. -(defconst secrets-struct-secret-content-type - (ignore-errors - (let ((content-type "text/plain") - (path (cadr - (dbus-call-method - :session secrets-service secrets-path - secrets-interface-service - "OpenSession" "plain" '(:variant "")))) - result) - ;; Create a dummy item. - (setq result - (dbus-call-method - :session secrets-service secrets-session-collection-path - secrets-interface-collection "CreateItem" - ;; Properties. - `(:array - (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant " "))) - ;; Secret. - `(:struct :object-path ,path - (:array :signature "y") - ,(dbus-string-to-byte-array " ") - :string ,content-type) - ;; Don't replace. - nil)) - ;; Remove it. - (dbus-call-method - :session secrets-service (car result) - secrets-interface-item "Delete") - ;; Result. - `(,content-type))) - "The content_type of a secret struct. -It must be wrapped as list, because we add it via `append'. This -is an interface introduced in 2011.") +(defconst secrets-struct-secret-content-type "text/plain" + "The content_type of a secret struct.") (defconst secrets-interface-session "org.freedesktop.Secret.Session" "A session tracks state between the service and a client application.") @@ -696,13 +663,10 @@ The object path of the created item is returned." `((:dict-entry ,(concat secrets-interface-item ".Attributes") (:variant ,(append '(:array) props)))))) ;; Secret. - (append - `(:struct :object-path ,secrets-session-path - (:array :signature "y") ;; No parameters. - ,(dbus-string-to-byte-array password)) - ;; We add the content_type. In backward compatibility - ;; mode, nil is appended, which means nothing. - secrets-struct-secret-content-type) + `(:struct :object-path ,secrets-session-path + (:array :signature "y") ;; No parameters. + ,(dbus-string-to-byte-array password) + ,secrets-struct-secret-content-type) ;; Do not replace. Replace does not seem to work. nil)) (secrets-prompt (cadr result)) @@ -943,7 +907,7 @@ to their attributes." secrets-interface-service "CollectionDeleted" 'secrets-collection-handler) - ;; We shall inform, whether the secret service is enabled on this + ;; We shall inform, that the secret service is enabled on this ;; machine. (setq secrets-enabled t)) @@ -954,6 +918,7 @@ to their attributes." ;; * secrets-debug should be structured like auth-source-debug to ;; prevent leaking sensitive information. Right now I don't see ;; anything sensitive though. + ;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be ;; used for the transfer of the secrets. Currently, we use the ;; plain algorithm. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index e8b0fbc18c4..386f1d6095d 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -40,6 +40,8 @@ (require 'image) (require 'puny) (require 'url-cookie) +(require 'url-file) +(require 'pixel-fill) (require 'text-property-search) (defgroup shr nil @@ -56,8 +58,15 @@ fit these criteria." :version "24.1" :type 'float) +(defcustom shr-allowed-images nil + "If non-nil, only images that match this regexp are displayed. +If nil, all URLs are allowed. Also see `shr-blocked-images'." + :version "29.1" + :type '(choice (const nil) regexp)) + (defcustom shr-blocked-images nil - "Images that have URLs matching this regexp will be blocked." + "Images that have URLs matching this regexp will be blocked. +If nil, no images are blocked. Also see `shr-allowed-images'." :version "24.1" :type '(choice (const nil) regexp)) @@ -162,6 +171,10 @@ cid: URL as the argument.") (defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") +(defface shr-text '((t :inherit variable-pitch-text)) + "Face used for rendering text." + :version "29.1") + (defface shr-strike-through '((t :strike-through t)) "Face for <s> elements." :version "24.1") @@ -183,6 +196,11 @@ temporarily blinks with this face." "Face for <abbr> elements." :version "27.1") +(defface shr-sup + '((t :height 0.8)) + "Face for <sup> and <sub> elements." + :version "29.1") + (defface shr-h1 '((t :height 1.3 :weight bold)) "Face for <h1> elements." @@ -231,7 +249,6 @@ and other things: (defvar shr-internal-width nil) (defvar shr-list-mode nil) (defvar shr-content-cache nil) -(defvar shr-kinsoku-shorten nil) (defvar shr-table-depth 0) (defvar shr-stylesheet nil) (defvar shr-base nil) @@ -246,24 +263,23 @@ and other things: (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) - (define-key map "i" #'shr-browse-image) - (define-key map "z" #'shr-zoom-image) - (define-key map [?\t] #'shr-next-link) - (define-key map [?\M-\t] #'shr-previous-link) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] #'shr-browse-url) - (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window) - (define-key map "I" #'shr-insert-image) - (define-key map "w" #'shr-maybe-probe-and-copy-url) - (define-key map "u" #'shr-maybe-probe-and-copy-url) - (define-key map "v" #'shr-browse-url) - (define-key map "O" #'shr-save-contents) - (define-key map "\r" #'shr-browse-url) - map)) +(defvar shr--link-targets nil) + +(defvar-keymap shr-map + "a" #'shr-show-alt-text + "i" #'shr-browse-image + "z" #'shr-zoom-image + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<follow-link>" 'mouse-face + "<mouse-2>" #'shr-browse-url + "C-<down-mouse-1>" #'shr-mouse-browse-url-new-window + "I" #'shr-insert-image + "w" #'shr-maybe-probe-and-copy-url + "u" #'shr-maybe-probe-and-copy-url + "v" #'shr-browse-url + "O" #'shr-save-contents + "RET" #'shr-browse-url) (defvar shr-image-map (let ((map (copy-keymap shr-map))) @@ -305,6 +321,18 @@ and other things: (or (not (zerop (fringe-columns 'right))) (not (zerop (fringe-columns 'left)))))) +(defun shr--window-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)) + (pixel-fill-width))) + ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -326,22 +354,9 @@ DOM should be a parse tree as generated by (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)))) + (shr--window-width))) (max-specpdl-size max-specpdl-size) + (shr--link-targets nil) ;; `bidi-display-reordering' is supposed to be only used for ;; debugging purposes, but Shr's naïve filling algorithm ;; cannot cope with the complexity of RTL text in an LTR @@ -365,9 +380,22 @@ DOM should be a parse tree as generated by (shr-descend dom) (shr-fill-lines start (point)) (shr--remove-blank-lines-at-the-end start (point)) + (shr--set-target-ids shr--link-targets) (when shr-warning (message "%s" shr-warning)))) +(defun shr--set-target-ids (ids) + ;; If the buffer is empty, there's no point in setting targets. + (unless (zerop (buffer-size)) + ;; We may have several targets in the same place (if you have + ;; several <span id='foo'> things after one another). So group + ;; them by position. + (dolist (group (seq-group-by #'cdr ids)) + (let ((point (min (1- (point-max)) (car group)))) + (put-text-property point (1+ point) + 'shr-target-id + (mapcar #'car (cdr group))))))) + (defun shr--remove-blank-lines-at-the-end (start end) (save-restriction (save-excursion @@ -547,6 +575,12 @@ size, and full-buffer size." (shr-insert sub) (shr-descend sub)))) +(defun shr-image-blocked-p (url) + (or (and shr-blocked-images + (string-match shr-blocked-images url)) + (and shr-allowed-images + (not (string-match shr-allowed-images url))))) + (defun shr-indirect-call (tag-name dom &rest args) (let ((function (intern (concat "shr-tag-" (symbol-name tag-name)) obarray)) ;; Allow other packages to override (or provide) rendering @@ -577,7 +611,7 @@ size, and full-buffer size." (setq shr-warning "Not rendering the complete page because of too-deep nesting") (when style - (if (string-match "color\\|display\\|border-collapse" style) + (if (string-match-p "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) @@ -596,16 +630,8 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (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)) - (if (not (bolp)) - (insert ? ) - (insert ? ) - (shr-mark-fill start)) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property (1- (point)) (point) 'shr-target-id id)) + (when-let ((id (dom-attr dom 'id))) + (push (cons id (set-marker (make-marker) start)) shr--link-targets)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -619,43 +645,11 @@ size, and full-buffer size." (with-temp-buffer (let ((shr-indentation 0) (shr-start nil) - (shr-internal-width (- (window-body-width nil t) - (* 2 (frame-char-width)) - ;; Adjust the window width for when - ;; the user disables the fringes, - ;; which causes the display engine - ;; to usurp one column for the - ;; continuation glyph. - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0)))) + (shr-internal-width (shr--window-width))) (shr-insert text) (shr-fill-lines (point-min) (point-max)) (buffer-string))))) -(define-inline shr-char-breakable-p (char) - "Return non-nil if a line can be broken before and after CHAR." - (inline-quote (aref fill-find-break-point-function-table ,char))) -(define-inline shr-char-nospace-p (char) - "Return non-nil if no space is required before and after CHAR." - (inline-quote (aref fill-nospace-between-words-table ,char))) - -;; KINSOKU is a Japanese word meaning a rule that should not be violated. -;; In Emacs, it is a term used for characters, e.g. punctuation marks, -;; parentheses, and so on, that should not be placed in the beginning -;; of a line or the end of a line. -(define-inline shr-char-kinsoku-bol-p (char) - "Return non-nil if a line ought not to begin with CHAR." - (inline-letevals (char) - (inline-quote (and (not (eq ,char ?')) - (aref (char-category-set ,char) ?>))))) -(define-inline shr-char-kinsoku-eol-p (char) - "Return non-nil if a line ought not to end with CHAR." - (inline-quote (aref (char-category-set ,char) ?<))) -(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) - (load "kinsoku" nil t)) - (defun shr-pixel-column () (if (not shr-use-fonts) (current-column) @@ -669,6 +663,7 @@ size, and full-buffer size." (car (window-text-pixel-size nil (line-beginning-position) (point)))))) (defun shr-pixel-region () + (declare (obsolete nil "29.1")) (- (shr-pixel-column) (save-excursion (goto-char (mark)) @@ -711,7 +706,7 @@ size, and full-buffer size." (goto-char (point-max))))) (t (let ((font-start (point))) - (when (and (string-match "\\`[ \t\n\r]" text) + (when (and (string-match-p "\\`[ \t\n\r]" text) (not (bolp)) (not (eq (char-after (1- (point))) ? ))) (insert " ")) @@ -739,7 +734,7 @@ size, and full-buffer size." (when shr-use-fonts (put-text-property font-start (point) 'face - (or shr-current-font 'variable-pitch))))))))) + (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) (if (<= shr-internal-width 0) @@ -788,7 +783,7 @@ size, and full-buffer size." (while (not (eolp)) ;; We have to do some folding. First find the first ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) + (if (or (not (pixel-fill-find-fill-point (line-beginning-position))) (= (point) start)) ;; We had unbreakable text (for this width), so just go to ;; the first space and carry on. @@ -829,84 +824,6 @@ size, and full-buffer size." (when (looking-at " $") (delete-region (point) (line-end-position))))))) -(defun shr-find-fill-point (start) - (let ((bp (point)) - (end (point)) - failed) - (while (not (or (setq failed (<= (point) start)) - (eq (preceding-char) ? ) - (eq (following-char) ? ) - (shr-char-breakable-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char)))) - (shr-char-kinsoku-eol-p (following-char)) - (bolp))) - (backward-char 1)) - (if failed - ;; There's no breakable point, so we give it up. - (let (found) - (goto-char bp) - ;; Don't overflow the window edge, even if - ;; shr-kinsoku-shorten is nil. - (unless (or shr-kinsoku-shorten (null shr-width)) - (while (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move))) - (if (and found - (not (match-beginning 1))) - (goto-char (match-beginning 0))))) - (or - (eolp) - ;; Don't put kinsoku-bol characters at the beginning of a line, - ;; or kinsoku-eol characters at the end of a line. - (cond - ;; Don't overflow the window edge, even if shr-kinsoku-shorten - ;; is nil. - ((or shr-kinsoku-shorten (null shr-width)) - (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char)))) - (backward-char 1)) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we look for the second best position. - (while (and (progn - (forward-char 1) - (<= (point) end)) - (progn - (setq bp (point)) - (shr-char-kinsoku-eol-p (following-char))))) - (goto-char bp))) - ((shr-char-kinsoku-eol-p (preceding-char)) - ;; Find backward the point where kinsoku-eol characters begin. - (let ((count 4)) - (while - (progn - (backward-char 1) - (and (> (setq count (1- count)) 0) - (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char))))))) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1)))) - ((shr-char-kinsoku-bol-p (following-char)) - ;; Find forward the point where kinsoku-bol characters end. - (let ((count 4)) - (while (progn - (forward-char 1) - (and (>= (setq count (1- count)) 0) - (shr-char-kinsoku-bol-p (following-char)) - (shr-char-breakable-p (following-char)))))))) - (when (eq (following-char) ? ) - (forward-char 1)))) - (not failed))) - (defun shr-parse-base (url) ;; Always chop off anchors. (when (string-match "#.*" url) @@ -941,15 +858,13 @@ size, and full-buffer size." shr-base)) (when (zerop (length url)) (setq url nil)) - ;; Strip leading/trailing whitespace - (and url (string-match "\\`\\s-+" url) - (setq url (substring url (match-end 0)))) - (and url (string-match "\\s-+\\'" url) - (setq url (substring url 0 (match-beginning 0)))) + ;; Strip leading/trailing whitespace. + (when url + (setq url (string-trim url))) (cond ((zerop (length url)) (nth 3 base)) ((or (not base) - (string-match "\\`[a-z]*:" url)) + (string-match-p "\\`[a-z]*:" url)) ;; Absolute or empty URI url) ((eq (aref url 0) ?/) @@ -963,8 +878,10 @@ size, and full-buffer size." ;; A link to an anchor. (concat (nth 3 base) url)) (t - ;; Totally relative. - (url-expand-file-name url (concat (car base) (cadr base)))))) + ;; Totally relative. Allow Tramp file names if we're + ;; rendering a file:// URL. + (let ((url-allow-non-local-files (equal (nth 2 base) "file"))) + (url-expand-file-name url (concat (car base) (cadr base))))))) (defun shr-ensure-newline () (unless (bobp) @@ -986,22 +903,6 @@ size, and full-buffer size." (looking-at " *$"))) ;; We're already at a new paragraph; do nothing. ) - ((and (not (bolp)) - (save-excursion - (beginning-of-line) - (looking-at " *$")) - (save-excursion - (forward-line -1) - (looking-at " *$")) - ;; Check all chars on the current line and see whether - ;; they're all placeholders. - (cl-loop for pos from (line-beginning-position) upto (1- (point)) - unless (get-text-property pos 'shr-target-id) - return nil - finally return t)) - ;; We have some invisible markers from <div id="foo"></div>; - ;; do nothing. - ) ((and prefix (= prefix (- (point) (line-beginning-position)))) ;; Do nothing; we're at the start of a <li>. @@ -1134,14 +1035,14 @@ the mouse click event." (let ((param (match-string 4 data)) (payload (url-unhex-string (match-string 5 data)))) (when (and param - (string-match "^.*\\(;[ \t]*base64\\)$" param)) + (string-match-p "^.*\\(;[ \t]*base64\\)$" param)) (setq payload (ignore-errors (base64-decode-string payload)))) payload))) ;; Behind display-graphic-p test. (declare-function image-size "image.c" (spec &optional pixels frame)) -(declare-function image-animate "image" (image &optional index limit)) +(declare-function image-animate "image" (image &optional index limit position)) (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. @@ -1178,13 +1079,14 @@ element is the data blob and the second element is the content-type." (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (if (eq size 'original) - (insert-sliced-image image (or alt "*") nil 20 1) - (insert-image image (or alt "*"))) - (put-text-property start (point) 'image-size size) - (when (and shr-image-animate - (cdr (image-multi-frame-p image))) - (image-animate image nil 60))) + (let ((image-pos (point))) + (if (eq size 'original) + (insert-sliced-image image (or alt "*") nil 20 1) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) + (when (and shr-image-animate + (cdr (image-multi-frame-p image))) + (image-animate image nil 60 image-pos)))) image) (insert (or alt "")))) @@ -1270,7 +1172,7 @@ Return a string with image data." ;; SVG images may contain references to further images that we may ;; want to block. So special-case these by parsing the XML data ;; and remove anything that looks like a blocked bit. - (when (and shr-blocked-images + (when (and (or shr-allowed-images shr-blocked-images) (eq content-type 'image/svg+xml)) (setq data ;; Note that libxml2 doesn't parse everything perfectly, @@ -1449,8 +1351,7 @@ ones, in case fg and bg are nil." ((or (not (eq (dom-tag elem) 'image)) ;; Filter out blocked elements inside the SVG image. (not (setq url (dom-attr elem ':xlink:href))) - (not shr-blocked-images) - (not (string-match shr-blocked-images url))) + (not (shr-image-blocked-p url))) (insert " ") (shr-dom-print elem))))) (insert (format "</%s>" (dom-tag dom)))) @@ -1467,12 +1368,14 @@ ones, in case fg and bg are nil." (defun shr-tag-sup (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise 0.2)))) + (put-text-property start (point) 'display '(raise 0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-sub (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise -0.2)))) + (put-text-property start (point) 'display '(raise -0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-p (dom) (shr-ensure-paragraph) @@ -1534,9 +1437,7 @@ ones, in case fg and bg are nil." (defun shr-parse-style (style) (when style - (save-match-data - (when (string-match "\n" style) - (setq style (replace-match " " t t style)))) + (setq style (replace-regexp-in-string "\n" " " style)) (let ((plist nil)) (dolist (elem (split-string style ";")) (when elem @@ -1565,15 +1466,22 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (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)) - (insert ?\s) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property start (1+ start) 'shr-target-id id)) + (when-let* ((id (and (not (dom-attr dom 'id)) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + (push (cons id (set-marker (make-marker) start)) shr--link-targets)) (when url - (shr-urlify (or shr-start start) (shr-expand-url url) title)))) + (shr-urlify (or shr-start start) (shr-expand-url url) title) + ;; Check whether the URL is suspicious. + (when-let ((warning (or (textsec-suspicious-p + (shr-expand-url url) 'url) + (textsec-suspicious-p + (cons (shr-expand-url url) + (buffer-substring (or shr-start start) + (point))) + 'link)))) + (add-text-properties (or shr-start start) (point) + (list 'face '(shr-link textsec-suspicious))) + (insert (propertize "⚠️" 'help-echo warning)))))) (defun shr-tag-abbr (dom) (let ((title (dom-attr dom 'title)) @@ -1594,7 +1502,7 @@ ones, in case fg and bg are nil." (let ((start (point)) url multimedia image) (when-let* ((type (dom-attr dom 'type))) - (when (string-match "\\`image/svg" type) + (when (string-match-p "\\`image/svg" type) (setq url (dom-attr dom 'data) image t))) (dolist (child (dom-non-text-children dom)) @@ -1630,6 +1538,14 @@ url if no type is specified. The value should be a float in the range 0.0 to :version "24.4" :type '(alist :key-type regexp :value-type float)) +(defcustom shr-use-xwidgets-for-media nil + "If non-nil, use xwidgets to display video and audio elements. +This also depends on Emacs being built with xwidgets capability. +Note that this is experimental, and may lead to instability on +some platforms." + :type 'boolean + :version "29.1") + (defun shr--get-media-pref (elem) "Determine the preference for ELEM. The preference is a float determined from `shr-prefer-media-type'." @@ -1666,16 +1582,39 @@ The preference is a float determined from `shr-prefer-media-type'." pref (cdr ret))))))))) (cons url pref)) +(declare-function xwidget-webkit-execute-script "xwidget.c" + (xwidget script &optional callback)) + (defun shr-tag-video (dom) (let ((image (dom-attr dom 'poster)) (url (dom-attr dom 'src)) (start (point))) (unless url (setq url (car (shr--extract-best-source dom)))) - (if (> (length image) 0) - (shr-indirect-call 'img nil image) - (shr-insert " [video] ")) - (shr-urlify start (shr-expand-url url)))) + (if (and shr-use-xwidgets-for-media + (fboundp 'make-xwidget)) + ;; Play the video. + (progn + (require 'xwidget) + (let ((widget (make-xwidget + 'webkit + "Video" + (truncate (* (window-pixel-width) 0.8)) + (truncate (* (window-pixel-width) 0.8 0.75))))) + (insert + (propertize + " [video] " + 'display (list 'xwidget :xwidget widget))) + (xwidget-webkit-execute-script + widget (format "document.body.innerHTML = %S;" + (format + "<style>body { margin: 0px; }</style><div style='background: black; height: 100%%; display: flex; align-items: center; justify-content: center;'><video autoplay loop muted controls style='max-width: 100%%; max-height: 100%%;'><source src=%S type='video/mp4'></source></video></div>" + url))))) + ;; No xwidgets. + (if (> (length image) 0) + (shr-indirect-call 'img nil image) + (shr-insert " [video] ")) + (shr-urlify start (shr-expand-url url))))) (defun shr-tag-audio (dom) (let ((url (dom-attr dom 'src)) @@ -1725,8 +1664,7 @@ The preference is a float determined from `shr-prefer-media-type'." (funcall shr-put-image-function image alt (list :width width :height height))))) ((or shr-inhibit-images - (and shr-blocked-images - (string-match shr-blocked-images url))) + (shr-image-blocked-p url)) (setq shr-start (point)) (shr-insert alt)) ((and (not shr-ignore-cache) @@ -2038,7 +1976,8 @@ BASE is the URL of the HTML being rendered." (setq dom (or (dom-child-by-tag dom 'tbody) dom)) (let* ((shr-inhibit-images t) (shr-table-depth (1+ shr-table-depth)) - (shr-kinsoku-shorten t) + ;; Fill hard in CJK languages. + (pixel-fill-respect-kinsoku nil) ;; Find all suggested widths. (columns (shr-column-specs dom)) ;; Compute how many pixels wide each TD should be. @@ -2532,9 +2471,10 @@ flags that control whether to collect or render objects." (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) (max-width 0) + (shr--link-targets nil) natural-width) (when style - (setq style (and (string-match "color" style) + (setq style (and (string-search "color" style) (shr-parse-style style)))) (when bgcolor (setq style (nconc (list (cons 'background-color bgcolor)) @@ -2573,6 +2513,7 @@ flags that control whether to collect or render objects." (end-of-line) (point))) (goto-char (point-min)) + (shr--set-target-ids shr--link-targets) (list max-width natural-width (count-lines (point-min) (point-max)) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index 468bc90a9d7..50342b9105a 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -79,6 +79,7 @@ (require 'sasl) (autoload 'sasl-find-mechanism "sasl") (autoload 'auth-source-search "auth-source") +(autoload 'auth-info-password "auth-source") ;; User customizable variables: @@ -230,10 +231,7 @@ Return the buffer associated with the connection." :max 1 :create t)) (user-name (or (plist-get (nth 0 auth-info) :user) "")) - (user-password (or (plist-get (nth 0 auth-info) :secret) "")) - (user-password (if (functionp user-password) - (funcall user-password) - user-password)) + (user-password (or (auth-info-password (nth 0 auth-info)) "")) (client (sasl-make-client (sasl-find-mechanism (list mech)) user-name "sieve" sieve-manage-server)) (sasl-read-passphrase diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 27acc8a4f32..5e7bdbe6c6a 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -5,12 +5,11 @@ ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> ;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org> ;; Created: December, 2009 -;; Version: 3.2.0 +;; Version: 3.2.1 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; URL: https://github.com/alex-hhh/emacs-soap-client -;; Package-Requires: ((cl-lib "0.6.1")) -;;FIXME: Put in `Package-Requires:' the Emacs version we expect. +;; Package-Requires: ((emacs "24.1") (cl-lib "0.6.1")) ;; This file is part of GNU Emacs. @@ -659,7 +658,7 @@ representing leap seconds." (if second (if second-fraction (let* ((second-fraction-significand - (string-replace "." "" second-fraction)) + (replace-regexp-in-string "\\." "" second-fraction)) (hertz (expt 10 (length second-fraction-significand))) (ticks (+ (* hertz (string-to-number second)) @@ -718,10 +717,9 @@ representing leap seconds." second) minute hour day month year second-fraction datatype time-zone) (let ((time - (apply - #'encode-time (list - (if new-decode-time new-decode-time-second second) - minute hour day month year nil nil time-zone)))) + (encode-time (list + (if new-decode-time new-decode-time-second second) + minute hour day month year nil nil time-zone)))) (if new-decode-time (with-no-warnings (decode-time time nil t)) (decode-time time)))))) @@ -1938,7 +1936,7 @@ This is a specialization of `soap-decode-type' for (e-name (soap-xs-element-name element)) ;; Heuristic: guess if we need to decode using local ;; namespaces. - (use-fq-names (string-search ":" (symbol-name (car node)))) + (use-fq-names (string-match ":" (symbol-name (car node)))) (children (if e-name (if use-fq-names ;; Find relevant children diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 3c1b032baf6..ce90943d9a6 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -107,7 +107,8 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-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) @@ -178,6 +179,7 @@ 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-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -191,11 +193,10 @@ It is used for TCP/IP devices." ;; 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-adb-file-name-p (filename) - "Check if it's a FILENAME for ADB." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-adb-method))) +(defsubst tramp-adb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for ADB." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) @@ -306,7 +307,7 @@ arguments to pass to the OPERATION." (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (with-parsed-tramp-file-name (expand-file-name directory) nil (copy-tree @@ -415,6 +416,8 @@ Emacs dired can't find files." (defun tramp-adb-ls-output-time-less-p (a b) "Sort \"ls\" output by time, descending." (let (time-a time-b) + ;; Once we can assume Emacs 27 or later, the two calls + ;; (apply #'encode-time X) can be replaced by (encode-time X). (string-match tramp-adb-ls-date-regexp a) (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) @@ -499,7 +502,7 @@ Emacs dired can't find files." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -591,8 +594,7 @@ Emacs dired can't find files." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. @@ -660,7 +662,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -720,8 +722,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file @@ -742,7 +743,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -776,7 +777,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-adb-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." (with-tramp-connection-property vec "signal-strings" - (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + (let ((default-directory (tramp-make-tramp-file-name vec 'noloc)) ;; `shell-file-name' and `shell-command-switch' are needed ;; for Emacs < 27.1, which doesn't support connection-local ;; variables in `shell-command'. @@ -815,10 +816,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Determine input. (if (null infile) (setq input (tramp-get-remote-null-device v)) - (setq infile (expand-file-name infile)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (tramp-file-local-name infile)) + (setq input (tramp-unquote-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)) @@ -849,7 +850,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 (tramp-file-local-name (cadr destination))) + (setq stderr (tramp-unquote-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) @@ -870,7 +871,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq ret (tramp-adb-send-command-and-check v (format "(cd %s; %s)" - (tramp-shell-quote-argument localname) command) + (tramp-unquote-shell-quote-argument localname) + command) t)) (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. @@ -900,8 +902,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - - (unless process-file-side-effects + (when process-file-side-effects (tramp-flush-directory-properties v "")) ;; Return exit status. @@ -986,6 +987,10 @@ implementation will be used." (name1 name) (i 0)) + (when (string-match-p "[[:multibyte:]]" command) + (tramp-error + v 'file-error "Cannot apply multi-byte command `%s'" command)) + (while (get-process name1) ;; NAME must be unique as process name. (setq i (1+ i) @@ -1264,7 +1269,7 @@ connection if a previous connection has died for some reason." (if (zerop (length device)) (tramp-error vec 'file-error "Device %s not connected" host)) (with-tramp-progress-reporter vec 3 "Opening adb shell connection" - (let* ((coding-system-for-read 'utf-8-dos) ;is this correct? + (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct? (process-connection-type tramp-process-connection-type) (args (if (> (length host) 0) (list "-s" device "shell") @@ -1349,25 +1354,39 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-adb-connection-local-default-shell-variables '((shell-file-name . "/system/bin/sh") (shell-command-switch . "-c")) "Default connection-local shell variables for remote adb connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) 'tramp-adb-connection-local-default-shell-profile)) +;; `shell-mode' tries to open remote files like "/adb::~/.history". +;; This fails, because the tilde cannot be expanded. Tell +;; `tramp-handle-expand-file-name' to tolerate this. +(defun tramp-adb-tolerate-tilde (orig-fun) + "Advice for `shell-mode' to tolerate tilde in remote file names." + (let ((tramp-tolerate-tilde + (or tramp-tolerate-tilde + (equal (file-remote-p default-directory 'method) + tramp-adb-method)))) + (funcall orig-fun))) + +(add-function + :around (symbol-function #'shell-mode) #'tramp-adb-tolerate-tilde) +(add-hook 'tramp-adb-unload-hook + (lambda () + (remove-function + (symbol-function #'shell-mode) #'tramp-adb-tolerate-tilde))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-adb 'force))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 1b5f42a9912..788e4573679 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -54,6 +54,7 @@ ;; * ".ar" - UNIX archiver formats ;; * ".cab", ".CAB" - Microsoft Windows cabinets ;; * ".cpio" - CPIO archives +;; * ".crate" - Cargo (Rust) packages ;; * ".deb" - Debian packages ;; * ".depot" - HP-UX SD depots ;; * ".exe" - Self extracting Microsoft Windows EXE files @@ -141,6 +142,7 @@ "ar" ;; UNIX archiver formats. "cab" "CAB" ;; Microsoft Windows cabinets. "cpio" ;; CPIO archives. + "crate" ;; Cargo (Rust) packages. Not in libarchive testsuite. "deb" ;; Debian packages. Not in libarchive testsuite. "depot" ;; HP-UX SD depot. Not in libarchive testsuite. "exe" ;; Self extracting Microsoft Windows EXE files. @@ -188,6 +190,8 @@ It must be supported by libarchive(3).") "\\)" ;; \1 "\\(" "/" ".*" "\\)" "\\'"))) ;; \2 +(put #'tramp-archive-autoload-file-name-regexp 'tramp-autoload t) + ;; In older Emacsen (prior 27.1), `tramp-archive-autoload-file-name-regexp' ;; is not autoloaded. So we cannot expect it to be known in ;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded. @@ -211,7 +215,8 @@ It must be supported by libarchive(3).") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-archive-file-name-handler-alist - '((access-file . tramp-archive-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-archive-handle-access-file) (add-name-to-file . tramp-archive-handle-not-implemented) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. @@ -282,6 +287,7 @@ 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-get-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -363,6 +369,8 @@ arguments to pass to the OPERATION." (tramp-archive-autoload t)) (apply #'tramp-autoload-file-name-handler operation args))))) +(put #'tramp-archive-autoload-file-name-handler 'tramp-autoload t) + ;;;###autoload (progn (defun tramp-register-archive-file-name-handler () "Add archive file name handler to `file-name-handler-alist'." @@ -372,6 +380,8 @@ arguments to pass to the OPERATION." #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t)))) +(put #'tramp-register-archive-file-name-handler 'tramp-autoload t) + ;;;###autoload (progn (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) @@ -454,7 +464,7 @@ name is kept in slot `hop'" ((tramp-archive-file-name-p archive) (let ((archive (tramp-make-tramp-file-name - (tramp-archive-dissect-file-name archive) nil 'noarchive))) + (tramp-archive-dissect-file-name archive)))) (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) (puthash archive (list vec) tramp-archive-hash)) @@ -557,8 +567,7 @@ offered." (defun tramp-archive-gvfs-file-name (name) "Return NAME in GVFS syntax." - (tramp-make-tramp-file-name - (tramp-archive-dissect-file-name name) nil 'nohop)) + (tramp-make-tramp-file-name (tramp-archive-dissect-file-name name))) ;; File name primitives. @@ -572,9 +581,8 @@ offered." preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for file archives." (when (tramp-archive-file-name-p newname) - (tramp-error - (tramp-archive-dissect-file-name newname) 'file-error - "Permission denied: %s" newname)) + (tramp-compat-permission-denied + (tramp-archive-dissect-file-name newname) newname)) (copy-file (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)) @@ -618,7 +626,7 @@ offered." (defun tramp-archive-handle-file-system-info (filename) "Like `file-system-info' for file archives." (with-parsed-tramp-archive-file-name filename nil - (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + (list (file-attribute-size (file-attributes archive)) 0 0))) (defun tramp-archive-handle-file-truename (filename) "Like `file-truename' for file archives." @@ -658,7 +666,7 @@ offered." ;; mounted directory, it is returned as it. Not what we want. (with-parsed-tramp-archive-file-name default-directory nil (let ((default-directory (file-name-directory archive))) - (tramp-compat-temporary-file-directory-function)))) + (temporary-file-directory)))) (defun tramp-archive-handle-not-implemented (operation &rest args) "Generic handler for operations not implemented for file archives." diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index d35f7ffa4e3..dc1e3d28b58 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -49,8 +49,6 @@ ;; 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. -;; "lock-pid" is the timestamp a (network) process is created, it is -;; used instead of the pid in file locks. ;; ;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep @@ -101,8 +99,7 @@ details see the info pages." (choice :tag " Value" sexp)))) ;;;###tramp-autoload -(defcustom tramp-persistency-file-name - (expand-file-name (locate-user-emacs-file "tramp")) +(defcustom tramp-persistency-file-name (locate-user-emacs-file "tramp") "File which keeps connection history for Tramp connections." :group 'tramp :type 'file) @@ -127,7 +124,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (dolist (elt tramp-connection-properties) (when (string-match-p (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-make-tramp-file-name key 'noloc)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash)))) @@ -225,7 +222,9 @@ Return VALUE." (defun tramp-flush-file-upper-properties (key file) "Remove some properties of FILE's upper directory." (when (file-name-absolute-p file) - (let ((file (directory-file-name (file-name-directory file)))) + ;; `file-name-directory' can return nil, for example for "~". + (when-let ((file (file-name-directory file)) + (file (directory-file-name file))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 43aed625550..c18ab4972d2 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -67,7 +67,7 @@ SYNTAX can be one of the symbols `default' (default), nil (mapcar (lambda (x) - (with-current-buffer x (when (tramp-tramp-file-p default-directory) x))) + (when (tramp-tramp-file-p (tramp-get-default-directory x)) x)) (buffer-list)))) ;;;###tramp-autoload @@ -593,9 +593,8 @@ buffer in your bug report. (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." - (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer)) - (val (with-current-buffer reporter-eval-buffer - (symbol-value varsym)))) + (when-let ((reporter-eval-buffer reporter-eval-buffer) + (val (buffer-local-value varsym reporter-eval-buffer))) (if (hash-table-p val) ;; Pretty print the cache. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index aead1dedd24..bd6d53afcb8 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,17 +23,12 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 28. This -;; package provides compatibility functions for Emacs 25, Emacs 26 and -;; Emacs 27. +;; Tramp's main Emacs version for development is Emacs 29. This +;; package provides compatibility functions for Emacs 26, Emacs 27 and +;; Emacs 28. ;;; Code: -;; 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) (require 'format-spec) (require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. @@ -42,8 +37,7 @@ (require 'subr-x) (declare-function tramp-error "tramp") -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(declare-function tramp-handle-temporary-file-directory "tramp") +(declare-function tramp-file-name-handler "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -83,133 +77,19 @@ Add the extension of F, if existing." 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 - (if (fboundp 'temporary-file-directory) - #'temporary-file-directory - #'tramp-handle-temporary-file-directory)) - -;; `file-attribute-*' are introduced in Emacs 26.1. - -(defalias 'tramp-compat-file-attribute-type - (if (fboundp 'file-attribute-type) - #'file-attribute-type - (lambda (attributes) - "The type field in ATTRIBUTES returned by `file-attributes'. -The value is either t for directory, string (name linked to) for -symbolic link, or nil." - (nth 0 attributes)))) - -(defalias 'tramp-compat-file-attribute-link-number - (if (fboundp 'file-attribute-link-number) - #'file-attribute-link-number - (lambda (attributes) - "Return the number of links in ATTRIBUTES returned by `file-attributes'." - (nth 1 attributes)))) - -(defalias 'tramp-compat-file-attribute-user-id - (if (fboundp 'file-attribute-user-id) - #'file-attribute-user-id - (lambda (attributes) - "The UID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 2 attributes)))) - -(defalias 'tramp-compat-file-attribute-group-id - (if (fboundp 'file-attribute-group-id) - #'file-attribute-group-id - (lambda (attributes) - "The GID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 3 attributes)))) - -(defalias 'tramp-compat-file-attribute-access-time - (if (fboundp 'file-attribute-access-time) - #'file-attribute-access-time - (lambda (attributes) - "The last access time in ATTRIBUTES returned by `file-attributes'. -This a Lisp timestamp in the style of `current-time'." - (nth 4 attributes)))) - -(defalias 'tramp-compat-file-attribute-modification-time - (if (fboundp 'file-attribute-modification-time) - #'file-attribute-modification-time - (lambda (attributes) - "The modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of the last change to the file's contents, and -is a Lisp timestamp in the style of `current-time'." - (nth 5 attributes)))) - -(defalias 'tramp-compat-file-attribute-status-change-time - (if (fboundp 'file-attribute-status-change-time) - #'file-attribute-status-change-time - (lambda (attributes) - "The status modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of last change to the file's attributes: owner -and group, access mode bits, etc., and is a Lisp timestamp in the -style of `current-time'." - (nth 6 attributes)))) - -(defalias 'tramp-compat-file-attribute-size - (if (fboundp 'file-attribute-size) - #'file-attribute-size - (lambda (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -If the size is too large for a fixnum, this is a bignum in Emacs 27 -and later, and is a float in Emacs 26 and earlier." - (nth 7 attributes)))) - -(defalias 'tramp-compat-file-attribute-modes - (if (fboundp 'file-attribute-modes) - #'file-attribute-modes - (lambda (attributes) - "The file modes in ATTRIBUTES returned by `file-attributes'. -This is a string of ten letters or dashes as in ls -l." - (nth 8 attributes)))) - -;; `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.") - -(defsubst tramp-compat-file-missing (vec file) - "Emit the `file-missing' error." - (if (get 'file-missing 'error-conditions) - (tramp-error vec tramp-file-missing file) - (tramp-error vec tramp-file-missing "No such file or directory: %s" file))) - -;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26.1. -(defalias 'tramp-compat-file-local-name - (if (fboundp 'file-local-name) - #'file-local-name - (lambda (name) - "Return the local name component of NAME. -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', `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) - (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2))) + (if (equal (func-arity #'file-name-quoted-p) '(1 . 2)) #'file-name-quoted-p (lambda (name &optional top) "Whether NAME is quoted with prefix \"/:\". If NAME is a remote file name and TOP is nil, check the local part of NAME." (let ((file-name-handler-alist (unless top file-name-handler-alist))) - (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) + (string-prefix-p "/:" (file-local-name name)))))) (defalias 'tramp-compat-file-name-quote - (if (and - (fboundp 'file-name-quote) - (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2))) + (if (equal (func-arity #'file-name-quote) '(1 . 2)) #'file-name-quote (lambda (name &optional top) "Add the quotation prefix \"/:\" to file NAME. @@ -217,20 +97,17 @@ If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." (let ((file-name-handler-alist (unless top file-name-handler-alist))) (if (tramp-compat-file-name-quoted-p name top) name - (concat - (file-remote-p name) "/:" (tramp-compat-file-local-name name))))))) + (concat (file-remote-p name) "/:" (file-local-name name))))))) (defalias 'tramp-compat-file-name-unquote - (if (and - (fboundp 'file-name-unquote) - (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2))) + (if (equal (func-arity #'file-name-unquote) '(1 . 2)) #'file-name-unquote (lambda (name &optional top) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name and TOP is nil, the local part of NAME is unquoted." (let* ((file-name-handler-alist (unless top file-name-handler-alist)) - (localname (tramp-compat-file-local-name name))) + (localname (file-local-name name))) (when (tramp-compat-file-name-quoted-p localname top) (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) @@ -257,8 +134,8 @@ NAME is unquoted." #'exec-path (lambda () "List of directories to search programs to run in remote subprocesses." - (if-let ((handler (find-file-name-handler default-directory 'exec-path))) - (funcall handler 'exec-path) + (if (tramp-tramp-file-p default-directory) + (tramp-file-name-handler 'exec-path) exec-path)))) ;; `time-equal-p' has appeared in Emacs 27.1. @@ -288,8 +165,7 @@ A nil value for either argument stands for the current time." ;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. (defalias 'tramp-compat-progress-reporter-update - (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update) - '(1 . 3)) + (if (equal (func-arity #'progress-reporter-update) '(1 . 3)) #'progress-reporter-update (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) @@ -306,19 +182,19 @@ CONDITION can also be a list of error conditions." ;; `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)) + (if (equal (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)) + (if (equal (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)) + (if (equal (func-arity #'set-file-times) '(1 . 3)) #'set-file-times (lambda (filename &optional timestamp _flag) (set-file-times filename timestamp)))) @@ -326,14 +202,13 @@ CONDITION can also be a list of error conditions." ;; `directory-files' and `directory-files-and-attributes' got argument ;; COUNT in Emacs 28.1. (defalias 'tramp-compat-directory-files - (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5)) + (if (equal (func-arity #'directory-files) '(1 . 5)) #'directory-files (lambda (directory &optional full match nosort _count) (directory-files directory full match nosort)))) (defalias 'tramp-compat-directory-files-and-attributes - (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes) - '(1 . 6)) + (if (equal (func-arity #'directory-files-and-attributes) '(1 . 6)) #'directory-files-and-attributes (lambda (directory &optional full match nosort id-format _count) (directory-files-and-attributes directory full match nosort id-format)))) @@ -398,6 +273,27 @@ CONDITION can also be a list of error conditions." (car components)) (cdr components))))))) +;; `permission-denied' is introduced in Emacs 29.1. +(defconst tramp-permission-denied + (if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error) + "The error symbol for the `permission-denied' error.") + +(defsubst tramp-compat-permission-denied (vec file) + "Emit the `permission-denied' error." + (if (get 'permission-denied 'error-conditions) + (tramp-error vec tramp-permission-denied file) + (tramp-error vec tramp-permission-denied "Permission denied: %s" file))) + +;; Function `auth-info-password' is new in Emacs 29.1. +(defalias 'tramp-compat-auth-info-password + (if (fboundp 'auth-info-password) + #'auth-info-password + (lambda (auth-info) + (let ((secret (plist-get auth-info :secret))) + (while (functionp secret) + (setq secret (funcall secret))) + secret)))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) @@ -410,8 +306,6 @@ CONDITION can also be a list of error conditions." ;;; TODO: ;; -;; * `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. ;; diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index e8313463da4..fb3ba08bb14 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -157,7 +157,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-crypt-file-name-handler-alist - '((access-file . tramp-crypt-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (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) @@ -192,9 +193,9 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; `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-notify-add-watch . tramp-handle-file-notify-add-watch) + (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (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) @@ -207,7 +208,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (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. + (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -228,6 +229,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (start-file-process . ignore) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-handle-temporary-file-directory) + ;; `tramp-get-home-directory' performed by default-handler. ;; `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) @@ -294,8 +296,8 @@ arguments to pass to the OPERATION." (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)) + (locate-user-emacs-file + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config)))) (defun tramp-crypt-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -322,7 +324,7 @@ connection if a previous connection has died for some reason." 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)) + (unless (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. @@ -485,6 +487,7 @@ See `tramp-crypt-do-encrypt-or-decrypt-file'." 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." + ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) @@ -596,7 +599,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -698,7 +701,7 @@ absolute file names." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let* (tramp-crypt-enabled diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 650e839f823..ff8caa570ca 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -175,11 +175,10 @@ pass to the OPERATION." ;; 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-ftp-file-name-p (filename) - "Check if it's a FILENAME that should be forwarded to Ange-FTP." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method))) +(defsubst tramp-ftp-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-ftp-method))) ;;;###tramp-autoload (tramp--with-startup diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 17d419f853b..2a73d5aa02b 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -48,7 +48,7 @@ (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (with-parsed-tramp-file-name directory nil @@ -107,12 +107,6 @@ (unless (string-match-p elt item) (throw 'match nil))) (setq result (cons (concat item "/") result)))))))))) -(defun tramp-fuse-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-readable-p" - (file-readable-p (tramp-fuse-local-file-name filename))))) - ;; This function isn't used. (defun tramp-fuse-handle-insert-directory (filename switches &optional wildcard full-directory-p) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 0bba894cdbb..d6120d2bee1 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -122,10 +122,7 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (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") + (or (tramp-process-running-p "gvfs-fuse-daemon") (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") @@ -471,8 +468,7 @@ It has been changed in GVFS 1.14.") ;; </method> ;; </interface> -;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for GNOME Online Accounts. (cl-defstruct (tramp-goa-account (:type list) :named) method user host port) ;;;###tramp-autoload @@ -672,8 +668,7 @@ It has been changed in GVFS 1.14.") ;; 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. +;; The basic structure for media devices. (cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We @@ -749,7 +744,8 @@ It has been changed in GVFS 1.14.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-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) @@ -820,6 +816,7 @@ 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-home-directory . tramp-gvfs-handle-get-home-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) @@ -834,12 +831,11 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; 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-gvfs-file-name-p (filename) - "Check if it's a FILENAME handled by the GVFS daemon." - (and (tramp-tramp-file-p filename) - (let ((method - (tramp-file-name-method (tramp-dissect-file-name filename)))) - (and (stringp method) (member method tramp-gvfs-methods))))) +(defsubst tramp-gvfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (let ((method (tramp-file-name-method vec))) + (and (stringp method) (member method tramp-gvfs-methods))))) ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) @@ -921,8 +917,6 @@ or `dbus-call-method-asynchronously'." ;; when loading. (dbus-ignore-errors (tramp-dbus-function ,vec func args)))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) - (defmacro with-tramp-dbus-get-all-properties (vec bus service path interface) "Return all properties of INTERFACE. @@ -937,8 +931,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)))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) - (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. It is needed when D-Bus signals or errors arrive, because there @@ -1002,7 +994,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -1102,8 +1094,7 @@ file names." (tramp-skeleton-delete-directory directory recursive trash (if (and recursive (not (file-symlink-p directory))) (mapc (lambda (file) - (if (eq t (tramp-compat-file-attribute-type - (file-attributes file))) + (if (eq t (file-attribute-type (file-attributes file))) (delete-directory file recursive) (delete-file file))) (directory-files @@ -1149,21 +1140,18 @@ file names." ;; Dissect NAME. (with-parsed-tramp-file-name name nil ;; If there is a default location, expand tilde. - (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname) - (save-match-data - (tramp-gvfs-maybe-open-connection - (make-tramp-file-name - :method method :user user :domain domain - :host host :port port :localname "/" :hop hop))) - (setq localname - (replace-match - (tramp-get-connection-property v "default-location" "~") - nil t localname 1))) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) ;; Tilde expansion is not possible. - (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (tramp-error - v 'file-error - "Cannot expand tilde in file `%s'" name)) + (when (and (not tramp-tolerate-tilde) + (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) + (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". @@ -1178,10 +1166,12 @@ file names." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (tramp-run-real-handler #'expand-file-name (list localname)))))) + v (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." @@ -1396,7 +1386,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-executable-p" - (tramp-check-cached-permissions v ?x)))) + (or (tramp-check-cached-permissions v ?x) + (tramp-check-cached-permissions v ?s))))) (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." @@ -1463,7 +1454,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." `file-notify' events." (let* ((events (process-get proc 'events)) (rest-string (process-get proc 'rest-string)) - (dd (with-current-buffer (process-buffer proc) default-directory)) + (dd (tramp-get-default-directory (process-buffer proc))) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) @@ -1528,11 +1519,13 @@ 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 (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")))))))) + (when (or size free) + (list (and size (string-to-number size)) + (and free (string-to-number free)) + ;; "mtp" connections do not return "filesystem::used". + (or (and size used + (- (string-to-number size) (string-to-number used))) + (and free (string-to-number free)))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1602,9 +1595,30 @@ If FILE-SYSTEM is non-nil, return file system attributes." "%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) + nil time))))) +(defun tramp-gvfs-handle-get-home-directory (vec &optional _user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (let ((localname + (tramp-get-connection-property vec "default-location" nil)) + result) + (cond + ((zerop (length localname)) + (tramp-get-connection-property (tramp-get-process vec) "share" nil)) + ;; Google-drive. + ((not (string-prefix-p "/" localname)) + (dolist (item + (tramp-gvfs-get-directory-attributes + (tramp-make-tramp-file-name vec "/")) + result) + (when (string-equal (cdr (assoc "name" item)) localname) + (setq result (concat "/" (car item)))))) + (t localname)))) + (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'." @@ -1612,22 +1626,18 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-file-name-user vec) (when-let ((localname (tramp-get-connection-property - (tramp-get-process vec) "share" - (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))))) + (tramp-get-process vec) "share" nil))) + (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 - (tramp-get-process vec) "share" - (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)))) + (tramp-get-process vec) "share" nil))) + (file-attribute-group-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1865,9 +1875,9 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and host (tramp-file-name-host v) port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) - (let ((v (make-tramp-file-name - :method method :user user :domain domain - :host host :port port))) + (let ((v (make-tramp-file-name + :method method :user user :domain domain + :host host :port port))) (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) @@ -2134,9 +2144,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) @@ -2256,13 +2263,7 @@ connection if a previous connection has died for some reason." COMMAND is a command from the gvfs-* utilities. It is replaced by the corresponding gio tool call if available. `call-process' is applied, and it returns t if the return code is zero." - (let* ((locale (tramp-get-local-locale vec)) - (process-environment - (append - `(,(format "LANG=%s" locale) - ,(format "LANGUAGE=%s" locale) - ,(format "LC_ALL=%s" locale)) - process-environment))) + (let ((locale (tramp-get-local-locale vec))) (when (tramp-gvfs-gio-tool-p vec) ;; Use gio tool. (setq args (cons (cdr (assoc command tramp-gvfs-gio-mapping)) @@ -2272,7 +2273,14 @@ is applied, and it returns t if the return code is zero." (with-current-buffer (tramp-get-connection-buffer vec) (tramp-gvfs-maybe-open-connection vec) (erase-buffer) - (or (zerop (apply #'tramp-call-process vec command nil t nil args)) + (or (zerop + (apply + #'tramp-call-process vec "env" nil t nil + (append `(,(format "LANG=%s" locale) + ,(format "LANGUAGE=%s" locale) + ,(format "LC_ALL=%s" locale) + ,command) + args))) ;; Remove information about mounted connection. (and (tramp-flush-file-properties vec "/") nil))))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index b5df9804ab4..3b2e7c0f916 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -85,13 +85,6 @@ special handling of `substitute-in-file-name'." "An overlay covering the shadowed part of the filename." (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) -;; Package rfn-eshadow is preloaded in Emacs, but for some reason, -;; it only did (defvar rfn-eshadow-overlay) without giving it a global -;; value, so it was only declared as dynamically-scoped within the -;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need -;; this defvar here for older releases. -(defvar rfn-eshadow-overlay) - (defun tramp-rfn-eshadow-update-overlay () "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. This is intended to be used as a minibuffer `post-command-hook' for @@ -278,25 +271,21 @@ NAME must be equal to `tramp-current-connection'." #'tramp-compile-disable-ssh-controlmaster-options) (add-hook 'tramp-integration-unload-hook (lambda () - (remove-hook 'compilation-start-hook + (remove-hook 'compilation-mode-hook #'tramp-compile-disable-ssh-controlmaster-options)))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-connection-local-default-system-variables '((path-separator . ":") (null-device . "/dev/null")) "Default connection-local system variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-system-profile tramp-connection-local-default-system-variables) -(tramp-compat-funcall - 'connection-local-set-profiles +(connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-system-profile) @@ -305,14 +294,12 @@ NAME must be equal to `tramp-current-connection'." (shell-command-switch . "-c")) "Default connection-local shell variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-shell-profile tramp-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 20e983c77d1..126b09fcbf3 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-rclone-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-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) @@ -106,11 +107,11 @@ (file-name-nondirectory . tramp-handle-file-name-nondirectory) ;; `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-notify-add-watch . tramp-handle-file-notify-add-watch) + (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fuse-handle-file-readable-p) + (file-readable-p . tramp-rclone-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) @@ -142,6 +143,7 @@ (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -156,11 +158,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; 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-rclone-file-name-p (filename) - "Check if it's a FILENAME for rclone." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-rclone-method))) +(defsubst tramp-rclone-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for rclone." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-rclone-method))) ;;;###tramp-autoload (defun tramp-rclone-file-name-handler (operation &rest args) @@ -223,7 +224,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -280,6 +281,12 @@ file names." (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) +(defun tramp-rclone-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-readable-p" + (file-readable-p (tramp-fuse-local-file-name filename))))) + (defun tramp-rclone-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors @@ -362,10 +369,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property - p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index de4d579740a..c80190a67fb 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -34,8 +34,11 @@ (eval-when-compile (require 'cl-lib)) (require 'tramp) +;; `dired-*' declarations can be removed, starting with Emacs 29.1. +(declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) +;; Added in Emacs 28.1. (defvar process-file-return-signal-string) (defvar vc-handled-backends) (defvar vc-bzr-program) @@ -134,6 +137,12 @@ be auto-detected by Tramp. The string is used in `tramp-methods'.") +(defcustom tramp-use-scp-direct-remote-copying nil + "Whether to use direct copying between two remote hosts." + :group 'tramp + :version "29.1" + :type 'boolean) + ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload (tramp--with-startup @@ -170,7 +179,7 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("%x") ("-q") ("-r") ("%c"))) + ("%x") ("%y") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -186,7 +195,7 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("%x") ("-q") ("-r") ("%c"))) + ("%x") ("%y") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -292,7 +301,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10) - (tramp-session-timeout 300))) + (tramp-session-timeout 300) + (tramp-password-previous-hop t))) (add-to-list 'tramp-methods `("doas" (tramp-login-program "doas") @@ -300,7 +310,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10) - (tramp-session-timeout 300))) + (tramp-session-timeout 300) + (tramp-password-previous-hop t))) (add-to-list 'tramp-methods `("ksu" (tramp-login-program "ksu") @@ -940,7 +951,8 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) @@ -952,6 +964,8 @@ Format specifiers \"%s\" are replaced before the script is used.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-sh-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' performed by + ;; default handler. (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sh-handle-exec-path) @@ -1011,6 +1025,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (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-home-directory . tramp-sh-handle-get-home-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) @@ -1144,8 +1159,7 @@ component is used as the target of the symlink." (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)) - 'nohop))))) + result))))))) ;; Basic functions. @@ -1334,7 +1348,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (or (tramp-compat-file-attribute-modification-time attr) + (modtime (or (file-attribute-modification-time attr) tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) @@ -1372,7 +1386,7 @@ of." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -1424,7 +1438,7 @@ of." (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) + nil time))) (tramp-send-command-and-check v (format @@ -1436,6 +1450,20 @@ of." (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (when (tramp-send-command-and-check + vec (format + "echo %s" + (tramp-shell-quote-argument + (concat "~" (or user (tramp-file-name-user vec)))))) + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))))) + (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'." @@ -1574,6 +1602,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; Examine `file-attributes' cache to see if request can be ;; satisfied without remote operation. (or (tramp-check-cached-permissions v ?x) + (tramp-check-cached-permissions v ?s) (tramp-run-test "-x" filename))))) (defun tramp-sh-handle-file-readable-p (filename) @@ -1620,14 +1649,14 @@ ID-FORMAT valid values are `string' and `integer'." ;; information would be lost by an (attempted) delete and create. (or (null attributes) (and - (= (tramp-compat-file-attribute-user-id attributes) + (= (file-attribute-user-id attributes) (tramp-get-remote-uid v 'integer)) (or (not group) ;; On BSD-derived systems files always inherit the ;; parent directory's group, so skip the group-gid ;; test. (tramp-check-remote-uname v "BSD\\|DragonFly\\|Darwin") - (= (tramp-compat-file-attribute-group-id attributes) + (= (file-attribute-group-id attributes) (tramp-get-remote-gid v 'integer))))))))) ;; Directory listings. @@ -1637,8 +1666,7 @@ ID-FORMAT valid values are `string' and `integer'." "Like `directory-files-and-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) (unless (file-exists-p directory) - (tramp-compat-file-missing - (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (expand-file-name directory)) (let* ((temp @@ -1858,7 +1886,7 @@ ID-FORMAT valid values are `string' and `integer'." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -1952,7 +1980,7 @@ file names." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (length (tramp-compat-file-attribute-size + (length (file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes (file-extended-attributes filename))) @@ -1960,7 +1988,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -2052,7 +2080,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." ;; Check, whether file is too large. Emacs checks in `insert-file-1' ;; and `find-file-noselect', but that's not called here. (abort-if-file-too-large - (tramp-compat-file-attribute-size (file-attributes (file-truename filename))) + (file-attribute-size (file-attributes (file-truename filename))) (symbol-name op) filename) ;; We must disable multibyte, because binary data shall not be ;; converted. We don't want the target file to be compressed, so we @@ -2074,8 +2102,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) @@ -2094,7 +2121,7 @@ as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep the uid and gid from FILENAME." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename))) (with-parsed-tramp-file-name (if t1 filename newname) nil @@ -2238,201 +2265,210 @@ the uid and gid from FILENAME." (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)) - (t2 (tramp-tramp-file-p newname)) - (orig-vec (tramp-dissect-file-name (if t1 filename newname))) + (let* ((v1 (and (tramp-tramp-file-p filename) + (tramp-dissect-file-name filename))) + (v2 (and (tramp-tramp-file-p newname) + (tramp-dissect-file-name newname))) + (v (or v1 v2)) copy-program copy-args copy-env copy-keep-date listener spec options source target remote-copy-program remote-copy-args p) - (with-parsed-tramp-file-name (if t1 filename newname) nil - (if (and t1 t2) - - ;; Both are Tramp files. We shall optimize it when the - ;; methods for FILENAME and NEWNAME are the same. - (let* ((dir-flag (file-directory-p filename)) - (tmpfile (tramp-compat-make-temp-file localname dir-flag))) - (if dir-flag - (setq tmpfile - (expand-file-name - (file-name-nondirectory newname) tmpfile))) - (unwind-protect - (progn - (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile ok-if-already-exists keep-date) - (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname ok-if-already-exists keep-date)) - ;; Save exit. - (ignore-errors - (if dir-flag - (delete-directory - (expand-file-name ".." tmpfile) 'recursive) - (delete-file tmpfile))))) - - ;; Check which ones of source and target are Tramp files. - (setq source (funcall - (if (and (string-equal method "rsync") - (file-directory-p filename) - (not (file-exists-p newname))) - #'file-name-as-directory - #'identity) - (if t1 - (tramp-make-copy-program-file-name v) - (tramp-compat-file-name-unquote filename))) - target (if t2 - (tramp-make-copy-program-file-name v) - (tramp-compat-file-name-unquote newname))) - - ;; Check for user. There might be an interactive setting. - (setq user (or (tramp-file-name-user v) - (tramp-get-connection-property v "login-as" nil))) - - ;; Check for listener port. - (when (tramp-get-method-parameter v 'tramp-remote-copy-args) - (setq listener (number-to-string (+ 50000 (random 10000)))) - (while - (zerop (tramp-call-process v "nc" nil nil nil "-z" host listener)) - (setq listener (number-to-string (+ 50000 (random 10000)))))) - - ;; Compose copy command. - (setq options - (format-spec - (tramp-ssh-controlmaster-options v) - (format-spec-make - ?t (tramp-get-connection-property - (tramp-get-connection-process v) "temp-file" ""))) - spec (list - ?h (or host "") ?u (or user "") ?p (or port "") - ?r listener ?c options ?k (if keep-date " " "") - ?n (concat "2>" (tramp-get-remote-null-device v)) - ?x (tramp-scp-strict-file-name-checking v)) - copy-program (tramp-get-method-parameter v 'tramp-copy-program) - copy-keep-date (tramp-get-method-parameter - v 'tramp-copy-keep-date) - copy-args - ;; " " has either been a replacement of "%k" (when - ;; keep-date argument is non-nil), or a replacement for - ;; the whole keep-date sublist. - (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) - ;; `tramp-ssh-controlmaster-options' is a string instead - ;; of a list. Unflatten it. - copy-args - (tramp-compat-flatten-tree - (mapcar - (lambda (x) (if (tramp-compat-string-search " " x) - (split-string x) x)) - copy-args)) - copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) - remote-copy-program - (tramp-get-method-parameter v 'tramp-remote-copy-program) - remote-copy-args - (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) - - ;; Check for local copy program. - (unless (executable-find copy-program) - (tramp-error - v 'file-error "Cannot find local copy program: %s" copy-program)) - - ;; Install listener on the remote side. The prompt must be - ;; consumed later on, when the process does not listen anymore. - (when remote-copy-program - (unless (with-tramp-connection-property - v (concat "remote-copy-program-" remote-copy-program) - (tramp-find-executable - v remote-copy-program (tramp-get-remote-path v))) - (tramp-error - v 'file-error - "Cannot find remote listener: %s" remote-copy-program)) - (setq remote-copy-program - (mapconcat - #'identity - (append - (list remote-copy-program) remote-copy-args - (list (if t1 (concat "<" source) (concat ">" target)) "&")) - " ")) - (tramp-send-command v remote-copy-program) - (with-timeout - (60 (tramp-error - v 'file-error - "Listener process not running on remote host: `%s'" - remote-copy-program)) - (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) - (while (not (tramp-send-command-and-check v nil)) - (tramp-send-command - v (format "netstat -l | grep -q :%s" listener))))) + (if (and v1 v2 (zerop (length (tramp-scp-direct-remote-copying v1 v2)))) - (with-temp-buffer + ;; Both are Tramp files. We cannot use direct remote copying. + (let* ((dir-flag (file-directory-p filename)) + (tmpfile (tramp-compat-make-temp-file + (tramp-file-name-localname v1) dir-flag))) + (if dir-flag + (setq tmpfile + (expand-file-name + (file-name-nondirectory newname) tmpfile))) (unwind-protect - ;; The default directory must be remote. - (let ((default-directory - (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment))) - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - (when copy-env - (tramp-message - orig-vec 6 "%s=\"%s\"" - (car copy-env) (string-join (cdr copy-env) " ")) - (setenv (car copy-env) (string-join (cdr copy-env) " "))) - (setq - copy-args - (append - copy-args - (if remote-copy-program - (list (if t1 (concat ">" target) (concat "<" source))) - (list source target))) - ;; Use an asynchronous process. By this, password - ;; can be handled. We don't set a timeout, because - ;; the copying of large files can last longer than 60 - ;; secs. - p (let ((default-directory tramp-compat-temporary-file-directory)) - (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - copy-program copy-args))) - (tramp-message orig-vec 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector orig-vec) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) + (progn + (tramp-do-copy-or-rename-file-out-of-band + op filename tmpfile ok-if-already-exists keep-date) + (tramp-do-copy-or-rename-file-out-of-band + 'rename tmpfile newname ok-if-already-exists keep-date)) + ;; Save exit. + (ignore-errors + (if dir-flag + (delete-directory + (expand-file-name ".." tmpfile) 'recursive) + (delete-file tmpfile))))) + + ;; Check which ones of source and target are Tramp files. + (setq source (funcall + (if (and (string-equal (tramp-file-name-method v) "rsync") + (file-directory-p filename) + (not (file-exists-p newname))) + #'file-name-as-directory + #'identity) + (if v1 + (tramp-make-copy-program-file-name v1) + (tramp-compat-file-name-unquote filename))) + target (if v2 + (tramp-make-copy-program-file-name v2) + (tramp-compat-file-name-unquote newname))) + + ;; Check for listener port. + (when (tramp-get-method-parameter v 'tramp-remote-copy-args) + (setq listener (number-to-string (+ 50000 (random 10000)))) + (while + (zerop (tramp-call-process + v "nc" nil nil nil "-z" (tramp-file-name-host v) listener)) + (setq listener (number-to-string (+ 50000 (random 10000)))))) + + ;; Compose copy command. + (setq options + (format-spec + (tramp-ssh-controlmaster-options v) + (format-spec-make + ?t (tramp-get-connection-property + (tramp-get-connection-process v) "temp-file" ""))) + spec (list + ;; "%h" and "%u" do not happen in `tramp-copy-args' + ;; of `scp', so it is save to use `v'. + ?h (or (tramp-file-name-host v) "") + ?u (or (tramp-file-name-user v) + ;; There might be an interactive setting. + (tramp-get-connection-property v "login-as" nil) + "") + ;; For direct remote copying, the port must be the + ;; same for source and target. + ?p (or (tramp-file-name-port v) "") + ?r listener ?c options ?k (if keep-date " " "") + ?n (concat "2>" (tramp-get-remote-null-device v)) + ?x (tramp-scp-strict-file-name-checking v) + ?y (tramp-scp-direct-remote-copying v1 v2)) + copy-program (tramp-get-method-parameter v 'tramp-copy-program) + copy-keep-date (tramp-get-method-parameter + v 'tramp-copy-keep-date) + copy-args + ;; " " has either been a replacement of "%k" (when + ;; keep-date argument is non-nil), or a replacement for + ;; the whole keep-date sublist. + (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) + ;; `tramp-ssh-controlmaster-options' is a string instead + ;; of a list. Unflatten it. + copy-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) (if (tramp-compat-string-search " " x) + (split-string x) x)) + copy-args)) + copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) + remote-copy-program + (tramp-get-method-parameter v 'tramp-remote-copy-program) + remote-copy-args + (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) + + ;; Check for local copy program. + (unless (executable-find copy-program) + (tramp-error + v 'file-error "Cannot find local copy program: %s" copy-program)) + + ;; Install listener on the remote side. The prompt must be + ;; consumed later on, when the process does not listen anymore. + (when remote-copy-program + (unless (with-tramp-connection-property + v (concat "remote-copy-program-" remote-copy-program) + (tramp-find-executable + v remote-copy-program (tramp-get-remote-path v))) + (tramp-error + v 'file-error + "Cannot find remote listener: %s" remote-copy-program)) + (setq remote-copy-program + (mapconcat + #'identity + (append + (list remote-copy-program) remote-copy-args + (list (if v1 (concat "<" source) (concat ">" target)) "&")) + " ")) + (tramp-send-command v remote-copy-program) + (with-timeout + (60 (tramp-error + v 'file-error + "Listener process not running on remote host: `%s'" + remote-copy-program)) + (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) + (while (not (tramp-send-command-and-check v nil)) + (tramp-send-command + v (format "netstat -l | grep -q :%s" listener))))) + + (with-temp-buffer + (unwind-protect + ;; The default directory must be remote. + (let ((default-directory + (file-name-directory (if v1 filename newname))) + (process-environment (copy-sequence process-environment))) + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + (when copy-env + (tramp-message + v 6 "%s=\"%s\"" + (car copy-env) (string-join (cdr copy-env) " ")) + (setenv (car copy-env) (string-join (cdr copy-env) " "))) + (setq + copy-args + (append + copy-args + (if remote-copy-program + (list (if v1 (concat ">" target) (concat "<" source))) + (list source target))) + ;; Use an asynchronous process. By this, password can + ;; be handled. We don't set a timeout, because the + ;; copying of large files can last longer than 60 secs. + p (let ((default-directory + tramp-compat-temporary-file-directory)) + (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program copy-args))) + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + + ;; We must adapt `tramp-local-end-of-line' for sending + ;; the password. Also, we indicate that perhaps several + ;; password prompts might appear. + (let ((tramp-local-end-of-line tramp-rsh-end-of-line) + (tramp-password-prompt-not-unique (and v1 v2))) + (tramp-process-actions + p v nil tramp-actions-copy-out-of-band))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Clear the remote prompt. + (when (and remote-copy-program + (not (tramp-send-command-and-check v nil))) + ;; Houston, we have a problem! Likely, the listener is + ;; still running, so let's clear everything (but the + ;; cached password). + (tramp-cleanup-connection v 'keep-debug 'keep-password)))) + + ;; Handle KEEP-DATE argument. + (when (and keep-date (not copy-keep-date)) + (tramp-compat-set-file-times + newname + (file-attribute-modification-time (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) + + ;; Set the mode. + (unless (and keep-date copy-keep-date) + (ignore-errors + (set-file-modes newname (tramp-default-file-modes filename))))) - ;; We must adapt `tramp-local-end-of-line' for - ;; sending the password. - (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) - (tramp-process-actions - p v nil tramp-actions-copy-out-of-band))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Clear the remote prompt. - (when (and remote-copy-program - (not (tramp-send-command-and-check v nil))) - ;; Houston, we have a problem! Likely, the listener is - ;; still running, so let's clear everything (but the - ;; cached password). - (tramp-cleanup-connection v 'keep-debug 'keep-password)))) - - ;; Handle KEEP-DATE argument. - (when (and keep-date (not copy-keep-date)) - (tramp-compat-set-file-times - newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) - (unless ok-if-already-exists 'nofollow))) - - ;; Set the mode. - (unless (and keep-date copy-keep-date) - (ignore-errors - (set-file-modes newname (tramp-default-file-modes filename))))) - - ;; If the operation was `rename', delete the original file. - (unless (eq op 'copy) - (if (file-regular-p filename) - (delete-file filename) - (delete-directory filename 'recursive)))))) + ;; If the operation was `rename', delete the original file. + (unless (eq op 'copy) + (if (file-regular-p filename) + (delete-file filename) + (delete-directory filename 'recursive))))) (defun tramp-sh-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -2476,42 +2512,58 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-dired-compress-file (file) "Like `dired-compress-file' for Tramp files." - ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil - (tramp-flush-file-properties v localname) - (let ((suffixes dired-compress-file-suffixes) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match-p (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-tramp-progress-reporter - v 0 (format "Uncompressing %s" file) - (when (tramp-send-command-and-check - v (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-tramp-progress-reporter v 0 (format "Compressing %s" file) - (when (tramp-send-command-and-check - v (concat "gzip -f " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil))))))))) + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. + (if (>= emacs-major-version 29) + (tramp-run-real-handler #'dired-compress-file (list file)) + ;; Code stolen mainly from dired-aux.el. + (with-parsed-tramp-file-name file nil + (tramp-flush-file-properties v localname) + (let ((suffixes dired-compress-file-suffixes) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match-p (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-tramp-progress-reporter + v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (if (string-match-p "%[io]" (nth 2 suffix)) + (replace-regexp-in-string + "%i" (tramp-shell-quote-argument localname) + (nth 2 suffix)) + (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname)))) + (unless (string-match-p "\\.tar\\.gz" file) + (dired-remove-file file)) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so + ;; compress it. Try gzip. + (with-tramp-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (if (file-directory-p file) + (format "tar -cf - %s | gzip -c9 > %s.tar.gz" + (tramp-shell-quote-argument + (file-name-nondirectory localname)) + (tramp-shell-quote-argument localname)) + (concat "gzip -f " + (tramp-shell-quote-argument localname)))) + (unless (file-directory-p file) + (dired-remove-file file)) + (catch 'found nil + (dolist (target (mapcar (lambda (suffix) + (concat file suffix)) + '(".tar.gz" ".gz" ".z"))) + (when (file-exists-p target) + (throw 'found target)))))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -2583,7 +2635,7 @@ The method used must be an out-of-band method." ;; We cannot use `insert-buffer-substring' because the Tramp ;; buffer changes its contents before insertion due to calling ;; `expand-file-name' and alike. - (insert (with-current-buffer (tramp-get-buffer v) (buffer-string))) + (insert (tramp-get-buffer-string (tramp-get-buffer v))) ;; We must enable unibyte strings, because the "--dired" ;; output counts in bytes. @@ -2693,38 +2745,32 @@ the result will be a local, non-Tramp, file name." ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) - ;; If connection is not established yet, run the real handler. - (if (not (tramp-connectable-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + ;; If connection is not established yet, run the real handler. + (if (not (tramp-connectable-p v)) + (tramp-run-real-handler #'expand-file-name (list name nil)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "~/" localname))) ;; Tilde expansion if necessary. This needs a shell which ;; groks tilde expansion! The function `tramp-find-shell' is ;; supposed to find such a shell on the remote host. Please ;; tell me about it when this doesn't work on your system. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) + (fname (match-string 2 localname)) + hname) ;; We cannot simply apply "~/", because under sudo "~/" is ;; expanded to the local user home directory but to the ;; root home directory. On the other hand, using always ;; the default user name for tilde expansion is not ;; appropriate either, because ssh and companions might ;; use a user name from the config file. - (when (and (string-equal uname "~") + (when (and (zerop (length uname)) (string-match-p "\\`su\\(do\\)?\\'" method)) - (setq uname (concat uname user))) - (setq uname - (with-tramp-connection-property v uname - (tramp-send-command - v - (format "cd %s && pwd" (tramp-shell-quote-argument uname))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring (point) (point-at-eol))))) - (setq localname (concat uname fname)))) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) ;; There might be a double slash, for example when "~/" ;; expands to "/". Remove this. (while (string-match "//" localname) @@ -2732,15 +2778,17 @@ the result will be a local, non-Tramp, file name." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. ;; `default-directory' is bound, because on Windows there ;; would be problems with UNC shares or Cygwin mounts. (let ((default-directory tramp-compat-temporary-file-directory)) (tramp-make-tramp-file-name - v (tramp-drop-volume-letter - (tramp-run-real-handler - #'expand-file-name (list localname))))))))) + v (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname + (tramp-drop-volume-letter + (tramp-run-real-handler + #'expand-file-name (list localname)))))))))) ;;; Remote commands: @@ -2834,7 +2882,7 @@ implementation will be used." ;; `shell'. We discard hops, if existing, that's why ;; we cannot use `file-remote-p'. (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name v nil 'nohop) + (tramp-make-tramp-file-name v) tramp-initial-end-of-output)) ;; We use as environment the difference to toplevel ;; `process-environment'. @@ -2995,7 +3043,7 @@ implementation will be used." vec (concat "signal-strings-" (tramp-get-method-parameter vec 'tramp-remote-shell)) - (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + (let ((default-directory (tramp-make-tramp-file-name vec 'noloc)) process-file-return-signal-string signals res result) (setq signals (append @@ -3080,13 +3128,13 @@ implementation will be used." ;; Determine input. (if (null infile) (setq input (tramp-get-remote-null-device v)) - (setq infile (expand-file-name infile)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (tramp-file-local-name infile)) + (setq input (tramp-unquote-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)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -3114,11 +3162,11 @@ implementation will be used." (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 (tramp-file-local-name (cadr destination))) + (setq stderr (tramp-unquote-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) - tmpstderr (tramp-make-tramp-file-name v stderr 'nohop)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr (tramp-get-remote-null-device v))))) @@ -3135,15 +3183,15 @@ implementation will be used." (setq ret (tramp-send-command-and-check v (format "cd %s && %s" - (tramp-shell-quote-argument localname) command) + (tramp-unquote-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 (insert - (with-current-buffer (tramp-get-connection-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-connection-buffer v)))) (when (and display (get-buffer-window outbuf t)) (redisplay)))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. @@ -3167,8 +3215,7 @@ implementation will be used." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - - (unless process-file-side-effects + (when process-file-side-effects (tramp-flush-directory-properties v "")) ;; Return exit status. @@ -3187,9 +3234,9 @@ implementation will be used." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) - (let* ((size (tramp-compat-file-attribute-size + (let* ((size (file-attribute-size (file-attributes (file-truename filename)))) (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) (loc-dec (tramp-get-inline-coding v "local-decoding" size)) @@ -3276,11 +3323,9 @@ implementation will be used." (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (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)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -3359,8 +3404,7 @@ implementation will be used." ;; specified. However, if the method _also_ specifies an ;; encoding function, then that is used for encoding the ;; contents of the tmp file. - (let* ((size (tramp-compat-file-attribute-size - (file-attributes tmpfile))) + (let* ((size (file-attribute-size (file-attributes tmpfile))) (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) (loc-enc (tramp-get-inline-coding v "local-encoding" size))) (cond @@ -3460,8 +3504,7 @@ implementation will be used." (not (string-equal (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-buffer v)))) (tramp-error v 'file-error (concat "Couldn't write region to `%s'," @@ -3495,10 +3538,10 @@ implementation will be used." ;; We must pass modtime explicitly, because FILENAME can ;; be different from (buffer-file-name), f.e. if ;; `file-precious-flag' is set. - (or (tramp-compat-file-attribute-modification-time file-attr) + (or (file-attribute-modification-time file-attr) (current-time))) - (when (and (= (tramp-compat-file-attribute-user-id file-attr) uid) - (= (tramp-compat-file-attribute-group-id file-attr) gid)) + (when (and (= (file-attribute-user-id file-attr) uid) + (= (file-attribute-group-id file-attr) gid)) (setq need-chown nil)))) ;; Set the ownership. @@ -3637,8 +3680,7 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-sh-file-name-handler-p (vec) "Whether VEC uses a method from `tramp-sh-file-name-handler'." (and (assoc (tramp-file-name-method vec) tramp-methods) - (eq (tramp-find-foreign-file-name-handler - (tramp-make-tramp-file-name vec nil 'nohop)) + (eq (tramp-find-foreign-file-name-handler vec) 'tramp-sh-file-name-handler))) ;; This must be the last entry, because `identity' always matches. @@ -3755,8 +3797,7 @@ Fall back to normal file name handler if no Tramp handler exists." "Read output from \"gio monitor\" and add corresponding `file-notify' events." (let ((events (process-get proc 'events)) (remote-prefix - (with-current-buffer (process-buffer proc) - (file-remote-p default-directory))) + (file-remote-p (tramp-get-default-directory (process-buffer proc)))) (rest-string (process-get proc 'rest-string)) pos) (when rest-string @@ -4793,7 +4834,7 @@ Goes through the list `tramp-inline-compress-commands'." ((stringp tramp-scp-strict-file-name-checking) tramp-scp-strict-file-name-checking) - ;; Determine the options. + ;; Determine the option. (t (setq tramp-scp-strict-file-name-checking "") (let ((case-fold-search t)) (ignore-errors @@ -4809,6 +4850,78 @@ Goes through the list `tramp-inline-compress-commands'." (setq tramp-scp-strict-file-name-checking "-T"))))))) tramp-scp-strict-file-name-checking))) +(defun tramp-scp-direct-remote-copying (vec1 vec2) + "Return the direct remote copying argument of the local scp." + (cond + ((or (not tramp-use-scp-direct-remote-copying) (null vec1) (null vec2) + (not (tramp-get-process vec1)) + (not (equal (tramp-file-name-port vec1) (tramp-file-name-port vec2))) + (null (assoc "%y" (tramp-get-method-parameter vec1 'tramp-copy-args))) + (null (assoc "%y" (tramp-get-method-parameter vec2 'tramp-copy-args)))) + "") + + ((let ((case-fold-search t)) + (and + ;; Check, whether "scp" supports "-R" option. + (with-tramp-connection-property nil "scp-R" + (when (executable-find "scp") + (with-temp-buffer + (tramp-call-process vec1 "scp" nil t nil "-R") + (goto-char (point-min)) + (not (search-forward-regexp + "\\(illegal\\|unknown\\) option -- R" nil 'noerror))))) + + ;; Check, that RemoteCommand is not used. + (with-tramp-connection-property (tramp-get-process vec1) "remote-command" + (let ((command `("ssh" "-G" ,(tramp-file-name-host vec1)))) + (with-temp-buffer + (tramp-call-process + vec1 tramp-encoding-shell nil t nil + tramp-encoding-command-switch + (mapconcat #'identity command " ")) + (goto-char (point-min)) + (not (search-forward "remotecommand" nil 'noerror))))) + + ;; Check hostkeys. + (with-tramp-connection-property + (tramp-get-process vec1) + (concat "direct-remote-copying-" + (tramp-make-tramp-file-name vec2 'noloc)) + (let ((command + (append + `("ssh" "-G" ,(tramp-file-name-host vec2) "|" + "grep" "-i" "^hostname" "|" "cut" "-d\" \"" "-f2" "|" + "ssh-keyscan" "-f" "-") + (when (tramp-file-name-port vec2) + `("-p" ,(tramp-file-name-port vec2))))) + found string) + (with-temp-buffer + ;; Check hostkey of VEC2, seen from VEC1. + (tramp-send-command vec1 (mapconcat #'identity command " ")) + ;; Check hostkey of VEC2, seen locally. + (tramp-call-process + vec1 tramp-encoding-shell nil t nil tramp-encoding-command-switch + (mapconcat #'identity command " ")) + (goto-char (point-min)) + (while (and (not found) (not (eobp))) + (setq string + (buffer-substring + (line-beginning-position) (line-end-position)) + string + (and + (string-match "^[^# ]+ \\S-+ \\(\\S-+\\)$" string) + (match-string 1 string)) + found + (and string + (with-current-buffer (tramp-get-buffer vec1) + (goto-char (point-min)) + (search-forward string nil 'noerror)))) + (forward-line)) + found))))) + "-R") + + (t "-3"))) + (defun tramp-timeout-session (vec) "Close the connection VEC after a session timeout. If there is just some editing, retry it after 5 seconds." @@ -4902,8 +5015,7 @@ connection if a previous connection has died for some reason." (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) (let* ((current-host tramp-system-name) (target-alist (tramp-compute-multi-hops vec)) - ;; Needed for `tramp-get-remote-null-device'. - (previous-hop nil) + (previous-hop tramp-null-hop) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -4988,9 +5100,14 @@ connection if a previous connection has died for some reason." ;; Set password prompt vector. (tramp-set-connection-property p "password-vector" - (make-tramp-file-name - :method l-method :user l-user :domain l-domain - :host l-host :port l-port)) + (if (tramp-get-method-parameter + hop 'tramp-password-previous-hop) + (let ((pv (copy-tramp-file-name previous-hop))) + (setf (tramp-file-name-method pv) l-method) + pv) + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port))) ;; Set session timeout. (when (tramp-get-method-parameter @@ -5426,7 +5543,7 @@ Nonexistent directories are removed from spec." (lambda (x) (and (stringp x) - (file-directory-p (tramp-make-tramp-file-name vec x 'nohop)) + (file-directory-p (tramp-make-tramp-file-name vec x)) x)) remote-path)))))) @@ -5962,9 +6079,6 @@ function cell is returned to be applied on a buffer." ;; ;; * Use lsh instead of ssh. (Alfred M. Szmidt) ;; -;; * Optimize out-of-band copying when both methods are scp-like (not -;; rsync). -;; ;; * Keep a second connection open for out-of-band methods like scp or ;; rsync. ;; @@ -6008,5 +6122,8 @@ function cell is returned to be applied on a buffer." ;; be to stipulate, as a directory or connection-local variable, an ;; additional rc file on the remote machine that is sourced every ;; time Tramp connects. <https://emacs.stackexchange.com/questions/62306> +;; +;; * Support hostname canonicalization in ~/.ssh/config. +;; <https://stackoverflow.com/questions/70205232/> ;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 3960554605d..67c63e6ce7a 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -222,7 +222,8 @@ See `tramp-actions-before-shell' for more info.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) @@ -293,6 +294,7 @@ 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-home-directory . tramp-smb-handle-get-home-directory) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -330,11 +332,10 @@ This can be used to disable echo etc." ;; 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-smb-file-name-p (filename) - "Check if it's a FILENAME for SMB servers." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method))) +(defsubst tramp-smb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SMB servers." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -419,7 +420,7 @@ arguments to pass to the OPERATION." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -442,7 +443,7 @@ arguments to pass to the OPERATION." (with-tramp-progress-reporter v 0 (format "Copying %s to %s" dirname newname) (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) (when (and (file-directory-p newname) (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) @@ -567,8 +568,7 @@ arguments to pass to the OPERATION." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes dirname)) + (file-attribute-modification-time (file-attributes dirname)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -602,10 +602,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (copy-directory filename newname keep-date 'parents 'copy-contents) (unless (file-exists-p filename) - (tramp-compat-file-missing + (tramp-error (tramp-dissect-file-name (if (tramp-tramp-file-p filename) filename newname)) - filename)) + 'file-missing filename)) (if-let ((tmpfile (file-local-copy filename))) ;; Remote filename. @@ -645,8 +645,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive trash) @@ -706,7 +705,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (let ((result (mapcar #'directory-file-name (file-name-all-completions "" directory)))) ;; Discriminate with regexp. @@ -747,25 +746,30 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-run-real-handler #'expand-file-name (list name nil)) ;; Dissect NAME. (with-parsed-tramp-file-name name nil - ;; Tilde expansion if necessary. We use the user name as share, - ;; which is often the case in domains. - (when (string-match "\\`/?~\\([^/]*\\)" localname) - (setq localname - (replace-match - (if (zerop (length (match-string 1 localname))) - user - (match-string 1 localname)) - nil nil localname))) - ;; Make the file name absolute. + ;; Tilde expansion if necessary. + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) + ;; Tilde expansion is not possible. + (when (and (not tramp-tolerate-tilde) + (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) + (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (tramp-run-real-handler #'expand-file-name (list localname)))))) + v (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))) (defun tramp-smb-action-get-acl (proc vec) "Read ACL data from connection buffer." @@ -976,7 +980,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -1041,8 +1045,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) (tramp-compat-string-search - "w" - (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) + "w" (or (file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) (and (file-exists-p dir) (file-writable-p dir))))) @@ -1145,11 +1148,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (insert (format "%10s %3d %-8s %-8s %8s %s " - (or (tramp-compat-file-attribute-modes attr) (nth 1 x)) - (or (tramp-compat-file-attribute-link-number attr) 1) - (or (tramp-compat-file-attribute-user-id attr) "nobody") - (or (tramp-compat-file-attribute-group-id attr) "nogroup") - (or (tramp-compat-file-attribute-size attr) (nth 2 x)) + (or (file-attribute-modes attr) (nth 1 x)) + (or (file-attribute-link-number attr) 1) + (or (file-attribute-user-id attr) "nobody") + (or (file-attribute-group-id attr) "nogroup") + (or (file-attribute-size attr) (nth 2 x)) (format-time-string (if (time-less-p ;; Half a year. @@ -1171,8 +1174,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Insert symlink. (when (and (tramp-compat-string-search "l" switches) - (stringp (tramp-compat-file-attribute-type attr))) - (insert " -> " (tramp-compat-file-attribute-type attr)))) + (stringp (file-attribute-type attr))) + (insert " -> " (file-attribute-type attr)))) (insert "\n") (beginning-of-line))) @@ -1284,10 +1287,10 @@ component is used as the target of the symlink." ;; Determine input. (when infile - (setq infile (expand-file-name infile)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (tramp-file-local-name infile)) + (setq input (tramp-unquote-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)) @@ -1376,8 +1379,7 @@ component is used as the target of the symlink." (when tmpinput (delete-file tmpinput)) (unless outbuf (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) - - (unless process-file-side-effects + (when process-file-side-effects (tramp-flush-directory-properties v "")) ;; Return exit status. @@ -1394,7 +1396,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (if (tramp-tramp-file-p filename) filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -1439,9 +1441,9 @@ component is used as the target of the symlink." (unless (process-live-p proc) ;; Accept pending output. (while (tramp-accept-process-output proc)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 10 "\n%s" (buffer-string)) - (throw 'tramp-action 'ok)))) + (tramp-message + vec 10 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) + (throw 'tramp-action 'ok))) (defun tramp-smb-handle-set-file-acl (filename acl-string) "Like `set-file-acl' for Tramp files." @@ -1593,6 +1595,15 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-run-real-handler #'substitute-in-file-name (list filename)) (error filename)))) +(defun tramp-smb-handle-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (let ((user (or user (tramp-file-name-user vec)))) + (unless (zerop (length user)) + (concat "/" user)))) + (defun tramp-smb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." @@ -1647,8 +1658,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 7be26bd23df..2f9d8a0681b 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -51,11 +51,13 @@ (add-to-list 'tramp-methods `(,tramp-sshfs-method (tramp-mount-args (("-C") ("-p" "%p") + ("-o" "transform_symlinks") ("-o" "idmap=user,reconnect"))) ;; These are for remote processes. (tramp-login-program "ssh") - (tramp-login-args (("-q")("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h") ("%l"))) + (tramp-login-args (("-q") ("-l" "%u") ("-p" "%p") + ("-e" "none") ("-t" "-t") + ("%h") ("%l"))) (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) @@ -71,7 +73,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sshfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-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) @@ -106,9 +109,9 @@ (file-name-nondirectory . tramp-handle-file-name-nondirectory) ;; `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-notify-add-watch . tramp-handle-file-notify-add-watch) + (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) (file-readable-p . tramp-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) @@ -117,7 +120,7 @@ (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-sshfs-handle-file-system-info) (file-truename . tramp-handle-file-truename) - (file-writable-p . tramp-handle-file-writable-p) + (file-writable-p . tramp-sshfs-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) @@ -136,12 +139,13 @@ (set-file-acl . ignore) (set-file-modes . tramp-sshfs-handle-set-file-modes) (set-file-selinux-context . ignore) - (set-file-times . ignore) + (set-file-times . tramp-sshfs-handle-set-file-times) (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) (shell-command . tramp-handle-shell-command) (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-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -156,11 +160,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; 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-sshfs-file-name-p (filename) - "Check if it's a FILENAME for sshfs." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sshfs-method))) +(defsubst tramp-sshfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for sshfs." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sshfs-method))) ;;;###tramp-autoload (defun tramp-sshfs-file-name-handler (operation &rest args) @@ -219,6 +222,10 @@ arguments to pass to the OPERATION." ;;`file-system-info' exists since Emacs 27.1. (tramp-compat-funcall 'file-system-info (tramp-fuse-local-file-name filename))) +(defun tramp-sshfs-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (file-writable-p (tramp-fuse-local-file-name filename))) + (defun tramp-sshfs-handle-insert-file-contents (filename &optional visit beg end replace) "Like `insert-file-contents' for Tramp files." @@ -239,16 +246,69 @@ arguments to pass to the OPERATION." (error "Implementation does not handle immediate return")) (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((command + (let ((coding-system-for-read 'utf-8-dos) ; Is this correct? + (command (format "cd %s && exec %s" - localname - (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))) + (tramp-unquote-shell-quote-argument localname) + (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) + input tmpinput stderr tmpstderr outbuf) + + ;; Determine input. + (if (null infile) + (setq input (tramp-get-remote-null-device v)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) + (if (tramp-equal-remote default-directory infile) + ;; INFILE is on the same remote host. + (setq input (tramp-unquote-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)) + (copy-file infile tmpinput t))) + (when input (setq command (format "%s <%s" command input))) + + ;; Determine output. + (cond + ;; Just a buffer. + ((bufferp destination) + (setq outbuf destination)) + ;; A buffer name. + ((stringp destination) + (setq outbuf (get-buffer-create destination))) + ;; (REAL-DESTINATION ERROR-DESTINATION) + ((consp destination) + ;; output. + (cond + ((bufferp (car destination)) + (setq outbuf (car destination))) + ((stringp (car destination)) + (setq outbuf (get-buffer-create (car destination)))) + ((car destination) + (setq outbuf (current-buffer)))) + ;; stderr. + (cond + ((stringp (cadr destination)) + (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 (tramp-unquote-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) + tmpstderr (tramp-make-tramp-file-name v stderr)))) + ;; stderr to be discarded. + ((null (cadr destination)) + (setq stderr (tramp-get-remote-null-device v))))) + ;; 't + (destination + (setq outbuf (current-buffer)))) + (when stderr (setq command (format "%s 2>%s" command stderr))) + (unwind-protect (apply #'tramp-call-process v (tramp-get-method-parameter v 'tramp-login-program) - infile destination display + nil outbuf display (tramp-expand-args v 'tramp-login-args ?h (or (tramp-file-name-host v) "") @@ -256,7 +316,20 @@ arguments to pass to the OPERATION." ?p (or (tramp-file-name-port v) "") ?l command)) - (unless process-file-side-effects + ;; Synchronize stderr. + (when tmpstderr + (tramp-cleanup-connection v 'keep-debug 'keep-password) + (tramp-fuse-unmount v)) + + ;; Provide error file. + (when tmpstderr + (rename-file tmpstderr (cadr destination) t)) + + ;; Cleanup. We remove all file cache values for the + ;; connection, because the remote process could have changed + ;; them. + (when tmpinput (delete-file tmpinput)) + (when process-file-side-effects (tramp-flush-directory-properties v "")))))) (defun tramp-sshfs-handle-rename-file @@ -285,6 +358,15 @@ arguments to pass to the OPERATION." (tramp-compat-set-file-modes (tramp-fuse-local-file-name filename) mode flag)))) +(defun tramp-sshfs-handle-set-file-times (filename &optional timestamp flag) + "Like `set-file-times' for Tramp files." + (or (file-exists-p filename) (write-region "" nil filename nil 0)) + (with-parsed-tramp-file-name filename nil + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (tramp-compat-set-file-times + (tramp-fuse-local-file-name filename) timestamp flag)))) + (defun tramp-sshfs-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." @@ -313,6 +395,12 @@ arguments to pass to the OPERATION." start end (tramp-fuse-local-file-name filename) append 'nomessage) (tramp-flush-file-properties v localname)) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (or (file-attribute-modification-time (file-attributes filename)) + (current-time)))) + ;; Unlock file. (when file-locked ;; `unlock-file' exists since Emacs 28.1. @@ -345,9 +433,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) @@ -386,6 +471,24 @@ connection if a previous connection has died for some reason." (with-tramp-connection-property vec "gid-string" (tramp-get-local-gid 'string))) +;; `shell-mode' tries to open remote files like "/sshfs:user@host:~/.history". +;; This fails, because the tilde cannot be expanded. Tell +;; `tramp-handle-expand-file-name' to tolerate this. +(defun tramp-sshfs-tolerate-tilde (orig-fun) + "Advice for `shell-mode' to tolerate tilde in remote file names." + (let ((tramp-tolerate-tilde + (or tramp-tolerate-tilde + (equal (file-remote-p default-directory 'method) + tramp-sshfs-method)))) + (funcall orig-fun))) + +(add-function + :around (symbol-function #'shell-mode) #'tramp-sshfs-tolerate-tilde) +(add-hook 'tramp-sshfs-unload-hook + (lambda () + (remove-function + (symbol-function #'shell-mode) #'tramp-sshfs-tolerate-tilde))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-sshfs 'force))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index c4222b28a20..242a6c7f587 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -45,7 +45,8 @@ (add-to-list 'tramp-methods `(,tramp-sudoedit-method (tramp-sudo-login (("sudo") ("-u" "%u") ("-S") ("-H") - ("-p" "Password:") ("--"))))) + ("-p" "Password:") ("--"))) + (tramp-password-previous-hop t))) (add-to-list 'tramp-default-user-alist '("\\`sudoedit\\'" nil "root")) @@ -63,7 +64,8 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defconst tramp-sudoedit-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) (byte-compiler-base-file-name . ignore) (copy-directory . tramp-handle-copy-directory) @@ -99,9 +101,9 @@ See `tramp-actions-before-shell' for more info.") (file-name-nondirectory . tramp-handle-file-name-nondirectory) ;; `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-notify-add-watch . tramp-handle-file-notify-add-watch) + (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) (file-readable-p . tramp-sudoedit-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) @@ -135,6 +137,7 @@ 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-home-directory . tramp-sudoedit-handle-get-home-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) @@ -148,11 +151,10 @@ See `tramp-actions-before-shell' for more info.") ;; 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-sudoedit-file-name-p (filename) - "Check if it's a FILENAME for SUDOEDIT." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sudoedit-method))) +(defsubst tramp-sudoedit-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SUDOEDIT." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sudoedit-method))) ;;;###tramp-autoload (defun tramp-sudoedit-file-name-handler (operation &rest args) @@ -168,6 +170,12 @@ arguments to pass to the OPERATION." (tramp-register-foreign-file-name-handler #'tramp-sudoedit-file-name-p #'tramp-sudoedit-file-name-handler)) +;; Needed for `tramp-read-passwd'. +(defconst tramp-sudoedit-null-hop + (make-tramp-file-name + :method tramp-sudoedit-method :user (user-login-name) :host tramp-system-name) +"Connection hop which identifies the virtual hop before the first one.") + ;; File name primitives. @@ -233,7 +241,7 @@ absolute file names." (let ((t1 (tramp-sudoedit-file-name-p filename)) (t2 (tramp-sudoedit-file-name-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename)) (attributes (and preserve-extended-attributes @@ -247,7 +255,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -336,7 +344,7 @@ absolute file names." (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) (unless (tramp-sudoedit-send-command - v "rm" (tramp-compat-file-name-unquote localname)) + v "rm" "-f" (tramp-compat-file-name-unquote localname)) ;; Propagate the error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -362,17 +370,23 @@ the result will be a local, non-Tramp, file name." (setq localname "~")) (unless (file-name-absolute-p localname) (setq localname (format "~%s/%s" user localname))) - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - (when (string-equal uname "~") - (setq uname (concat uname user))) - (setq localname (concat uname fname)))) - ;; Do not keep "/..". - (when (string-match-p "^/\\.\\.?$" localname) - (setq localname "/")) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) ;; Do normal `expand-file-name' (this does "~user/", "/./" and "/../"). - (tramp-make-tramp-file-name v (expand-file-name localname)))) + (tramp-make-tramp-file-name + v (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname + (tramp-run-real-handler + #'expand-file-name (list localname)))))) (defun tramp-sudoedit-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." @@ -453,12 +467,13 @@ the result will be a local, non-Tramp, file name." (if (file-directory-p (expand-file-name f directory)) (file-name-as-directory f) f)) - (with-current-buffer (tramp-get-connection-buffer v) - (delq - nil - (mapcar - (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n" 'omit))))))))) + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string + (tramp-get-buffer-string (tramp-get-connection-buffer v)) + "\n" 'omit)))))))) (defun tramp-sudoedit-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -534,7 +549,7 @@ the result will be a local, non-Tramp, file name." (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) + nil time))) (tramp-sudoedit-send-command v "env" "TZ=UTC" "touch" "-t" @@ -571,8 +586,7 @@ the result will be a local, non-Tramp, file name." (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)) - 'nohop))))) + result))))))) (defun tramp-sudoedit-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -692,6 +706,13 @@ component is used as the target of the symlink." (tramp-flush-file-property v localname "file-selinux-context")) t))))) +(defun tramp-sudoedit-handle-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (expand-file-name (concat "~" (or user (tramp-file-name-user vec))))) + (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'." @@ -721,11 +742,9 @@ ID-FORMAT valid values are `string' and `integer'." "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (let* ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (let* ((uid (or (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)) + (gid (or (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)) @@ -736,10 +755,10 @@ ID-FORMAT valid values are `string' and `integer'." ;; Set the ownership, modes and extended attributes. This is ;; not performed in `tramp-handle-write-region'. - (unless (and (= (tramp-compat-file-attribute-user-id + (unless (and (= (file-attribute-user-id (file-attributes filename 'integer)) uid) - (= (tramp-compat-file-attribute-group-id + (= (file-attribute-group-id (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) @@ -789,9 +808,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) @@ -830,6 +846,7 @@ in case of error, t otherwise." (process-put p 'vector vec) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) + (tramp-set-connection-property p "password-vector" tramp-sudoedit-null-hop) (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions) (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string)) (prog1 diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index ee6e0e6c088..49778cbfeee 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -185,7 +185,7 @@ See the variable `tramp-encoding-shell' for more information." ;; Since Emacs 26.1, `system-name' can return nil at build time if ;; Emacs is compiled with "--no-build-details". We do expect it to be -;; a string. (Bug#44481) +;; a string. (Bug#44481, Bug#54294) (defconst tramp-system-name (or (system-name) "") "The system name Tramp is running locally.") @@ -255,6 +255,8 @@ pair of the form (KEY VALUE). The following KEYs are defined: - \"%n\" expands to \"2>/dev/null\". - \"%x\" is replaced by the `tramp-scp-strict-file-name-checking' argument if it is supported. + - \"%y\" is replaced by the `tramp-scp-direct-remote-copying' + argument if it is supported. The existence of `tramp-login-args', combined with the absence of `tramp-copy-args', is an indication that the @@ -313,14 +315,20 @@ pair of the form (KEY VALUE). The following KEYs are defined: * `tramp-connection-timeout' This is the maximum time to be spent for establishing a connection. In general, the global default value shall be used, but for - some methods, like \"su\" or \"sudo\", a shorter timeout - might be desirable. + some methods, like \"doas\", \"su\" or \"sudo\", a shorter + timeout might be desirable. * `tramp-session-timeout' How long a Tramp connection keeps open before being disconnected. - This is useful for methods like \"su\" or \"sudo\", which + This is useful for methods like \"doas\" or \"sudo\", which shouldn't run an open connection in the background forever. + * `tramp-password-previous-hop' + The password for this connection is the same like the + password for the previous hop. If there is no previous hop, + the password of the local user is applied. This is needed + for methods like \"doas\", \"sudo\" or \"sudoedit\". + * `tramp-case-insensitive' Whether the remote file system handles file names case insensitive. Only a non-nil value counts, the default value nil means to @@ -751,11 +759,11 @@ The answer will be provided by `tramp-action-process-alive', (defconst tramp-temp-name-prefix "tramp." "Prefix to use for temporary files. -If this is a relative file name (such as \"tramp.\"), it is considered -relative to the directory name returned by the function -`tramp-compat-temporary-file-directory' (which see). It may also be an -absolute file name; don't forget to include a prefix for the filename -part, though.") +If this is a relative file name (such as \"tramp.\"), it is +considered relative to the directory name returned by the +function `temporary-file-directory' (which see). It may also be +an absolute file name; don't forget to include a prefix for the +filename part, though.") (defconst tramp-temp-buffer-name " *tramp temp*" "Buffer name for a temporary buffer. @@ -822,11 +830,10 @@ to be set, depending on VALUE." (tramp-register-file-name-handlers)) ;; Initialize the Tramp syntax variables. We want to override initial -;; value of `tramp-file-name-regexp'. Other Tramp syntax variables -;; must be initialized as well to proper values. We do not call +;; value of `tramp-file-name-regexp'. We do not call ;; `custom-set-variable', this would load Tramp via custom.el. (tramp--with-startup - (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) + (tramp-set-syntax 'tramp-syntax tramp-syntax)) (defun tramp-syntax-values () "Return possible values of `tramp-syntax', a list." @@ -836,9 +843,9 @@ to be set, depending on VALUE." values)) (defun tramp-lookup-syntax (alist) - "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax'. -Raise an error if `tramp-syntax' is invalid." - (or (cdr (assq (tramp-compat-tramp-syntax) alist)) + "Look up a syntax string in ALIST according to `tramp-syntax'. +Raise an error if it is invalid." + (or (cdr (assq tramp-syntax alist)) (error "Wrong `tramp-syntax' %s" tramp-syntax))) (defconst tramp-prefix-format-alist @@ -1388,6 +1395,11 @@ Will be called once the password has been verified by successful authentication.") (put 'tramp-password-save-function 'tramp-suppress-trace t) +(defvar tramp-password-prompt-not-unique nil + "Whether several passwords might be requested. +This shouldn't be set explicitly. It is let-bound, for example +during direct remote copying with scp.") + (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) @@ -1409,8 +1421,7 @@ calling HANDLER.") ;; internal data structure. Convenience functions for internal ;; data structure. -;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for remote file names. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1422,6 +1433,11 @@ calling HANDLER.") (put #'tramp-file-name-localname 'tramp-suppress-trace t) (put #'tramp-file-name-hop 'tramp-suppress-trace t) +;; Needed for `tramp-read-passwd' and `tramp-get-remote-null-device'. +(defconst tramp-null-hop + (make-tramp-file-name :user (user-login-name) :host tramp-system-name) +"Connection hop which identifies the virtual hop before the first one.") + (defun tramp-file-name-user-domain (vec) "Return user and domain components of VEC." (when (or (tramp-file-name-user vec) (tramp-file-name-domain vec)) @@ -1522,7 +1538,7 @@ of `process-file', `start-file-process', or `shell-command'." (or (and (tramp-tramp-file-p name) (string-match (nth 0 tramp-file-name-structure) name) (match-string (nth 4 tramp-file-name-structure) name)) - (tramp-compat-file-local-name name))) + (file-local-name name))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-unquote-file-local-name (name) @@ -1669,6 +1685,18 @@ default values are used." (put #'tramp-dissect-file-name 'tramp-suppress-trace t) +(defun tramp-ensure-dissected-file-name (vec-or-filename) + "Return a `tramp-file-name' structure for VEC-OR-FILENAME. + +VEC-OR-FILENAME may be either a string or a `tramp-file-name'. +If it's not a Tramp filename, return nil." + (cond + ((tramp-file-name-p vec-or-filename) vec-or-filename) + ((tramp-tramp-file-p vec-or-filename) + (tramp-dissect-file-name vec-or-filename)))) + +(put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t) + (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." @@ -1703,13 +1731,10 @@ See `tramp-dissect-file-name' for details." "Construct a Tramp file name from ARGS. ARGS could have two different signatures. The first one is of -type (VEC &optional LOCALNAME HOP). +type (VEC &optional LOCALNAME). If LOCALNAME is nil, the value in VEC is used. If it is a symbol, a null localname will be used. Otherwise, LOCALNAME is expected to be a string, which will be used. -If HOP is nil, the value in VEC is used. If it is a symbol, a -null hop will be used. Otherwise, HOP is expected to be a -string, which will be used. The other signature exists for backward compatibility. It has the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." @@ -1725,8 +1750,13 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." hop (tramp-file-name-hop (car args))) (when (cadr args) (setq localname (and (stringp (cadr args)) (cadr args)))) - (when (cl-caddr args) - (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + (when hop + (setq hop nil) + ;; Assure that the hops are in `tramp-default-proxies-alist'. + ;; In tramp-archive.el, the slot `hop' is used for the archive + ;; file name. + (unless (string-equal method "archive") + (tramp-add-hops (car args))))) (t (setq method (nth 0 args) user (nth 1 args) @@ -1759,15 +1789,17 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." localname))) (set-advertised-calling-convention - #'tramp-make-tramp-file-name '(vec &optional localname hop) "27.1") + #'tramp-make-tramp-file-name '(vec &optional localname) "29.1") (defun tramp-make-tramp-hop-name (vec) "Construct a Tramp hop name from VEC." - (replace-regexp-in-string - tramp-prefix-regexp "" + (concat + (tramp-file-name-hop vec) (replace-regexp-in-string - (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format - (tramp-make-tramp-file-name vec 'noloc)))) + tramp-prefix-regexp "" + (replace-regexp-in-string + (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format + (tramp-make-tramp-file-name vec 'noloc))))) (defun tramp-completion-make-tramp-file-name (method user host localname) "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. @@ -1801,7 +1833,7 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." (tramp-get-connection-property vec "process-buffer" nil)) (setq buffer-undo-list t default-directory - (tramp-make-tramp-file-name vec 'noloc 'nohop)) + (tramp-make-tramp-file-name vec 'noloc)) (current-buffer))))) (defun tramp-get-connection-buffer (vec &optional dont-create) @@ -1839,9 +1871,7 @@ from the default one." If connection-local variables are not supported by this Emacs version, the function does nothing." (with-current-buffer (tramp-get-connection-buffer vec) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(tramp-file-name-method vec) :user ,(tramp-file-name-user-domain vec) @@ -1852,14 +1882,27 @@ version, the function does nothing." If connection-local variables are not supported by this Emacs version, the function does nothing." (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 + (hack-connection-local-variables-apply `(:application tramp :protocol ,(file-remote-p default-directory 'method) :user ,(file-remote-p default-directory 'user) :machine ,(file-remote-p default-directory 'host))))) +(defsubst tramp-get-default-directory (buffer) + "Return `default-directory' of BUFFER." + (buffer-local-value 'default-directory buffer)) + +(put #'tramp-get-default-directory 'tramp-suppress-trace t) + +(defsubst tramp-get-buffer-string (&optional buffer) + "Return contents of BUFFER. +If BUFFER is not a buffer or a buffer name, return the contents +of `current-buffer'." + (with-current-buffer (or buffer (current-buffer)) + (substring-no-properties (buffer-string)))) + +(put #'tramp-get-buffer-string 'tramp-suppress-trace t) + (defun tramp-debug-buffer-name (vec) "A name for the debug buffer for VEC." (let ((method (tramp-file-name-method vec)) @@ -1898,29 +1941,55 @@ The outline level is equal to the verbosity of the Tramp message." (put #'tramp-debug-outline-level 'tramp-suppress-trace t) +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-debug-buffer-command-completion-p (_symbol buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only in Tramp debug buffers." + (with-current-buffer buffer + (string-equal (buffer-substring 1 (min 10 (point-max))) ";; Emacs:"))) + +(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) + +(defun tramp-setup-debug-buffer () + "Function to setup debug buffers." + ;; (declare (completion tramp-debug-buffer-command-completion-p)) + (interactive) + (set-buffer-file-coding-system 'utf-8) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes die. + ;; Yes: I've seen `flyspell-mode', which starts "ispell". + ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises + ;; on error in `(outline-mode)', we don't want to see it in the + ;; traces. + (let ((default-directory tramp-compat-temporary-file-directory)) + (outline-mode)) + (setq-local outline-level 'tramp-debug-outline-level) + (setq-local font-lock-keywords + ;; FIXME: This `(t FOO . BAR)' representation in + ;; `font-lock-keywords' is supposed to be an internal + ;; implementation "detail". Don't abuse it here! + `(t (eval ,tramp-debug-font-lock-keywords t) + ,(eval tramp-debug-font-lock-keywords t))) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map) + ;; For debugging purposes. + (local-set-key "\M-n" 'clone-buffer) + (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) + +(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) + +(function-put + #'tramp-setup-debug-buffer 'completion-predicate + #'tramp-debug-buffer-command-completion-p) + (defun tramp-get-debug-buffer (vec) "Get the debug buffer for VEC." (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) - (set-buffer-file-coding-system 'utf-8) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes - ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". - ;; `(custom-declare-variable outline-minor-mode-prefix ...)' - ;; raises on error in `(outline-mode)', we don't want to see it - ;; in the traces. - (let ((default-directory tramp-compat-temporary-file-directory)) - (outline-mode)) - (setq-local outline-level 'tramp-debug-outline-level) - (setq-local font-lock-keywords - ;; FIXME: This `(t FOO . BAR)' representation in - ;; `font-lock-keywords' is supposed to be an - ;; internal implementation "detail". Don't abuse it here! - `(t (eval ,tramp-debug-font-lock-keywords t) - ,(eval tramp-debug-font-lock-keywords t))) - ;; Do not edit the debug buffer. - (use-local-map special-mode-map)) + (tramp-setup-debug-buffer)) (current-buffer))) (put #'tramp-get-debug-buffer 'tramp-suppress-trace t) @@ -1982,9 +2051,7 @@ ARGUMENTS to actually emit the message (if applicable)." (unless (bolp) (insert "\n")) ;; Timestamp. - (let ((now (current-time))) - (insert (format-time-string "%T." now)) - (insert (format "%06d " (nth 2 now)))) + (insert (format-time-string "%T.%6N ")) ;; Calling Tramp function. We suppress compat and trace ;; functions from being displayed. (let ((btn 1) btf fn) @@ -2054,12 +2121,15 @@ applicable)." ;; Append connection buffer for error messages, if exists. (when (= level 1) (ignore-errors - (with-current-buffer - (if (processp vec-or-proc) - (process-buffer vec-or-proc) - (tramp-get-connection-buffer vec-or-proc 'dont-create)) - (setq fmt-string (concat fmt-string "\n%s") - arguments (append arguments (list (buffer-string))))))) + (setq fmt-string (concat fmt-string "\n%s") + arguments + (append + arguments + `(,(tramp-get-buffer-string + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer + vec-or-proc 'dont-create)))))))) ;; Translate proc to vec. (when (processp vec-or-proc) (setq vec-or-proc (process-get vec-or-proc 'vector)))) @@ -2121,8 +2191,8 @@ an input event arrives. The other arguments are passed to `tramp-error'." (and (tramp-file-name-p vec-or-proc) (tramp-get-connection-buffer vec-or-proc)))) (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc) - (and buf (with-current-buffer buf - (tramp-dissect-file-name default-directory)))))) + (and buf (tramp-dissect-file-name + (tramp-get-default-directory buf)))))) (unwind-protect (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. @@ -2186,10 +2256,14 @@ the resulting error message." (defun tramp-test-message (fmt-string &rest arguments) "Emit a Tramp message according `default-directory'." - (if (tramp-tramp-file-p default-directory) - (apply #'tramp-message - (tramp-dissect-file-name default-directory) 0 fmt-string arguments) - (apply #'message fmt-string arguments))) + (cond + ((tramp-tramp-file-p default-directory) + (apply #'tramp-message + (tramp-dissect-file-name default-directory) 0 fmt-string arguments)) + ((tramp-file-name-p (car tramp-current-connection)) + (apply #'tramp-message + (car tramp-current-connection) 0 fmt-string arguments)) + (t (apply #'message fmt-string arguments)))) (put #'tramp-test-message 'tramp-suppress-trace t) @@ -2239,8 +2313,6 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (ignore ,@(mapcar #'car bindings)) ,@body))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) - (defun tramp-progress-reporter-update (reporter &optional value suffix) "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) @@ -2277,9 +2349,6 @@ without a visible progress reporter." (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) -(font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-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." @@ -2296,8 +2365,6 @@ FILE must be a local file name on a connection identified via VEC." value) ,@body)) -(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)) @@ -2311,9 +2378,6 @@ FILE must be a local file name on a connection identified via VEC." (tramp-set-connection-property ,key ,property value)) value)) -(font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) - (defun tramp-drop-volume-letter (name) "Cut off unnecessary drive letter from file NAME. The functions `tramp-*-handle-expand-file-name' call `expand-file-name' @@ -2476,19 +2540,17 @@ Must be handled by the callers." file-accessible-directory-p file-attributes file-directory-p file-executable-p file-exists-p file-local-copy file-modes file-name-as-directory - file-name-directory file-name-nondirectory - file-name-sans-versions file-notify-add-watch - file-ownership-preserved-p file-readable-p - file-regular-p file-remote-p file-selinux-context - file-symlink-p file-truename file-writable-p - find-backup-file-name get-file-buffer + file-name-case-insensitive-p file-name-directory + file-name-nondirectory file-name-sans-versions + file-notify-add-watch file-ownership-preserved-p + file-readable-p file-regular-p file-remote-p + file-selinux-context file-symlink-p file-truename + file-writable-p find-backup-file-name get-file-buffer insert-directory insert-file-contents load make-directory make-directory-internal set-file-acl set-file-modes set-file-selinux-context set-file-times substitute-in-file-name unhandled-file-name-directory vc-registered - ;; Emacs 26+ only. - file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. @@ -2501,8 +2563,6 @@ Must be handled by the callers." (nth 0 args) default-directory)) ;; STRING FILE. - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. ((eq operation 'make-symbolic-link) (nth 1 args)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation @@ -2533,32 +2593,41 @@ Must be handled by the callers." (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) ;; COMMAND. ((member operation - '(process-file shell-command start-file-process - ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory + '(make-nearby-temp-file process-file shell-command + start-file-process temporary-file-directory ;; Emacs 27+ only. exec-path make-process)) default-directory) ;; PROC. ((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))) + (tramp-get-default-directory (process-buffer (nth 0 args))))) ;; VEC. - ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) + ((member operation + '(tramp-get-home-directory + 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)))) -(defun tramp-find-foreign-file-name-handler (filename &optional _operation) +(defun tramp-find-foreign-file-name-handler (vec &optional _operation) "Return foreign file name handler if exists." - (when (tramp-tramp-file-p filename) + (when (tramp-file-name-p vec) (let ((handler tramp-foreign-file-name-handler-alist) - elt res) + elt func res) (while handler (setq elt (car handler) handler (cdr handler)) - (when (funcall (car elt) filename) + ;; Previously, this function was called with FILENAME, but now + ;; it's called with the VEC. + (when (condition-case nil + (funcall (setq func (car elt)) vec) + (error + (setcar elt #'ignore) + (unless (member 'remote-file-error debug-ignored-errors) + (tramp-error + vec 'remote-file-error + "Not a valid Tramp file name function `%s'" func)))) (setq handler nil res (cdr elt)))) res))) @@ -2577,7 +2646,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (with-parsed-tramp-file-name filename nil (let ((current-connection tramp-current-connection) (foreign - (tramp-find-foreign-file-name-handler filename operation)) + (tramp-find-foreign-file-name-handler v operation)) (signal-hook-function #'tramp-signal-hook-function) result) ;; Set `tramp-current-connection'. @@ -2676,6 +2745,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (load "tramp" 'noerror 'nomessage))) (apply operation args))) +(put #'tramp-autoload-file-name-handler 'tramp-autoload t) + ;; `tramp-autoload-file-name-handler' must be registered before ;; evaluation of site-start and init files, because there might exist ;; remote files already, f.e. files kept via recentf-mode. @@ -2687,6 +2758,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t))) +(put #'tramp-register-autoload-file-name-handlers 'tramp-autoload t) ;;;###autoload (tramp-register-autoload-file-name-handlers) (defun tramp-use-absolute-autoload-file-names () @@ -2757,8 +2829,9 @@ remote file names." (defun tramp-register-foreign-file-name-handler (func handler &optional append) "Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'. -FUNC is the function, which determines whether HANDLER is to be called. -Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." +FUNC is the function, which takes a dissected filename and determines +whether HANDLER is to be called. 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. @@ -2799,6 +2872,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))) +(put #'tramp-unload-file-name-handlers 'tramp-autoload t) (add-hook 'tramp-unload-hook #'tramp-unload-file-name-handlers) ;;; File name handler functions for completion mode: @@ -2809,18 +2883,14 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (defun tramp-command-completion-p (_symbol buffer) "A predicate for Tramp interactive commands. They are completed by \"M-x TAB\" only if the current buffer is remote." - (with-current-buffer buffer (tramp-tramp-file-p default-directory))) + (tramp-tramp-file-p (tramp-get-default-directory buffer))) (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 0) - (vec - (cond - ((tramp-file-name-p vec-or-filename) vec-or-filename) - ((tramp-tramp-file-p vec-or-filename) - (tramp-dissect-file-name vec-or-filename))))) + (vec (tramp-ensure-dissected-file-name vec-or-filename))) (or ;; We check this for the process related to ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. @@ -3278,6 +3348,42 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +(defvar tramp-tolerate-tilde nil + "Indicator, that not expandable tilde shall be tolerated. +Let-bind it when necessary.") + +;; `directory-abbrev-apply' and `directory-abbrev-make-regexp' exists +;; since Emacs 29.1. Since this handler isn't called for older +;; Emacsen, it is save to invoke them via `tramp-compat-funcall'. +(defun tramp-handle-abbreviate-file-name (filename) + "Like `abbreviate-file-name' for Tramp files." + (let* ((case-fold-search (file-name-case-insensitive-p filename)) + (vec (tramp-dissect-file-name filename)) + (tramp-tolerate-tilde t) + (home-dir + (if (let ((non-essential t)) (tramp-connectable-p vec)) + ;; If a connection has already been established, get the + ;; home directory. + (tramp-get-home-directory vec) + ;; Otherwise, just use the cached value. + (tramp-get-connection-property vec "~" nil)))) + (when home-dir + (setq home-dir + (tramp-compat-funcall + 'directory-abbrev-apply + (tramp-make-tramp-file-name vec home-dir)))) + ;; If any elt of `directory-abbrev-alist' matches this name, + ;; abbreviate accordingly. + (setq filename (tramp-compat-funcall 'directory-abbrev-apply filename)) + ;; Abbreviate home directory. + (if (and home-dir + (string-match + (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) + filename)) + (tramp-make-tramp-file-name + vec (concat "~" (substring filename (match-beginning 1)))) + (tramp-make-tramp-file-name (tramp-dissect-file-name filename))))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) @@ -3288,10 +3394,11 @@ User is always nil." (if (file-directory-p filename) #'file-accessible-directory-p #'file-readable-p) filename) - (tramp-error - v 'file-error (format "%s: Permission denied, %s" string filename))) - (tramp-compat-file-missing - v (format "%s: No such file or directory, %s" string filename))))) + (tramp-compat-permission-denied + v (format "%s: Permission denied, %s" string filename))) + (tramp-error + v 'file-missing + (format "%s: No such file or directory, %s" string filename))))) (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) @@ -3325,7 +3432,7 @@ User is always nil." ;; `copy-directory' creates NEWNAME before running this check. So ;; we do it ourselves. (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) ;; We must do it file-wise. (tramp-run-real-handler #'copy-directory @@ -3346,7 +3453,7 @@ User is always nil." (defun tramp-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let ((temp (nreverse (file-name-all-completions "" directory))) @@ -3394,6 +3501,21 @@ User is always nil." (with-parsed-tramp-file-name name nil (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) + ;; Expand tilde. Usually, the methods applying this handler do + ;; not support tilde expansion. But users could declare a + ;; respective connection property. (Bug#53847) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) + ;; Tilde expansion is not possible. + (when (and (not tramp-tolerate-tilde) + (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) + (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) @@ -3403,7 +3525,9 @@ User is always nil." (let ((default-directory tramp-compat-temporary-file-directory)) (tramp-make-tramp-file-name v (tramp-drop-volume-letter - (tramp-run-real-handler #'expand-file-name (list localname)))))))) + (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." @@ -3412,9 +3536,7 @@ User is always nil." (defun tramp-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + (eq (file-attribute-type (file-attributes (file-truename filename))) t)) (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." @@ -3446,7 +3568,7 @@ User is always nil." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) @@ -3454,7 +3576,7 @@ User is always nil." (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." (when-let ((attrs (file-attributes filename)) - (mode-string (tramp-compat-file-attribute-modes attrs))) + (mode-string (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)))) @@ -3486,7 +3608,7 @@ User is always nil." (tramp-get-method-parameter v 'tramp-case-insensitive) ;; There isn't. So we must check, in case there's a connection already. - (and (file-remote-p filename nil 'connected) + (and (let ((non-essential t)) (tramp-connectable-p v)) (with-tramp-connection-property v "case-insensitive" (ignore-errors (with-tramp-progress-reporter v 5 "Checking case-insensitive" @@ -3507,16 +3629,13 @@ User is always nil." (directory-file-name (file-name-directory candidate)))) ;; Nothing found, so we must use a temporary file - ;; 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. + ;; for comparison. (unless (string-match-p "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory - (file-name-directory filename))) - (tramp-compat-funcall - 'make-nearby-temp-file "tramp.")) + (file-name-directory filename))) + (make-nearby-temp-file "tramp.")) candidate tmpfile)) ;; Check for the existence of the same file with ;; upper case letters. @@ -3577,9 +3696,8 @@ User is always nil." ((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)))))) + (file-attribute-modification-time (file-attributes file2)) + (file-attribute-modification-time (file-attributes file1)))))) (defun tramp-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -3598,15 +3716,15 @@ User is always nil." ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. (when-let ((attr (file-attributes filename))) - (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) + (eq ?- (aref (file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." ;; We do not want traces in the debug buffer. (let ((tramp-verbose (min tramp-verbose 3))) (when (tramp-tramp-file-p filename) - (let* ((v (tramp-dissect-file-name filename)) - (p (tramp-get-connection-process v)) + (let* ((o (tramp-dissect-file-name filename)) + (p (tramp-get-connection-process o)) (c (and (process-live-p p) (tramp-get-connection-property p "connected" nil)))) ;; We expand the file name only, if there is already a connection. @@ -3620,7 +3738,8 @@ User is always nil." ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) - ((eq identification 'hop) hop) + ;; Hop exists only in original dissected file name. + ((eq identification 'hop) (tramp-file-name-hop o)) (t (tramp-make-tramp-file-name v 'noloc))))))))) (defun tramp-handle-file-selinux-context (_filename) @@ -3630,7 +3749,7 @@ User is always nil." (defun tramp-handle-file-symlink-p (filename) "Like `file-symlink-p' for Tramp files." - (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) + (let ((x (file-attribute-type (file-attributes filename)))) (and (stringp x) x))) (defun tramp-handle-file-truename (filename) @@ -3671,8 +3790,7 @@ User is always nil." (expand-file-name symlink-target (file-name-directory v2-localname)))) - v2-localname) - 'nohop))) + v2-localname)))) (when (>= numchase numchase-limit) (tramp-error v1 'file-error @@ -3719,7 +3837,7 @@ User is always nil." (when (and (not tramp-allow-unsafe-temporary-files) (not backup-inhibited) (file-in-directory-p (car result) temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3776,7 +3894,7 @@ User is always nil." (unwind-protect (if (not (file-exists-p filename)) (let ((tramp-verbose (if visit 0 tramp-verbose))) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (with-tramp-progress-reporter v 3 (format-message "Inserting `%s'" filename) @@ -3831,8 +3949,7 @@ User is always nil." (cond ((stringp remote-copy) (file-local-copy - (tramp-make-tramp-file-name - v remote-copy 'nohop))) + (tramp-make-tramp-file-name v remote-copy))) ((stringp tramp-temp-buffer-file-name) (copy-file filename tramp-temp-buffer-file-name 'ok) @@ -3875,7 +3992,7 @@ User is always nil." (or remote-copy (null tramp-temp-buffer-file-name))) (delete-file local-copy)) (when (stringp remote-copy) - (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))) + (delete-file (tramp-make-tramp-file-name v remote-copy)))) ;; Result. (cons filename (cdr result))))) @@ -3890,16 +4007,19 @@ Return nil when there is no lockfile." (insert-file-contents-literally lockname) (buffer-string)))))) +(defvar tramp-lock-pid nil + "A random nunber local for every connection. +Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") + (defun tramp-get-lock-pid (file) "Determine pid for lockfile of FILE." - ;; Some Tramp methods do not offer a connection process, but just a - ;; network process as a place holder. Those processes use the - ;; "lock-pid" connection property as fake pid, in fact it is the - ;; time stamp the process is created. - (let ((p (tramp-get-process (tramp-dissect-file-name file)))) - (number-to-string - (or (process-id p) - (tramp-get-connection-property p "lock-pid" (emacs-pid)))))) + ;; Not all Tramp methods use an own process. So we use a random + ;; number, which is as good as a process id. + (with-current-buffer + (tramp-get-connection-buffer (tramp-dissect-file-name file)) + (or tramp-lock-pid + (setq-local + tramp-lock-pid (number-to-string (random most-positive-fixnum)))))) (defconst tramp-lock-file-info-regexp ;; USER@HOST.PID[:BOOT_TIME] @@ -3910,9 +4030,11 @@ Return nil when there is no lockfile." "Like `file-locked-p' for Tramp files." (when-let ((info (tramp-get-lock-file file)) (match (string-match tramp-lock-file-info-regexp info))) - (or (and (string-equal (match-string 1 info) (user-login-name)) - (string-equal (match-string 2 info) (system-name)) + (or ; Locked by me. + (and (string-equal (match-string 1 info) (user-login-name)) + (string-equal (match-string 2 info) tramp-system-name) (string-equal (match-string 3 info) (tramp-get-lock-pid file))) + ; User name. (match-string 1 info)))) (defun tramp-handle-lock-file (file) @@ -3921,6 +4043,14 @@ Return nil when there is no lockfile." ;; was visited. (catch 'dont-lock (unless (eq (file-locked-p file) t) ;; Locked by me. + (when (and buffer-file-truename + (not (verify-visited-file-modtime)) + (file-exists-p file)) + ;; In filelock.c, `userlock--ask-user-about-supersession-threat' + ;; is called, which also checks file contents. This is unwise + ;; for remote files. + (ask-user-about-supersession-threat file)) + (when-let ((info (tramp-get-lock-file file)) (match (string-match tramp-lock-file-info-regexp info))) (unless (ask-user-about-lock @@ -3933,7 +4063,7 @@ Return nil when there is no lockfile." ;; USER@HOST.PID[:BOOT_TIME] (info (format - "%s@%s.%s" (user-login-name) (system-name) + "%s@%s.%s" (user-login-name) tramp-system-name (tramp-get-lock-pid file)))) ;; Protect against security hole. @@ -3941,7 +4071,7 @@ Return nil when there is no lockfile." (when (and (not tramp-allow-unsafe-temporary-files) create-lockfiles (file-in-directory-p lockname temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes file 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3993,7 +4123,7 @@ Return nil when there is no lockfile." v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) (unless (or noerror (file-exists-p file)) - (tramp-compat-file-missing v file)) + (tramp-error v 'file-missing file)) (if (not (file-exists-p file)) nil (let ((signal-hook-function (unless noerror signal-hook-function)) @@ -4010,15 +4140,10 @@ Return nil when there is no lockfile." (and (tramp-sh-file-name-handler-p vec) (not (tramp-get-method-parameter vec 'tramp-copy-program)))) -(defun tramp-compute-multi-hops (vec) - "Expands VEC according to `tramp-default-proxies-alist'." - (let ((saved-tdpa tramp-default-proxies-alist) - (target-alist `(,vec)) - (hops (or (tramp-file-name-hop vec) "")) - (item vec) - choices proxy) - - ;; Ad-hoc proxy definitions. +(defun tramp-add-hops (vec) + "Add ad-hoc proxy definitions to `tramp-default-proxies-alist'." + (when-let ((hops (tramp-file-name-hop vec)) + (item vec)) (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) (let* ((host-port (tramp-file-name-host-port item)) (user-domain (tramp-file-name-user-domain item)) @@ -4035,9 +4160,19 @@ Return nil when there is no lockfile." (add-to-list 'tramp-default-proxies-alist entry) (setq item (tramp-dissect-file-name proxy)))) ;; Save the new value. - (when (and hops tramp-save-ad-hoc-proxies) + (when tramp-save-ad-hoc-proxies (customize-save-variable - 'tramp-default-proxies-alist tramp-default-proxies-alist)) + 'tramp-default-proxies-alist tramp-default-proxies-alist)))) + +(defun tramp-compute-multi-hops (vec) + "Expands VEC according to `tramp-default-proxies-alist'." + (let ((saved-tdpa tramp-default-proxies-alist) + (target-alist `(,vec)) + (item vec) + choices proxy) + + ;; Ad-hoc proxy definitions. + (tramp-add-hops vec) ;; Look for proxy hosts to be passed. (setq choices tramp-default-proxies-alist) @@ -4198,7 +4333,9 @@ substitution. SPEC-LIST is a list of char/value pairs used for (command (mapconcat #'tramp-shell-quote-argument command " ")) ;; Set cwd and environment variables. (command - (append `("cd" ,localname "&&" "(" "env") env `(,command ")")))) + (append + `("cd" ,(tramp-shell-quote-argument localname) "&&" "(" "env") + env `(,command ")")))) ;; Check for `tramp-sh-file-name-handler', because something ;; is different between tramp-sh.el, and tramp-adb.el or @@ -4255,18 +4392,13 @@ substitution. SPEC-LIST is a list of char/value pairs used for p)))))) (defun tramp-handle-make-symbolic-link - (target linkname &optional ok-if-already-exists) + (_target linkname &optional _ok-if-already-exists) "Like `make-symbolic-link' for Tramp files. This is the fallback implementation for backends which do not support symbolic links." - (if (tramp-tramp-file-p (expand-file-name linkname)) - (tramp-error - (tramp-dissect-file-name (expand-file-name linkname)) 'file-error - "make-symbolic-link not supported") - ;; This is needed prior Emacs 26.1, where TARGET has also be - ;; checked for a file name handler. - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)))) + (tramp-error + (tramp-dissect-file-name (expand-file-name linkname)) 'file-error + "make-symbolic-link not supported")) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." @@ -4464,10 +4596,7 @@ BUFFER might be a list, in this case STDERR is separated." ;; We must disable cygwin-mount file name ;; handlers and alike. (tramp-run-real-handler - #'substitute-in-file-name (list localname)))))))) - ;; "/m:h:~" does not work for completion. We use "/m:h:~/". - (if (and (stringp localname) (string-equal "~" localname)) - (concat filename "/") + #'substitute-in-file-name (list localname))))))) filename)))) (defconst tramp-time-dont-know '(0 0 0 1000) @@ -4484,7 +4613,7 @@ BUFFER might be a list, in this case STDERR is separated." (unless time-list (let ((remote-file-name-inhibit-cache t)) (setq time-list - (or (tramp-compat-file-attribute-modification-time + (or (file-attribute-modification-time (file-attributes (buffer-file-name))) tramp-time-doesnt-exist)))) (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) @@ -4508,7 +4637,7 @@ of." t (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -4539,11 +4668,9 @@ of." (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (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)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -4579,8 +4706,7 @@ of." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Set the ownership. @@ -4661,8 +4787,8 @@ of." (save-window-excursion (pop-to-buffer (tramp-get-connection-buffer vec)) (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-message vec 3 "Sending login name `%s'" user) (tramp-send-string vec (concat user tramp-local-end-of-line))) t) @@ -4674,7 +4800,9 @@ of." ;; Let's check whether a wrong password has been sent already. ;; Sometimes, the process returns a new password request ;; immediately after rejecting the previous (wrong) one. - (unless (tramp-get-connection-property vec "first-password-request" nil) + (unless (or tramp-password-prompt-not-unique + (tramp-get-connection-property + vec "first-password-request" nil)) (tramp-clear-passwd vec)) (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) @@ -4682,7 +4810,13 @@ of." ;; We don't call `tramp-send-string' in order to hide the ;; password from the debug buffer and the traces. (process-send-string - proc (concat (tramp-read-passwd proc) tramp-local-end-of-line)) + proc + (concat + (funcall + (if tramp-password-prompt-not-unique + #'tramp-read-passwd-without-cache #'tramp-read-passwd) + proc) + tramp-local-end-of-line)) ;; Hide password prompt. (narrow-to-region (point-max) (point-max)))) t) @@ -4705,8 +4839,8 @@ See also `tramp-action-yn'." (unless (yes-or-no-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "yes" tramp-local-end-of-line))) t) @@ -4719,8 +4853,8 @@ See also `tramp-action-yesno'." (unless (y-or-n-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "y" tramp-local-end-of-line))) t) @@ -4728,15 +4862,15 @@ See also `tramp-action-yesno'." "Tell the remote host which terminal type to use. The terminal type can be configured with `tramp-terminal-type'." (tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)) t) (defun tramp-action-confirm-message (_proc vec) "Return RET in order to confirm the message." - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec tramp-local-end-of-line) t) @@ -4923,9 +5057,6 @@ Mostly useful to protect BODY from being interrupted by timers." ,@body) (tramp-flush-connection-property ,proc "locked")))) -(font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-locked-connection\\>")) - (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 @@ -5024,8 +5155,8 @@ nil." ;; The process could have timed out, for example due to session ;; timeout of sudo. The process buffer does not exist any longer then. (ignore-errors - (with-current-buffer (process-buffer proc) - (tramp-message proc 6 "\n%s" (buffer-string)))) + (tramp-message + proc 6 "\n%s" (tramp-get-buffer-string (process-buffer proc)))) (unless found (if timeout (tramp-error @@ -5247,10 +5378,10 @@ If FILENAME is remote, a file name handler is called." (let* ((dir (file-name-directory filename)) (modes (file-modes dir))) (when (and modes (not (zerop (logand modes #o2000)))) - (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) + (setq gid (file-attribute-group-id (file-attributes dir))))) - (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) - (funcall handler #'tramp-set-file-uid-gid filename uid gid) + (if (tramp-tramp-file-p filename) + (tramp-file-name-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))) @@ -5276,8 +5407,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; `group-name' has been introduced with Emacs 27.1. ((and (fboundp 'group-name) (equal id-format 'string)) (tramp-compat-funcall 'group-name (group-gid))) - ((tramp-compat-file-attribute-group-id - (file-attributes "~/" id-format)))))) + ((file-attribute-group-id (file-attributes "~/" id-format)))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -5310,7 +5440,8 @@ be granted." (offset (cond ((eq ?r access) 1) ((eq ?w access) 2) - ((eq ?x access) 3)))) + ((eq ?x access) 3) + ((eq ?s access) 3)))) (dolist (suffix '("string" "integer") result) (setq result @@ -5332,41 +5463,38 @@ be granted." file-attr (or ;; Not a symlink. - (eq t (tramp-compat-file-attribute-type file-attr)) - (null (tramp-compat-file-attribute-type file-attr))) + (eq t (file-attribute-type file-attr)) + (null (file-attribute-type file-attr))) (or ;; World accessible. - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 6))) + (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) ;; User accessible and owned by user. (and - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) offset)) - (or (equal remote-uid - (tramp-compat-file-attribute-user-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-user-id file-attr)))) + (eq access (aref (file-attribute-modes file-attr) offset)) + (or (equal remote-uid unknown-id) + (equal remote-uid (file-attribute-user-id file-attr)) + (equal unknown-id (file-attribute-user-id file-attr)))) ;; Group accessible and owned by user's principal group. (and (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 3))) - (or (equal remote-gid - (tramp-compat-file-attribute-group-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-group-id - file-attr)))))))))))) + (aref (file-attribute-modes file-attr) (+ offset 3))) + (or (equal remote-gid unknown-id) + (equal remote-gid (file-attribute-group-id file-attr)) + (equal unknown-id (file-attribute-group-id file-attr)))))))))))) + +(defun tramp-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (with-tramp-connection-property vec (concat "~" user) + (tramp-file-name-handler #'tramp-get-home-directory vec user))) (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)) + (or (tramp-file-name-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)))) @@ -5375,11 +5503,7 @@ ID-FORMAT valid values are `string' and `integer'." "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-gid))) - (funcall handler #'tramp-get-remote-gid vec id-format)) + (or (tramp-file-name-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)))) @@ -5402,8 +5526,7 @@ This handles also chrooted environments, which are not regarded as local." (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)) + (tramp-make-tramp-file-name vec tramp-compat-temporary-file-directory)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) (zerop (tramp-get-remote-uid vec 'integer)))))) @@ -5497,7 +5620,7 @@ this file, if that variable is non-nil." (when (and (not tramp-allow-unsafe-temporary-files) auto-save-default (file-in-directory-p result temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -5533,8 +5656,7 @@ ALIST is of the form ((FROM . TO) ...)." (defun tramp-handle-make-nearby-temp-file (prefix &optional dir-flag suffix) "Like `make-nearby-temp-file' for Tramp files." - (let ((temporary-file-directory - (tramp-compat-temporary-file-directory-function))) + (let ((temporary-file-directory (temporary-file-directory))) (make-temp-file prefix dir-flag suffix))) ;;; Compatibility functions section: @@ -5557,14 +5679,12 @@ are written with verbosity of 6." (with-temp-buffer (setq result (apply - #'call-process program infile (or destination t) display args)) + #'call-process program infile (or destination t) display args) + output (tramp-get-buffer-string destination)) ;; `result' could also be an error string. (when (stringp result) (setq error result - result 1)) - (with-current-buffer - (if (bufferp destination) destination (current-buffer)) - (setq output (buffer-string)))) + result 1))) (error (setq error (error-message-string err) result 1))) @@ -5595,10 +5715,10 @@ are written with verbosity of 6." ;; `result' could also be an error string. (when (stringp result) (signal 'file-error (list result))) - (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) - (if (zerop result) - (tramp-message vec 6 "%d" result) - (tramp-message vec 6 "%d\n%s" result (buffer-string))))) + (if (zerop result) + (tramp-message vec 6 "%d" result) + (tramp-message + vec 6 "%d\n%s" result (tramp-get-buffer-string buffer)))) (error (setq result 1) (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) @@ -5642,89 +5762,92 @@ verbosity of 6." ;; tramp-cache-read-persistent-data t)'" instead. (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." +Consults the auth-source package." (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. - (tramp-get-connection-property - proc "password-vector" (process-get proc 'vector)) - 'noloc 'nohop)) + ;; In tramp-sh.el, we must use "password-vector" due to + ;; multi-hop. + (vec (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector))) + (key (tramp-make-tramp-file-name vec 'noloc)) + (method (tramp-file-name-method vec)) + (user (or (tramp-file-name-user-domain vec) + (tramp-get-connection-property key "login-as" nil))) + (host (tramp-file-name-host-port vec)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) (tramp-check-for-regexp proc tramp-password-prompt-regexp) - (format "%s for %s " (capitalize (match-string 1)) key)))) + (if (string-match-p "passphrase" (match-string 1)) + (match-string 0) + (format "%s for %s " (capitalize (match-string 1)) key))))) (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; Use connection-local value. - (auth-sources (with-current-buffer (process-buffer proc) auth-sources)) + (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) ;; We suspend the timers while reading the password. (stimers (with-timeout-suspend)) auth-info auth-passwd) (unwind-protect - (with-parsed-tramp-file-name key nil - (setq tramp-password-save-function nil - user - (or user (tramp-get-connection-property key "login-as" nil))) - (prog1 - (or - ;; See if auth-sources contains something useful. - (ignore-errors - (and (tramp-get-connection-property - v "first-password-request" nil) - ;; Try with Tramp's current method. - (setq auth-info - (car - (auth-source-search - :max 1 - (and user :user) - (if domain - (concat - user tramp-prefix-domain-format domain) - user) - :host - (if port - (concat - host tramp-prefix-port-format port) - host) - :port method - :require (cons :secret (and user '(:user))) - :create t)) - tramp-password-save-function - (plist-get auth-info :save-function) - auth-passwd (plist-get auth-info :secret))) - (while (functionp auth-passwd) - (setq auth-passwd (funcall auth-passwd))) - auth-passwd) - - ;; Try the password cache. Exists since Emacs 26.1. - (progn - (setq auth-passwd (password-read pw-prompt key) - tramp-password-save-function - (lambda () (password-cache-add key auth-passwd))) - auth-passwd) - - ;; Else, get the password interactively w/o cache. - (read-passwd pw-prompt)) + ;; We cannot use `with-parsed-tramp-file-name', because it + ;; expands the file name. + (or + (setq tramp-password-save-function nil) + ;; See if auth-sources contains something useful. + (ignore-errors + (and (tramp-get-connection-property + vec "first-password-request" nil) + ;; Try with Tramp's current method. If there is no + ;; user name, `:create' triggers to ask for. We + ;; suppress it. + (setq auth-info + (car + (auth-source-search + :max 1 :user user :host host :port method + :require (cons :secret (and user '(:user))) + :create (and user t))) + tramp-password-save-function + (plist-get auth-info :save-function) + auth-passwd + (tramp-compat-auth-info-password auth-info)))) + + ;; Try the password cache. + (progn + (setq auth-passwd (password-read pw-prompt key) + tramp-password-save-function + (lambda () (password-cache-add key auth-passwd))) + auth-passwd)) - ;; Workaround. Prior Emacs 28.1, auth-source has saved - ;; empty passwords. See discussion in Bug#50399. - (when (zerop (length auth-passwd)) - (setq tramp-password-save-function nil)) - (tramp-set-connection-property v "first-password-request" nil))) + ;; Workaround. Prior Emacs 28.1, auth-source has saved empty + ;; passwords. See discussion in Bug#50399. + (when (zerop (length auth-passwd)) + (setq tramp-password-save-function nil)) + (tramp-set-connection-property vec "first-password-request" nil) ;; Reenable the timers. (with-timeout-unsuspend stimers)))) (put #'tramp-read-passwd 'tramp-suppress-trace t) +(defun tramp-read-passwd-without-cache (proc &optional prompt) + "Read a password from user (compat function)." + ;; We suspend the timers while reading the password. + (let ((stimers (with-timeout-suspend))) + (unwind-protect + (password-read + (or prompt + (with-current-buffer (process-buffer proc) + (tramp-check-for-regexp proc tramp-password-prompt-regexp) + (match-string 0)))) + ;; Reenable the timers. + (with-timeout-unsuspend stimers)))) + +(put #'tramp-read-passwd-without-cache 'tramp-suppress-trace t) + (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) @@ -5737,7 +5860,7 @@ Invokes `password-read' if available, `read-passwd' else." (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc)))) (put #'tramp-clear-passwd 'tramp-suppress-trace t) @@ -5824,18 +5947,16 @@ name of a process or buffer, or nil to default to the current buffer." (while (tramp-accept-process-output proc 0)) (not (process-live-p proc)))))) -;; `interrupt-process-functions' exists since Emacs 26.1. -(when (boundp 'interrupt-process-functions) - (add-hook 'interrupt-process-functions #'tramp-interrupt-process) - (add-hook - 'tramp-unload-hook - (lambda () - (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(add-hook 'interrupt-process-functions #'tramp-interrupt-process) +(add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. -If VEC is nil, return local null device." - (if (null vec) +If VEC is `tramp-null-hop', return local null device." + (if (equal vec tramp-null-hop) null-device (with-tramp-connection-property vec "null-device" (let ((default-directory (tramp-make-tramp-file-name vec))) @@ -5872,6 +5993,8 @@ BODY is the backend specific code." ;; Maybe it's not loaded yet. (ignore-errors (unload-feature 'tramp 'force)))) +(put #'tramp-unload-tramp 'tramp-autoload t) + (provide 'tramp) (run-hooks 'tramp--startup-hook) @@ -5894,5 +6017,11 @@ BODY is the backend specific code." ;; 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. +;; +;; * Implement file name abbreviation for a different user. That is, +;; (abbreviate-file-name "/ssh:user1@host:/home/user2") => +;; "/ssh:user1@host:~user2". +;; +;; * Implement file name abbreviation for user and host names. ;;; tramp.el ends here diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 1f41a926763..e3bcd568d72 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.2.28.1 -;; Package-Requires: ((emacs "25.1")) +;; Version: 2.6.0-pre +;; Package-Requires: ((emacs "26.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.5.2.28.1" +(defconst tramp-version "2.6.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -74,9 +74,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "25.1")) +(let ((x (if (not (string-version-lessp emacs-version "26.1")) "ok" - (format "Tramp 2.5.2.28.1 is not fit for %s" + (format "Tramp 2.6.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 21c6f5dd9d0..b2ef47898cd 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -61,6 +61,13 @@ ;;; Code: +;; TODO: +;; - Add a menu bar and tool bar for this library. +;; - Add commands to create/delete link from the hotlist. +;; - Add something like a bookmark folder in modern browsers. +;; - Add a command that can open/follow all links in a folder. +;; - Add tags for Web sites in the hotlist. + ;;-------------------------------------------------------- Package Dependencies (require 'browse-url) |