diff options
Diffstat (limited to 'lisp/net')
52 files changed, 3625 insertions, 2340 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index a6904fc07e9..9937c022d9f 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -2547,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 e4c485eccde..a55aec76bfc 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1,4 +1,4 @@ -;;; browse-url.el --- pass a URL to a WWW browser -*- lexical-binding: t; -*- +;;; browse-url.el --- pass a URL to a web browser -*- lexical-binding: t; -*- ;; Copyright (C) 1995-2022 Free Software Foundation, Inc. @@ -24,24 +24,28 @@ ;;; Commentary: -;; This package provides functions which read a URL (Uniform Resource -;; Locator) from the minibuffer, defaulting to the URL around point, -;; and ask a World-Wide Web browser to load it. It can also load the -;; URL associated with the current buffer. Different browsers use -;; different methods of remote control so there is one function for -;; each supported browser. If the chosen browser is not running, it -;; is started. Currently there is support for the following browsers, -;; as well as some other obsolete ones: +;; This package provides functions which read a URL from the +;; minibuffer, defaulting to the URL around point, and ask a web +;; browser to load it. It can also load the URL at point, or one +;; associated with the current buffer. The main functions are: + +;; `browse-url' Open URL +;; `browse-url-at-point' Open URL at point +;; `browse-url-of-buffer' Use web browser to display buffer +;; `browse-url-of-file' Use web browser to display file + +;; Different browsers use different methods of remote control so there +;; is one function for each supported browser. If the chosen browser +;; is not running, it is started. Currently there is support for the +;; following browsers, as well as some other obsolete ones: ;; Function Browser Earliest version -;; browse-url-mozilla Mozilla Don't know ;; browse-url-firefox Firefox Don't know (tried with 1.0.1) ;; 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-text-* Any text browser 0 ;; browse-url-generic arbitrary ;; browse-url-default-windows-browser MS-Windows browser ;; browse-url-default-macosx-browser macOS browser @@ -50,14 +54,12 @@ ;; browse-url-elinks Elinks Don't know (tried with 0.12.GIT) ;; eww-browse-url Emacs Web Wowser -;; Browsers can cache Web pages so it may be necessary to tell them to +;; Browsers can cache web pages so it may be necessary to tell them to ;; reload the current page if it has changed (e.g., if you have edited ;; it). There is currently no perfect automatic solution to this. -;; This package generalizes function html-previewer-process in Marc -;; Andreessen's html-mode (LCD modes/html-mode.el.Z). See also the -;; ffap.el package. The huge hyperbole package also contains similar -;; functions. +;; See also the ffap.el package. The huge hyperbole package also +;; contains similar functions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Usage @@ -83,34 +85,34 @@ ;; M-x browse-url-of-dired-file RET ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Customization (~/.emacs) +;; Customization (Init File) ;; To see what variables are available for customization, type ;; `M-x set-variable browse-url TAB'. Better, use ;; `M-x customize-group browse-url'. -;; Bind the browse-url commands to keys with the `C-c C-z' prefix -;; (as used by html-helper-mode): -;; (global-set-key "\C-c\C-z." 'browse-url-at-point) -;; (global-set-key "\C-c\C-zb" 'browse-url-of-buffer) -;; (global-set-key "\C-c\C-zr" 'browse-url-of-region) -;; (global-set-key "\C-c\C-zu" 'browse-url) -;; (global-set-key "\C-c\C-zv" 'browse-url-of-file) +;; Bind the browse-url commands to keys with the `C-c C-z' prefix: + +;; (keymap-global-set "C-c C-z ." 'browse-url-at-point) +;; (keymap-global-set "C-c C-z b" 'browse-url-of-buffer) +;; (keymap-global-set "C-c C-z r" 'browse-url-of-region) +;; (keymap-global-set "C-c C-z u" 'browse-url) +;; (keymap-global-set "C-c C-z v" 'browse-url-of-file) ;; (add-hook 'dired-mode-hook ;; (lambda () -;; (local-set-key "\C-c\C-zf" 'browse-url-of-dired-file))) +;; (keymap-local-set "C-c C-z f" 'browse-url-of-dired-file))) ;; Browse URLs in mail messages under RMAIL by clicking mouse-2: ;; (add-hook 'rmail-mode-hook (lambda () ; rmail-mode startup -;; (define-key rmail-mode-map [mouse-2] 'browse-url-at-mouse))) +;; (keymap-set rmail-mode-map [mouse-2] 'browse-url-at-mouse))) ;; Alternatively, add `goto-address' to `rmail-show-message-hook'. ;; Gnus provides a standard feature to activate URLs in article ;; buffers for invocation of browse-url. -;; Use the Emacs w3 browser when not running under X11: +;; Use the Emacs Web Wowser (EWW) when not running under X11: ;; (or (eq window-system 'x) -;; (setq browse-url-browser-function 'browse-url-w3)) +;; (setq browse-url-browser-function #'eww-browse-url)) ;; To always save modified buffers before displaying the file in a browser: ;; (setq browse-url-save-file t) @@ -149,15 +151,14 @@ :group 'comm) (defvar browse-url--browser-defcustom-type - '(choice - (function-item :tag "Emacs W3" :value browse-url-w3) - (function-item :tag "eww" :value eww-browse-url) - (function-item :tag "Mozilla" :value browse-url-mozilla) + `(choice + (function-item :tag "Emacs Web Wowser (EWW)" :value eww-browse-url) (function-item :tag "Firefox" :value browse-url-firefox) (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) + ,@(when (eq system-type 'haiku) + (list '(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" @@ -165,11 +166,13 @@ (function-item :tag "KDE" :value browse-url-kde) (function-item :tag "Elinks" :value browse-url-elinks) (function-item :tag "Specified by `Browse Url Generic Program'" - :value browse-url-generic) - (function-item :tag "Default Windows browser" - :value browse-url-default-windows-browser) - (function-item :tag "Default macOS browser" - :value browse-url-default-macosx-browser) + :value browse-url-generic) + ,@(when (eq system-type 'windows-nt) + (list '(function-item :tag "Default Windows browser" + :value browse-url-default-windows-browser))) + ,@(when (eq system-type 'darwin) + (list '(function-item :tag "Default macOS browser" + :value browse-url-default-macosx-browser))) (function-item :tag "Default browser" :value browse-url-default-browser) (function :tag "Your own function") @@ -247,16 +250,19 @@ be used instead." (defcustom browse-url-mozilla-program "mozilla" "The name by which to invoke Mozilla." :type 'string) +(make-obsolete-variable 'browse-url-mozilla-program nil "29.1") (defcustom browse-url-mozilla-arguments nil "A list of strings to pass to Mozilla as arguments." :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'browse-url-mozilla-arguments nil "29.1") (defcustom browse-url-mozilla-startup-arguments browse-url-mozilla-arguments "A list of strings to pass to Mozilla when it starts up. Defaults to the value of `browse-url-mozilla-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'browse-url-mozilla-startup-arguments nil "29.1") (defun browse-url--find-executable (candidates default) (while (and candidates (not (executable-find (car candidates)))) @@ -340,6 +346,7 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time If non-nil, then open the URL in a new tab rather than a new window if `browse-url-mozilla' is asked to open it in a new window." :type 'boolean) +(make-obsolete-variable 'browse-url-mozilla-new-window-is-tab nil "29.1") (defcustom browse-url-firefox-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. @@ -404,7 +411,7 @@ address to an HTTP URL: (setq browse-url-filename-alist \\='((\"/webmaster@webserver:/home/www/html/\" . - \"http://www.acme.co.uk/\") + \"https://www.example.org/\") (\"^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*\" . \"ftp://\\2/\") (\"^/\\([^:@/]+@\\)?\\([^:/]+\\):/*\" . \"ftp://\\1\\2/\") (\"^/+\" . \"file:/\")))" @@ -437,11 +444,13 @@ These might set its size, for instance." (defcustom browse-url-gnudoit-program "gnudoit" "The name of the `gnudoit' program used by `browse-url-w3-gnudoit'." :type 'string) +(make-obsolete-variable 'browse-url-gnudoit-program nil "29.1") (defcustom browse-url-gnudoit-args '("-q") "A list of strings defining options for `browse-url-gnudoit-program'. These might set the port, for instance." :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'browse-url-gnudoit-args nil "29.1") (defcustom browse-url-generic-program nil "The name of the browser program used by `browse-url-generic'." @@ -635,18 +644,32 @@ CHARS is a regexp that matches a character." The annoying characters are those that can mislead a web browser regarding its parameter treatment." ;; FIXME: Is there an actual example of a web browser getting - ;; confused? (This used to encode commas, but at least Firefox - ;; handles commas correctly and doesn't accept encoded commas.) - (browse-url-url-encode-chars url "[\"()$ ]")) + ;; confused? (This used to encode commas and dollar signs, but at + ;; least Firefox handles commas correctly and doesn't accept those + ;; encoded.) + (browse-url-url-encode-chars url "[\"() ]")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL input +(defcustom browse-url-default-scheme "http" + "URL scheme that `browse-url' (and related commands) will use by default. + +For example, when point is on an URL fragment like +\"www.example.org\", `browse-url' will assume that this is an +\"http\" URL by default (i.e. \"http://www.example.org\"). + +Note that if you set this to \"https\", websites that do not yet +support HTTPS may not load correctly in your web browser. Such +websites are increasingly rare, but they do still exist." + :type 'string + :version "29.1") + (defun browse-url-url-at-point () (or (thing-at-point 'url t) ;; assume that the user is pointing at something like gnu.org/gnu (let ((f (thing-at-point 'filename t))) - (and f (concat "http://" f))))) + (and f (concat browse-url-default-scheme "://" f))))) ;; Having this as a separate function called by the browser-specific ;; functions allows them to be stand-alone commands, making it easier @@ -708,16 +731,38 @@ interactively. Turn the filename into a URL with function (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. + (let ((bits (file-name-split file))) + (setq file + (string-join + ;; On Windows, the first bit here might be "c:" or the + ;; like, so don't encode the ":" in the first bit. + (cons (let ((url-unreserved-chars + (if (file-name-absolute-p file) + (cons ?: url-unreserved-chars) + url-unreserved-chars))) + (url-hexify-string (car bits))) + (mapcar #'url-hexify-string (cdr bits))) + "/")))) (dolist (map browse-url-filename-alist) (when (and map (string-match (car map) file)) (setq file (replace-match (cdr map) t nil file)))) @@ -769,7 +814,10 @@ If optional arg TEMP-FILE-NAME is non-nil, delete it instead." (defun browse-url-of-dired-file () "In Dired, ask a WWW browser to display the file named on this line." (interactive) - (let ((tem (dired-get-filename t t))) + (let ((tem (dired-get-filename t t)) + ;; Some URL handlers open files in Emacs. We want to always + ;; open in a browser, so disable those. + (browse-url-default-handlers nil)) (if tem (browse-url-of-file (expand-file-name tem)) (error "No file on this line")))) @@ -835,7 +883,11 @@ If ARGS are omitted, the default is to pass ((featurep 'pgtk) (setq classname (pgtk-backend-display-class)) (if (equal classname "GdkWaylandDisplay") - (setenv "WAYLAND_DISPLAY" dpy) + (progn + ;; The `display' frame parameter is probably wrong. + ;; See bug#53969 for some context. + ;; (setenv "WAYLAND_DISPLAY" dpy) + ) (setenv "DISPLAY" dpy))) (t (setenv "DISPLAY" dpy))))) @@ -954,7 +1006,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 () @@ -984,22 +1042,21 @@ instead of `browse-url-new-window-flag'." 'browse-url-default-windows-browser) ((memq system-type '(darwin)) 'browse-url-default-macosx-browser) + ((featurep 'haiku) + 'browse-url-default-haiku-browser) ((browse-url-can-use-xdg-open) 'browse-url-xdg-open) ;;; ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz) - ((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-kde-program) 'browse-url-kde) ((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 - (lambda (&rest _ignore) (error "No usable browser found")))) + (t #'eww-browse-url)) url args)) (function-put 'browse-url-default-browser 'browse-url-browser-kind - ;; Well, most probably external if we ignore w3. + ;; Well, most probably external if we ignore EWW. 'external) (defun browse-url-can-use-xdg-open () @@ -1040,6 +1097,7 @@ 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 "29.1")) (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) @@ -1066,6 +1124,7 @@ used instead of `browse-url-new-window-flag'." (defun browse-url-mozilla-sentinel (process url) "Handle a change to the process communicating with Mozilla." + (declare (obsolete nil "29.1")) (or (eq (process-exit-status process) 0) (let* ((process-environment (browse-url-process-environment))) ;; Mozilla is not running - start it @@ -1204,6 +1263,24 @@ The optional argument NEW-WINDOW is not used." (function-put 'browse-url-webpositive 'browse-url-browser-kind 'external) +(declare-function haiku-roster-launch "haikuselect.c") + +;;;###autoload +(defun browse-url-default-haiku-browser (url &optional _new-window) + "Browse URL with the system default browser. +Default to the URL around or before point." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((scheme (save-match-data + (if (string-match "\\(.+\\):/" url) + (match-string 1 url) + "http"))) + (mime (concat "application/x-vnd.Be.URL." scheme))) + (haiku-roster-launch mime (vector url)))) + +(function-put 'browse-url-default-haiku-browser + '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. @@ -1213,10 +1290,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))) @@ -1307,6 +1386,7 @@ prefix argument reverses the effect of `browse-url-new-window-flag'. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." + (declare (obsolete nil "29.1")) (interactive (browse-url-interactive-arg "W3 URL: ")) (require 'w3) ; w3-fetch-other-window not autoloaded (if (browse-url-maybe-new-window new-window) @@ -1576,13 +1656,11 @@ from `browse-url-elinks-wrapper'." ;;; Adding buttons to a buffer to call `browse-url' when you hit them. -(defvar browse-url-button-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" #'browse-url-button-open) - (define-key map [mouse-2] #'browse-url-button-open) - (define-key map "w" #'browse-url-button-copy) - map) - "The keymap used for `browse-url' buttons.") +(defvar-keymap browse-url-button-map + :doc "The keymap used for `browse-url' buttons." + "RET" #'browse-url-button-open + "<mouse-2>" #'browse-url-button-open + "w" #'browse-url-button-copy) (defface browse-url-button '((t :inherit link)) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 6a8bf879671..d4d4ed54e90 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -1871,13 +1871,7 @@ name and cdr is the list of properties as returned by \(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\") - => ((\"/org/gnome/SettingsDaemon/MediaKeys\" - (\"org.gnome.SettingsDaemon.MediaKeys\") - (\"org.freedesktop.DBus.Peer\") - (\"org.freedesktop.DBus.Introspectable\") - (\"org.freedesktop.DBus.Properties\") - (\"org.freedesktop.DBus.ObjectManager\")) - (\"/org/gnome/SettingsDaemon/Power\" + => ((\"/org/gnome/SettingsDaemon/Power\" (\"org.gnome.SettingsDaemon.Power.Keyboard\") (\"org.gnome.SettingsDaemon.Power.Screen\") (\"org.gnome.SettingsDaemon.Power\" diff --git a/lisp/net/dictionary-connection.el b/lisp/net/dictionary-connection.el index aef3c4efc74..a4afcd6647d 100644 --- a/lisp/net/dictionary-connection.el +++ b/lisp/net/dictionary-connection.el @@ -83,10 +83,10 @@ Return a data structure identifying the connection." "Return the status of the CONNECTION. Possible return values are the symbols: nil: argument is not a connection object - 'none: argument is not connected - 'up: connection is open and buffer is existing - 'down: connection is closed - 'alone: connection is not associated with a buffer" + `none': argument is not connected + `up': connection is open and buffer is existing + `down': connection is closed + `alone': connection is not associated with a buffer" (when (dictionary-connection-p connection) (let ((process (dictionary-connection-process connection)) (buffer (dictionary-connection-buffer connection))) diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index 507363cc0f8..31cc5035a3e 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -89,7 +89,7 @@ You can specify here: This port is probably always 2628 so there should be no need to modify it." :group 'dictionary :set #'dictionary-set-server-var - :type 'number + :type 'natnum :version "28.1") (defcustom dictionary-identification @@ -206,7 +206,7 @@ where the current word was found." "The port of the proxy server, used only when `dictionary-use-http-proxy' is set." :group 'dictionary-proxy :set #'dictionary-set-server-var - :type 'number + :type 'natnum :version "28.1") (defcustom dictionary-use-single-buffer @@ -326,26 +326,22 @@ is utf-8" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar dictionary-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (set-keymap-parent map button-buffer-map) - - (define-key map "q" #'dictionary-close) - (define-key map "h" #'dictionary-help) - (define-key map "s" #'dictionary-search) - (define-key map "d" #'dictionary-lookup-definition) - (define-key map "D" #'dictionary-select-dictionary) - (define-key map "M" #'dictionary-select-strategy) - (define-key map "m" #'dictionary-match-words) - (define-key map "l" #'dictionary-previous) - (define-key map "n" #'forward-button) - (define-key map "p" #'backward-button) - (define-key map " " #'scroll-up-command) - (define-key map [?\S-\ ] #'scroll-down-command) - (define-key map (read-kbd-macro "M-SPC") #'scroll-down-command) - map) - "Keymap for the dictionary mode.") +(defvar-keymap dictionary-mode-map + :doc "Keymap for the dictionary mode." + :suppress t :parent button-buffer-map + "q" #'dictionary-close + "h" #'dictionary-help + "s" #'dictionary-search + "d" #'dictionary-lookup-definition + "D" #'dictionary-select-dictionary + "M" #'dictionary-select-strategy + "m" #'dictionary-match-words + "l" #'dictionary-previous + "n" #'forward-button + "p" #'backward-button + "SPC" #'scroll-up-command + "S-SPC" #'scroll-down-command + "M-SPC" #'scroll-down-command) (defvar dictionary-connection nil @@ -759,31 +755,31 @@ of matching words." (progn (insert-button "[Back]" :type 'dictionary-button 'callback 'dictionary-restore-state - 'help-echo (purecopy "Mouse-2 to go backwards in history")) + 'help-echo "Mouse-2 to go backwards in history") (insert " ") (insert-button "[Search definition]" :type 'dictionary-button 'callback 'dictionary-search - 'help-echo (purecopy "Mouse-2 to look up a new word")) + 'help-echo "Mouse-2 to look up a new word") (insert " ") (insert-button "[Matching words]" :type 'dictionary-button 'callback 'dictionary-match-words - 'help-echo (purecopy "Mouse-2 to find matches for a pattern")) + 'help-echo "Mouse-2 to find matches for a pattern") (insert " ") (insert-button "[Quit]" :type 'dictionary-button 'callback 'dictionary-close - 'help-echo (purecopy "Mouse-2 to close this window")) + 'help-echo "Mouse-2 to close this window") (insert "\n ") (insert-button "[Select dictionary]" :type 'dictionary-button 'callback 'dictionary-select-dictionary - 'help-echo (purecopy "Mouse-2 to select dictionary for future searches")) + 'help-echo "Mouse-2 to select dictionary for future searches") (insert " ") (insert-button "[Select match strategy]" :type 'dictionary-button 'callback 'dictionary-select-strategy - 'help-echo (purecopy "Mouse-2 to select matching algorithm")) + 'help-echo "Mouse-2 to select matching algorithm") (insert "\n\n"))) (setq dictionary-marker (point-marker))) @@ -932,13 +928,13 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (insert-button (concat dictionary ": " translated) :type 'dictionary-link 'callback 'dictionary-set-dictionary 'data (cons dictionary description) - 'help-echo (purecopy "Mouse-2 to select this dictionary")) + 'help-echo "Mouse-2 to select this dictionary") (unless (dictionary-special-dictionary dictionary) (insert " ") (insert-button "(Details)" :type 'dictionary-link 'callback 'dictionary-set-dictionary 'list-data (list (cons dictionary description) t) - 'help-echo (purecopy "Mouse-2 to get more information"))) + 'help-echo "Mouse-2 to get more information")) (insert "\n"))))) (defun dictionary-set-dictionary (param &optional more) @@ -976,7 +972,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (insert-button description :type 'dictionary-link 'callback 'dictionary-set-dictionary 'data (cons dictionary description) - 'help-echo (purecopy "Mouse-2 to select this dictionary")) + 'help-echo "Mouse-2 to select this dictionary") (insert "\n\n") (setq reply (dictionary-read-answer)) (insert reply) @@ -1027,7 +1023,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (insert-button description :type 'dictionary-link 'callback 'dictionary-set-strategy 'data strategy - 'help-echo (purecopy "Mouse-2 to select this matching algorithm")) + 'help-echo "Mouse-2 to select this matching algorithm") (insert "\n"))))) (defun dictionary-set-strategy (strategy &rest _ignored) @@ -1128,7 +1124,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (insert-button word :type 'dictionary-link 'callback 'dictionary-new-search 'data (cons word dictionary) - 'help-echo (purecopy "Mouse-2 to lookup word")) + 'help-echo "Mouse-2 to lookup word") (insert "\n")) (reverse word-list)) (insert "\n"))) list)) @@ -1376,7 +1372,7 @@ any buffer where (dictionary-tooltip-mode 1) has been called." (dictionary-search word))) ;;;###autoload -(defun context-menu-dictionary (menu click) +(defun dictionary-context-menu (menu click) "Populate MENU with dictionary commands at CLICK. When you add this function to `context-menu-functions', the context menu will contain an item that searches diff --git a/lisp/net/dig.el b/lisp/net/dig.el index f7f1500454a..d4fad0c61fd 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -44,6 +44,11 @@ "Name of dig (domain information groper) binary." :type 'file) +(defcustom dig-program-options nil + "Options for the dig program." + :type '(repeat string) + :version "26.1") + (defcustom dig-dns-server nil "DNS server to query. If nil, use system defaults." @@ -59,8 +64,8 @@ If nil, use system defaults." :type 'sexp) (defun dig-invoke (domain &optional - query-type query-class query-option - dig-option server) + query-type query-class query-option + dig-option server) "Call dig with given arguments and return buffer containing output. DOMAIN is a string with a DNS domain. QUERY-TYPE is an optional string with a DNS type. QUERY-CLASS is an optional string with a DNS @@ -79,7 +84,8 @@ and is a commonly available debugging tool." (push domain cmdline) (if server (push (concat "@" server) cmdline) (if dig-dns-server (push (concat "@" dig-dns-server) cmdline))) - (apply #'call-process dig-program nil buf nil cmdline) + (apply #'call-process dig-program nil buf nil + (append dig-program-options cmdline)) buf)) (defun dig-extract-rr (domain &optional type class) @@ -117,11 +123,9 @@ Buffer should contain output generated by `dig-invoke'." (setq str (replace-match "" nil nil str))) str)) -(defvar dig-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "g" nil) - (define-key map "q" #'dig-exit) - map)) +(defvar-keymap dig-mode-map + "g" nil + "q" #'dig-exit) (define-derived-mode dig-mode special-mode "Dig" "Major mode for displaying dig output." @@ -132,7 +136,7 @@ Buffer should contain output generated by `dig-invoke'." (defun dig-exit () "Quit dig output buffer." - (interactive) + (interactive nil dig-mode) (quit-window t)) ;;;###autoload @@ -140,12 +144,23 @@ Buffer should contain output generated by `dig-invoke'." query-type query-class query-option dig-option server) "Query addresses of a DOMAIN using dig. See `dig-invoke' for an explanation for the parameters. -When called interactively, DOMAIN is prompted for. If given a prefix, -also prompt for the QUERY-TYPE parameter." +When called interactively, DOMAIN is prompted for. + +If given a \\[universal-argument] prefix, also prompt \ +for the QUERY-TYPE parameter. + +If given a \\[universal-argument] \\[universal-argument] \ +prefix, also prompt for the SERVER parameter." (interactive - (list (read-string "Host: ") + (list (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Host" default) nil nil default)) (and current-prefix-arg (read-string "Query type: ")))) + (when (and (numberp (car current-prefix-arg)) + (>= (car current-prefix-arg) 16)) + (let ((serv (read-from-minibuffer "Name server: "))) + (when (not (equal serv "")) + (setq server serv)))) (pop-to-buffer-same-window (dig-invoke domain query-type query-class query-option dig-option server)) (goto-char (point-min)) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 6a2cd13dd03..68a0ccb3a13 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -86,7 +86,7 @@ `("EUDC Image Menu" ["---" nil nil] ["Toggle inline display" eudc-bob-toggle-inline-display - (eudc-bob-can-display-inline-images)] + (display-graphic-p)] ,@(cdr (cdr eudc-bob-generic-menu)))) (defvar eudc-bob-sound-menu @@ -109,14 +109,6 @@ (setq overlays (cdr overlays))) value)) -(defun eudc-bob-can-display-inline-images () - "Return non-nil if we can display images inline." - (if (fboundp 'console-type) - (and (memq (console-type) '(x mswindows)) - (fboundp 'make-glyph)) - (and (fboundp 'display-graphic-p) - (display-graphic-p)))) - (defun eudc-bob-make-button (label keymap &optional menu plist) "Create a button with LABEL. Attach KEYMAP, MENU and properties from PLIST to a new overlay covering @@ -124,7 +116,7 @@ LABEL." (let (overlay (p (point)) prop val) - (insert label) + (insert (or label "")) (put-text-property p (point) 'face 'bold) (setq overlay (make-overlay p (point))) (overlay-put overlay 'mouse-face 'highlight) @@ -142,19 +134,7 @@ LABEL." "Display the JPEG DATA at point. If INLINE is non-nil, try to inline the image otherwise simply display a button." - (cond ((fboundp 'make-glyph) - (let ((glyph (if (eudc-bob-can-display-inline-images) - (make-glyph (list (vector 'jpeg :data data) - [string :data "[JPEG Picture]"]))))) - (eudc-bob-make-button "[JPEG Picture]" - eudc-bob-image-keymap - eudc-bob-image-menu - (list 'glyph glyph - 'end-glyph (if inline glyph) - 'duplicable t - 'invisible inline - 'object-data data)))) - ((fboundp 'create-image) + (cond ((fboundp 'create-image) (let* ((image (create-image data nil t)) (props (list 'object-data data 'eudc-image image))) (when (and inline (image-type-available-p 'jpeg)) @@ -167,7 +147,7 @@ display a button." (defun eudc-bob-toggle-inline-display () "Toggle inline display of an image." (interactive) - (when (eudc-bob-can-display-inline-images) + (when (display-graphic-p) (let* ((overlays (append (overlays-at (1- (point))) (overlays-at (point)))) image) @@ -287,11 +267,13 @@ display a button." ;;;###autoload (defun eudc-display-jpeg-inline (data) "Display the JPEG DATA inline at point if possible." - (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images))) + (eudc-bob-display-jpeg data (display-graphic-p))) ;;;###autoload (defun eudc-display-jpeg-as-button (data) "Display a button for the JPEG DATA." (eudc-bob-display-jpeg data nil)) +(define-obsolete-function-alias 'eudc-bob-can-display-inline-images #'display-graphic-p "29.1") + ;;; eudc-bob.el ends here diff --git a/lisp/net/eudc-capf.el b/lisp/net/eudc-capf.el new file mode 100644 index 00000000000..68cbfd93ffe --- /dev/null +++ b/lisp/net/eudc-capf.el @@ -0,0 +1,133 @@ +;;; eudc-capf.el --- EUDC - completion-at-point bindings -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; Author: Alexander Adolf +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library provides functions to deliver email addresses from +;; EUDC search results to `completion-at-point'. +;; +;; Email address completion will likely be desirable only in +;; situations where designating email recipients plays a role, such +;; as when composing or replying to email messages, or when posting +;; to newsgroups, possibly with copies of the post being emailed. +;; Hence, modes relevant in such contexts, such as for example +;; `message-mode' and `mail-mode', often at least to some extent +;; provide infrastructure for different functions to be called when +;; completing in certain message header fields, or in the body of +;; the message. In other modes for editing email messages or +;; newsgroup posts, which do not provide such infrastructure, any +;; completion function providing email addresses will need to check +;; whether the completion attempt occurs in an appropriate context +;; (that is, in a relevant message header field) before providing +;; completion candidates. Two mechanisms are thus provided by this +;; library. +;; +;; The first mechanism is intended for use by the modes listed in +;; `eudc-capf-modes', and relies on these modes adding +;; `eudc-capf-complete' to `completion-at-point-functions', as +;; would be usually done for any general-purpose completion +;; function. In this mode of operation, and in order to offer +;; email addresses only in contexts where the user would expect +;; them, a check is performed whether point is on a line that is a +;; message header field suitable for email addresses, such as for +;; example "To:", "Cc:", etc. +;; +;; The second mechanism is intended for when the user modifies +;; `message-completion-alist' to replace `message-expand-name' with +;; the function `eudc-capf-message-expand-name'. As a result, +;; minibuffer completion (`completing-read') for email addresses +;; would no longer enabled in `message-mode', but +;; `completion-at-point' (in-buffer completion) only. + +;;; Usage: + +;; In a major mode, or context where you want email address +;; completion, you would do something along the lines of: +;; +;; (require 'eudc-capf) +;; (add-hook 'completion-at-point-functions #'eudc-capf-complete -1 t) +;; +;; The minus one argument puts it at the front of the list so it is +;; called first, and the t value for the LOCAL parameter causes the +;; setting to be buffer local, so as to avoid modifying any global +;; setting. +;; +;; The value of the variable `eudc-capf-modes' indicates which +;; major modes do such a setup as part of their initialisation +;; code. + +;;; Code: + +(require 'eudc) + +(defvar message-email-recipient-header-regexp) +(defvar mail-abbrev-mode-regexp) +(declare-function mail-abbrev-in-expansion-header-p "mailabbrev" ()) + +(defconst eudc-capf-modes '(message-mode) + "List of modes in which email address completion is to be attempted.") + +;; completion functions + +;;;###autoload +(defun eudc-capf-complete () + "Email address completion function for `completion-at-point-functions'. + +This function checks whether the current major mode is one of the +modes listed in `eudc-capf-modes', and whether point is on a line +with a message header listing email recipients, that is, a line +whose beginning matches `message-email-recipient-header-regexp', +and, if the check succeeds, searches for records matching the +words before point. + +The return value is either nil when no match is found, or a +completion table as required for functions listed in +`completion-at-point-functions'." + (if (and (seq-some #'derived-mode-p eudc-capf-modes) + (let ((mail-abbrev-mode-regexp message-email-recipient-header-regexp)) + (mail-abbrev-in-expansion-header-p))) + (eudc-capf-message-expand-name))) + +;;;###autoload +(defun eudc-capf-message-expand-name () + "Email address completion function for `message-completion-alist'. + +When this function is added to `message-completion-alist', +replacing any existing entry for `message-expand-name' there, +with an appropriate regular expression such as for example +`message-email-recipient-header-regexp', then EUDC will be +queried for email addresses, and the results delivered to +`completion-at-point'." + (if (or eudc-server eudc-server-hotlist) + (progn + (let* ((beg (save-excursion + (re-search-backward "\\([:,]\\|^\\)[ \t]*") + (match-end 0))) + (end (point)) + (prefix (save-excursion (buffer-substring-no-properties beg end)))) + (list beg end + (completion-table-with-cache + (lambda (_) + (eudc-query-with-words (split-string prefix "[ \t]+") t)) + t)))))) + +(provide 'eudc-capf) +;;; eudc-capf.el ends here diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index 26afd768051..d70e0cf4f63 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -35,15 +35,13 @@ (defvar eudc-hotlist-menu nil) (defvar eudc-hotlist-list-beginning nil) -(defvar eudc-hotlist-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "a" #'eudc-hotlist-add-server) - (define-key map "d" #'eudc-hotlist-delete-server) - (define-key map "s" #'eudc-hotlist-select-server) - (define-key map "t" #'eudc-hotlist-transpose-servers) - (define-key map "q" #'eudc-hotlist-quit-edit) - (define-key map "x" #'kill-current-buffer) - map)) +(defvar-keymap eudc-hotlist-mode-map + "a" #'eudc-hotlist-add-server + "d" #'eudc-hotlist-delete-server + "s" #'eudc-hotlist-select-server + "t" #'eudc-hotlist-transpose-servers + "q" #'eudc-hotlist-quit-edit + "x" #'kill-current-buffer) (define-derived-mode eudc-hotlist-mode fundamental-mode "EUDC-Servers" "Major mode used to edit the hotlist of servers. diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index 3122b26cd81..59347ccc89a 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,32 +179,63 @@ 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") -(defcustom eudc-inline-expansion-format '("%s %s <%s>" firstname name email) - "A list specifying the format of the expansion of inline queries. -This variable controls what `eudc-expand-inline' actually inserts in -the buffer. First element is a string passed to `format'. Remaining -elements are symbols indicating attribute names; the corresponding values -are passed as additional arguments to `format'." - :type '(list - (string :tag "Format String") - (repeat :inline t - :tag "Attributes" - (choice - :tag "Attribute" - (const :menu-tag "First Name" :tag "First Name" firstname) - (const :menu-tag "Surname" :tag "Surname" name) - (const :menu-tag "Email Address" :tag "Email Address" email) - (const :menu-tag "Phone" :tag "Phone" phone) - (symbol :menu-tag "Other") - (symbol :tag "Attribute name")))) - :version "25.1") +(defcustom eudc-inline-expansion-format nil + "Specify the format of the expansion of inline queries. +This variable controls what `eudc-expand-inline' actually inserts +in the buffer. It is either a list, or a function. + +When set to a list, the expansion result will be formatted +according to the first element of the list, a string, which is +passed as the first argument to `format'. The remaining elements +of the list are symbols indicating attribute names; the +corresponding values are passed as additional arguments to +`format'. + +When set to nil, the expansion result will be formatted using +`eudc-rfc5322-make-address', and the PHRASE part will be +formatted according to \"firstname name\", quoting the result if +necessary. No COMMENT will be added in this case. + +When set to a function, the expansion result will be formatted +using `eudc-rfc5322-make-address', and the referenced function is +used to format the PHRASE, and COMMENT parts, respectively. It +receives a single argument, which is an alist of +protocol-specific attributes describing the recipient. To access +the alist elements using generic EUDC attribute names, such as +for example name, or email, use `eudc-translate-attribute-list'. +The function should return a list, which should contain two +elements. If the first element is a string, it will be used as +the PHRASE part, quoting it if necessary. If the second element +is a string, it will be used as the COMMENT part, unless it +contains characters not allowed in the COMMENT part by RFC 5322, +in which case the COMMENT part will be omitted." + :type '(choice (const :tag "RFC 5322 formatted \"first last <address>\"" nil) + (function :tag "RFC 5322 phrase/comment formatting function") + (list :tag "Format string (deprecated)" + (string :tag "Format String") + (repeat :inline t + :tag "Attributes" + (choice + :tag "Attribute" + (const :menu-tag "First Name" :tag "First Name" firstname) + (const :menu-tag "Surname" :tag "Surname" name) + (const :menu-tag "Email Address" :tag "Email Address" email) + (const :menu-tag "Phone" :tag "Phone" phone) + (symbol :menu-tag "Other") + (symbol :tag "Attribute name"))))) + :version "29.1") (defcustom eudc-inline-expansion-servers 'server-then-hotlist "Which servers to contact for the expansion of inline queries. @@ -252,6 +283,7 @@ If nil, query all servers available from `eudc-inline-expansion-servers'." (firstname . "First Name") (cn . "Full Name") (sn . "Surname") + (name . "Surname") (givenname . "First Name") (ou . "Unit") (labeledurl . "URL") @@ -394,6 +426,15 @@ BBDB fields. SPECs are sexps which are evaluated: (symbol :tag "BBDB Field") (sexp :tag "Conversion Spec")))) +(defcustom eudc-ldap-no-wildcard-attributes + '(objectclass objectcategory) + "LDAP attributes which are always searched for without wildcard character. +This is the list of special dictionary-valued attributes, where +wildcarded search may fail. For example, it fails with +objectclass in Active Directory servers." + :type '(repeat (symbol :tag "Directory attribute"))) + + ;;}}} ;;{{{ BBDB Custom Group diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 6831c4ffe3d..9208e40a730 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -48,6 +48,7 @@ (require 'wid-edit) (require 'cl-lib) (require 'eudc-vars) +(eval-when-compile (require 'subr-x)) ;;{{{ Internal cooking @@ -55,16 +56,14 @@ (defvar eudc-form-widget-list nil) -(defvar eudc-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-keymap) - (define-key map "q" #'kill-current-buffer) - (define-key map "x" #'kill-current-buffer) - (define-key map "f" #'eudc-query-form) - (define-key map "b" #'eudc-try-bbdb-insert) - (define-key map "n" #'eudc-move-to-next-record) - (define-key map "p" #'eudc-move-to-previous-record) - map)) +(defvar-keymap eudc-mode-map + :parent widget-keymap + "q" #'kill-current-buffer + "x" #'kill-current-buffer + "f" #'eudc-query-form + "b" #'eudc-try-bbdb-insert + "n" #'eudc-move-to-next-record + "p" #'eudc-move-to-previous-record) (defvar mode-popup-menu) @@ -162,6 +161,75 @@ Value is the new string." newtext))) (concat rtn-str (substring str start)))) + +(defconst eudc-rfc5322-atext-token "[:alpha:][:digit:]!#$%&'*+/=?^_`{|}~-" + "Printable US-ASCII characters not including specials. Used for atoms.") + +(defconst eudc-rfc5322-wsp-token " \t" + "Non-folding white space.") + +(defconst eudc-rfc5322-fwsp-token + (concat eudc-rfc5322-wsp-token "\n") + "Folding white space.") + +(defconst eudc-rfc5322-cctext-token "\u005D-\u007E\u002A-\u005B\u0021-\u0027" + "Printable US-ASCII characters not including \"(\", \")\", or \"\\\".") + +(defun eudc-rfc5322-quote-phrase (string) + "Quote STRING if it needs quoting as a phrase in a header." + (if (string-match + (concat "[^" eudc-rfc5322-wsp-token eudc-rfc5322-atext-token "]") + string) + (concat "\"" string "\"") + string)) + +(defun eudc-rfc5322-valid-comment-p (string) + "Check if STRING can be used as comment in a header." + (if (string-match + (concat "[^" eudc-rfc5322-cctext-token eudc-rfc5322-fwsp-token "]") + string) + nil + t)) + +(defun eudc-rfc5322-make-address (address &optional firstname name comment) + "Create a valid address specification according to RFC5322. +RFC5322 address specifications are used in message header fields +to indicate senders and recipients of messages. They generally +have one of the forms: + +ADDRESS +ADDRESS (COMMENT) +PHRASE <ADDRESS> +PHRASE <ADDRESS> (COMMENT) + +The arguments FIRSTNAME and NAME are combined to form PHRASE. +PHRASE is enclosed in double quotes if necessary. + +COMMENT is omitted if it contains any symbols outside the +permitted set `eudc-rfc5322-cctext-token'." + (if (and address + (not (string-blank-p address))) + (let ((result address) + (name-given (and name + (not (string-blank-p name)))) + (firstname-given (and firstname + (not (string-blank-p firstname)))) + (valid-comment-given (and comment + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p comment)))) + (if (or name-given firstname-given) + (let ((phrase (string-trim (concat firstname " " name)))) + (setq result + (concat + (eudc-rfc5322-quote-phrase phrase) + " <" result ">")))) + (if valid-comment-given + (setq result + (concat result " (" comment ")"))) + result) + ;; nil or empty address, nothing to return + nil)) + ;;}}} ;;{{{ Server and Protocol Variable Routines @@ -298,8 +366,8 @@ accordingly. Otherwise it is set to its EUDC default binding." ;;}}} -;; Add PROTOCOL to the list of supported protocols (defun eudc-register-protocol (protocol) + "Add PROTOCOL to the list of supported protocols." (unless (memq protocol eudc-supported-protocols) (setq eudc-supported-protocols (cons protocol eudc-supported-protocols)) @@ -313,32 +381,51 @@ accordingly. Otherwise it is set to its EUDC default binding." (cons protocol eudc-known-protocols)))) -(defun eudc-translate-query (query) +(defun eudc-translate-query (query &optional reverse) "Translate attribute names of QUERY. The translation is done according to -`eudc-protocol-attributes-translation-alist'." +`eudc-protocol-attributes-translation-alist'. + +When REVERSE is nil or omitted, the attribute names are +translated from EUDC generic names to protocol-specific +names. When REVERSE is non-nil, the translation is from +protocol-specific names back to EUDC generic names." (if eudc-protocol-attributes-translation-alist (mapcar (lambda (attribute) - (let ((trans (assq (car attribute) - (symbol-value eudc-protocol-attributes-translation-alist)))) + (let ((trans + (if reverse + (rassq (car attribute) + (symbol-value eudc-protocol-attributes-translation-alist)) + (assq (car attribute) + (symbol-value eudc-protocol-attributes-translation-alist))))) (if trans - (cons (cdr trans) (cdr attribute)) + (cons (if reverse (car trans) (cdr trans)) + (cdr attribute)) attribute))) query) query)) -(defun eudc-translate-attribute-list (list) +(defun eudc-translate-attribute-list (list &optional reverse) "Translate a list of attribute names LIST. The translation is done according to -`eudc-protocol-attributes-translation-alist'." +`eudc-protocol-attributes-translation-alist'. + +When REVERSE is nil or omitted, the attribute names are +translated from EUDC generic names to protocol-specific +names. When REVERSE is non-nil, the translation is from +protocol-specific names back to EUDC generic names." (if eudc-protocol-attributes-translation-alist (let (trans) (mapcar (lambda (attribute) - (setq trans (assq attribute - (symbol-value eudc-protocol-attributes-translation-alist))) - (if trans - (cdr trans) - attribute)) + (setq trans + (if reverse + (rassq attribute + (symbol-value eudc-protocol-attributes-translation-alist)) + (assq attribute + (symbol-value eudc-protocol-attributes-translation-alist)))) + (if trans + (if reverse (car trans) (cdr trans)) + attribute)) list)) list)) @@ -651,7 +738,7 @@ server for future sessions." (defun eudc-get-email (name &optional error) "Get the email field of NAME from the directory server. If ERROR is non-nil, report an error if there is none." - (interactive "sName: \np") + (interactive "sSurname: \np") (or eudc-server (call-interactively 'eudc-set-server)) (let ((result (eudc-query (list (cons 'name name)) '(email))) @@ -669,7 +756,7 @@ If ERROR is non-nil, report an error if there is none." (defun eudc-get-phone (name &optional error) "Get the phone field of NAME from the directory server. If ERROR is non-nil, report an error if there is none." - (interactive "sName: \np") + (interactive "sSurname: \np") (or eudc-server (call-interactively 'eudc-set-server)) (let ((result (eudc-query (list (cons 'name name)) '(phone))) @@ -741,9 +828,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. @@ -751,10 +847,12 @@ 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'." +see `eudc-inline-expansion-servers'. If TRY-ALL-SERVERS is +non-nil, collect results from all servers." (interactive) (let* ((end (point)) (beg (save-excursion @@ -764,13 +862,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) @@ -787,15 +885,65 @@ 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-format-inline-expansion-result (res query-attrs) + "Format a query result according to `eudc-inline-expansion-format'." + (cond + ;; format string + ((consp eudc-inline-expansion-format) + (string-trim (apply #'format + (car eudc-inline-expansion-format) + (mapcar + (lambda (field) + (or (cdr (assq field res)) + "")) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + + ;; formatting function + ((functionp eudc-inline-expansion-format) + (let ((addr (cdr (assq (nth 2 query-attrs) res))) + (ucontent (funcall eudc-inline-expansion-format res))) + (if (and ucontent + (listp ucontent)) + (let* ((phrase (car ucontent)) + (comment (cadr ucontent)) + (phrase-given + (and phrase + (stringp phrase) + (not (string-blank-p phrase)))) + (valid-comment-given + (and comment + (stringp comment) + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p + comment)))) + (eudc-rfc5322-make-address + addr nil + (if phrase-given phrase nil) + (if valid-comment-given comment nil))) + (progn + (error "Error: the function referenced by \ +`eudc-inline-expansion-format' is expected to return a list.") + nil)))) + + ;; fallback behaviour (nil function, or non-matching type) + (t + (let ((fname (cdr (assq (nth 0 query-attrs) res))) + (lname (cdr (assq (nth 1 query-attrs) res))) + (addr (cdr (assq (nth 2 query-attrs) res)))) + (eudc-rfc5322-make-address addr fname lname))))) + +;;;###autoload +(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. 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. +matches before returning them. 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 @@ -812,6 +960,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 @@ -823,7 +972,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)))))) @@ -833,46 +982,46 @@ 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* ((query-attrs (eudc-translate-attribute-list + (if (consp eudc-inline-expansion-format) + (cdr eudc-inline-expansion-format) + '(firstname name email)))) + (response + (eudc-query + (eudc-format-query query-words (car query-formats)) + query-attrs))) + (when response + ;; Format response. + (dolist (r response) + (let ((response-string + (eudc-format-inline-expansion-result r query-attrs))) + (if response-string + (cl-pushnew response-string response-strings + :test #'equal)))) + (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)) @@ -894,7 +1043,10 @@ queries the server for the existing fields and displays a corresponding form." pt) (switch-to-buffer buffer) (let ((inhibit-read-only t)) + (remove-hook 'after-change-functions 'widget-after-change t) + (delete-all-overlays) (erase-buffer) + (add-hook 'after-change-functions 'widget-after-change nil t) (kill-all-local-variables) (make-local-variable 'eudc-form-widget-list) (widget-insert "Directory Query Form\n") @@ -1052,6 +1204,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 @@ -1086,6 +1240,7 @@ queries the server for the existing fields and displays a corresponding form." :help "Set the directory server to SERVER using PROTOCOL"])) (defun eudc-menu () + "Return easy menu for EUDC." (let (command) (append '("Directory Servers") (list @@ -1117,6 +1272,7 @@ queries the server for the existing fields and displays a corresponding form." eudc-tail-menu))) (defun eudc-install-menu () + "Install EUDC menu." (define-key global-map [menu-bar tools directory-search] diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index 60a3adbc34f..e71dc238d08 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -233,7 +233,7 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs)))) (if (car query-attrs) ;; BEWARE: `bbdb-search' is a macro! - (setq records (eval `(bbdb-search records ,@bbdb-attrs) t))) + (setq records (eval `(bbdb-search (quote ,records) ,@bbdb-attrs) t))) (setq query-attrs (cdr query-attrs))) (mapc (lambda (record) (setq filtered (eudc-filter-duplicate-attributes record)) diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 365dace961a..1201c84f2d3 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -151,16 +151,20 @@ attribute names are returned. Default to `person'." (interactive) (or eudc-server (call-interactively 'eudc-set-server)) - (let ((ldap-host-parameters-alist - (list (cons eudc-server - '(scope subtree sizelimit 1))))) - (mapcar #'eudc-ldap-cleanup-record-filtering-addresses - (ldap-search - (eudc-ldap-format-query-as-rfc1558 - (list (cons "objectclass" - (or objectclass - "person")))) - eudc-server nil t)))) + (let ((plist (copy-sequence + (alist-get eudc-server ldap-host-parameters-alist + nil nil #'equal)))) + (plist-put plist 'scope 'subtree) + (plist-put plist 'sizelimit '1) + (let ((ldap-host-parameters-alist + (list (cons eudc-server plist)))) + (mapcar #'eudc-ldap-cleanup-record-filtering-addresses + (ldap-search + (eudc-ldap-format-query-as-rfc1558 + (list (cons 'objectclass + (or objectclass + "person")))) + eudc-server nil t))))) (defun eudc-ldap-escape-query-special-chars (string) "Value is STRING with characters forbidden in LDAP queries escaped." @@ -178,12 +182,17 @@ attribute names are returned. Default to `person'." (defun eudc-ldap-format-query-as-rfc1558 (query) "Format the EUDC QUERY list as a RFC1558 LDAP search filter." - (let ((formatter (lambda (item &optional wildcard) - (format "(%s=%s)" - (car item) - (concat - (eudc-ldap-escape-query-special-chars - (cdr item)) (if wildcard "*" "")))))) + (let ((formatter + (lambda (item &optional wildcard) + (format "(%s=%s)" + (car item) + (concat + (eudc-ldap-escape-query-special-chars + (cdr item)) + (if (and wildcard + (not (memq (car item) + eudc-ldap-no-wildcard-attributes))) + "*" "")))))) (format "(&%s)" (concat (mapconcat formatter (butlast query) "") diff --git a/lisp/net/eww.el b/lisp/net/eww.el index eaa5c119385..4dbd5de2ef7 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)) @@ -191,7 +192,7 @@ determine the renaming scheme, as follows: user-defined function: (defun my-eww-rename-buffer () - (when (eq major-mode 'eww-mode) + (when (eq major-mode \\='eww-mode) (when-let ((string (or (plist-get eww-data :title) (plist-get eww-data :url)))) (format \"*%s*\" string)))) @@ -310,7 +311,7 @@ parameter, and should return the (possibly) transformed URL." (defvar eww-accept-content-types "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" - "Value used for the HTTP 'Accept' header.") + "Value used for the HTTP \"Accept\" header.") (defvar-keymap eww-link-keymap :parent shr-map @@ -362,7 +363,9 @@ 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 -killed after rendering." +killed after rendering. + +For more information, see Info node `(eww) Top'." (interactive (let ((uris (eww-suggested-uris))) (list (read-string (format-prompt "Enter URL or keywords" @@ -487,22 +490,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 () @@ -833,7 +835,7 @@ The renaming scheme is performed in accordance with (when url (setq url (propertize url 'face 'variable-pitch)) (let* ((parsed (url-generic-parse-url url)) - (host-length (shr-string-pixel-width + (host-length (string-pixel-width (propertize (format "%s://%s" (url-type parsed) (url-host parsed)) @@ -842,17 +844,17 @@ The renaming scheme is performed in accordance with (cond ;; The host bit is wider than the window, so nix ;; the title. - ((> (+ host-length (shr-string-pixel-width "xxxxx")) width) + ((> (+ host-length (string-pixel-width "xxxxx")) width) (setq title "")) ;; Trim the title. - ((> (+ (shr-string-pixel-width (concat title "xx")) + ((> (+ (string-pixel-width (concat title "xx")) host-length) width) (setq title (concat (eww--limit-string-pixelwise title (- width host-length - (shr-string-pixel-width + (string-pixel-width (propertize "...: " 'face 'variable-pitch)))) (propertize "..." 'face 'variable-pitch))))))) @@ -932,9 +934,9 @@ The renaming scheme is performed in accordance with (defun eww-links-at-point () "Return list of URIs, if any, linked at point." - (remq nil - (list (get-text-property (point) 'shr-url) - (get-text-property (point) 'image-url)))) + (seq-filter #'stringp + (list (get-text-property (point) 'shr-url) + (get-text-property (point) 'image-url)))) (defun eww-view-source () "View the HTML source code of the current page." @@ -1204,7 +1206,10 @@ 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))) + +(function-put 'eww-browse-url 'browse-url-browser-kind 'internal) (defun eww-back-url () "Go to the previously displayed page." @@ -1291,9 +1296,16 @@ 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. @@ -1847,7 +1859,7 @@ The browser to used is specified by the (replace-regexp-in-string ".utm_.*" "" url)) (defun eww--transform-url (url) - "Appy `eww-url-transformers'." + "Apply `eww-url-transformers'." (when url (dolist (func eww-url-transformers) (setq url (funcall func url))) @@ -2045,7 +2057,9 @@ If CHARSET is nil then use UTF-8." (defun eww-write-bookmarks () (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory) (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") - (pp eww-bookmarks (current-buffer)))) + (let ((print-length nil) + (print-level nil)) + (pp eww-bookmarks (current-buffer))))) (defun eww-read-bookmarks (&optional error-out) "Read bookmarks from `eww-bookmarks'. @@ -2499,6 +2513,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/ldap.el b/lisp/net/ldap.el index ce6c270e0bc..0f2943cbb03 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -54,7 +54,7 @@ a separator." Initialized from the LDAP library at build time. Default value is 389." :type '(choice (const :tag "Use library default" nil) - (integer :tag "Port number"))) + (natnum :tag "Port number"))) (defcustom ldap-default-base nil "Default base for LDAP searches. @@ -148,7 +148,7 @@ Valid properties include: "The name of the ldapsearch command line program." :type '(string :tag "`ldapsearch' Program")) -(defcustom ldap-ldapsearch-args '("-LL" "-tt") +(defcustom ldap-ldapsearch-args '("-LLL" "-tt") "A list of additional arguments to pass to `ldapsearch'." :type '(repeat :tag "`ldapsearch' Arguments" (string :tag "Argument"))) @@ -663,7 +663,7 @@ an alist of attribute/value pairs." (while (not (memq (process-status proc) '(exit signal))) (sit-for 0.1)) (let ((status (process-exit-status proc))) - (when (not (eq status 0)) + (when (not (memql status '(0 4))) ; 4 = Size limit exceeded ;; Handle invalid credentials exit status specially ;; for ldap-password-read. (if (eq status 49) @@ -682,7 +682,7 @@ an alist of attribute/value pairs." (while (re-search-forward (concat "[\t\n\f]+ \\|" ldap-ldapsearch-password-prompt-regexp) nil t) - (replace-match "" nil nil)) + (replace-match "")) (goto-char (point-min)) (if (looking-at "usage") @@ -691,7 +691,6 @@ an alist of attribute/value pairs." ;; Skip error message when retrieving attribute list (if (looking-at "Size limit exceeded") (forward-line 1)) - (if (looking-at "version:") (forward-line 1)) ;bug#12724. (while (progn (skip-chars-forward " \t\n") (not (eobp))) @@ -699,7 +698,7 @@ an alist of attribute/value pairs." (forward-line 1) (while (looking-at "^\\([A-Za-z][-A-Za-z0-9]*\ \\|[0-9]+\\(?:\\.[0-9]+\\)*\\)\\(;[-A-Za-z0-9]+\\)*[=:\t ]+\ -\\(<[\t ]*file://\\)\\(.*\\)$") +\\(<[\t ]*file://\\)?\\(.*\\)$") (setq name (match-string 1) value (match-string 4)) ;; Need to handle file:///D:/... as generated by OpenLDAP @@ -724,7 +723,6 @@ an alist of attribute/value pairs." (record (push (nreverse record) result))) (setq record nil) - (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) (setq numres (1+ numres))) (message "Parsing results... done") diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index bf3c8edd1e3..8ba7f1bec3d 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -319,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 @@ -439,9 +440,10 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ("/usr/local/etc/mailcap" system))))) (when (stringp path) (setq path (mapcar #'list (split-string path path-separator t)))) - (when (seq-some (lambda (f) - (file-has-changed-p (car f) 'mail-parse-mailcaps)) - path) + (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 @@ -1096,11 +1098,12 @@ For instance, `image/png' will result in `png'." (mailcap-parse-mimetypes) (let* ((all-mime-type ;; All unique MIME types from file extensions - (delete-dups - (mapcar (lambda (file) - (mailcap-extension-to-mime - (file-name-extension file t))) - files))) + (delq nil + (delete-dups + (mapcar (lambda (file) + (mailcap-extension-to-mime + (file-name-extension file t))) + files)))) (all-mime-info ;; All MIME info lists (delete-dups @@ -1174,34 +1177,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/mairix.el b/lisp/net/mairix.el index d84763b1626..0b99d2a0b7c 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -743,21 +743,20 @@ VALUES may contain values for editable fields from current article." ;;;; Major mode for editing/deleting/saving searches -(defvar mairix-searches-mode-map - (let ((map (make-keymap))) - (define-key map [(return)] 'mairix-select-search) - (define-key map [(down)] 'mairix-next-search) - (define-key map [(up)] 'mairix-previous-search) - (define-key map [(right)] 'mairix-next-search) - (define-key map [(left)] 'mairix-previous-search) - (define-key map "\C-p" 'mairix-previous-search) - (define-key map "\C-n" 'mairix-next-search) - (define-key map [(q)] 'mairix-select-quit) - (define-key map [(e)] 'mairix-select-edit) - (define-key map [(d)] 'mairix-select-delete) - (define-key map [(s)] 'mairix-select-save) - map) - "`mairix-searches-mode' keymap.") +(defvar-keymap mairix-searches-mode-map + :doc "`mairix-searches-mode' keymap." + :full t + "<return>" #'mairix-select-search + "<down>" #'mairix-next-search + "<up>" #'mairix-previous-search + "<right>" #'mairix-next-search + "<left>" #'mairix-previous-search + "C-p" #'mairix-previous-search + "C-n" #'mairix-next-search + "q" #'mairix-select-quit + "e" #'mairix-select-edit + "d" #'mairix-select-delete + "s" #'mairix-select-save) (defvar mairix-searches-mode-font-lock-keywords '(("^\\([0-9]+\\)" diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index 411b6ed4132..c7ff175e08e 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -23,11 +23,10 @@ ;;; Commentary: -;; ;; There are three main areas of functionality: ;; ;; * Wrap common network utility programs (ping, traceroute, netstat, -;; nslookup, arp, route). Note that these wrappers are of the diagnostic +;; nslookup, arp, route). Note that these wrappers are of the diagnostic ;; functions of these programs only. ;; ;; * Implement some very basic protocols in Emacs Lisp (finger and whois) @@ -39,7 +38,7 @@ ;;; Code: ;; On some systems, programs like ifconfig are not in normal user -;; path, but rather in /sbin, /usr/sbin, etc (but non-root users can +;; path, but rather in /sbin, /usr/sbin, etc. (but non-root users can ;; still use them for queries). Actually the trend these ;; days is for /sbin to be a symlink to /usr/sbin, but we still need to ;; search both for older systems. @@ -176,15 +175,6 @@ This variable is only used if the variable `comint-use-prompt-regexp' is non-nil." :type 'regexp) -(defcustom dig-program "dig" - "Program to query DNS information." - :type 'string) - -(defcustom dig-program-options nil - "Options for the dig program." - :type '(repeat string) - :version "26.1") - (defcustom ftp-program "ftp" "Program to run to do FTP transfers." :type 'string) @@ -280,6 +270,7 @@ This variable is only used if the variable (define-derived-mode net-utils-mode special-mode "NetworkUtil" "Major mode for interacting with an external network utility." + :interactive nil (setq-local font-lock-defaults '((net-utils-font-lock-keywords))) (setq-local revert-buffer-function #'net-utils--revert-function)) @@ -288,31 +279,6 @@ This variable is only used if the variable ;; Utility functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Simplified versions of some at-point functions from ffap.el. -;; It's not worth loading all of ffap just for these. -(defun net-utils-machine-at-point () - (let ((pt (point))) - (buffer-substring-no-properties - (save-excursion - (skip-chars-backward "-a-zA-Z0-9.") - (point)) - (save-excursion - (skip-chars-forward "-a-zA-Z0-9.") - (skip-chars-backward "." pt) - (point))))) - -(defun net-utils-url-at-point () - (let ((pt (point))) - (buffer-substring-no-properties - (save-excursion - (skip-chars-backward "--:=&?$+@-Z_a-z~#,%") - (skip-chars-forward "^A-Za-z0-9" pt) - (point)) - (save-excursion - (skip-chars-forward "--:=&?$+@-Z_a-z~#,%") - (skip-chars-backward ":;.,!?" pt) - (point))))) - (defun net-utils-remove-ctrl-m-filter (process output-string) "Remove trailing control Ms." (with-current-buffer (process-buffer process) @@ -464,7 +430,8 @@ This variable is only used if the variable If your system's ping continues until interrupted, you can try setting `ping-program-options'." (interactive - (list (read-from-minibuffer "Ping host: " (net-utils-machine-at-point)))) + (list (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Ping host" default) nil nil default)))) (let ((options (if ping-program-options (append ping-program-options (list host)) @@ -497,7 +464,8 @@ See also: `nslookup-host-ipv4', `nslookup-host-ipv6' for non-interactive versions of this function more suitable for use in Lisp code." (interactive - (list (read-from-minibuffer "Lookup host: " (net-utils-machine-at-point)) + (list (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Lookup host" default) nil nil default)) (if current-prefix-arg (read-from-minibuffer "Name server: ")))) (let ((options (append nslookup-program-options (list host) @@ -589,14 +557,12 @@ This command uses `nslookup-program' to look up DNS records." (autoload 'comint-mode "comint" nil t) -(defvar nslookup-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\t" #'completion-at-point) - map)) +(defvar-keymap nslookup-mode-map + "TAB" #'completion-at-point) -;; Using a derived mode gives us keymaps, hooks, etc. (define-derived-mode nslookup-mode comint-mode "Nslookup" "Major mode for interacting with the nslookup program." + :interactive nil (setq-local font-lock-defaults '((nslookup-font-lock-keywords))) (setq comint-prompt-regexp nslookup-prompt-regexp) @@ -611,7 +577,8 @@ Interactively, prompt for NAME-SERVER if invoked with prefix argument. This command uses `dns-lookup-program' for looking up the DNS information." (interactive - (list (read-from-minibuffer "Lookup host: " (net-utils-machine-at-point)) + (list (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Lookup host" default) nil nil default)) (if current-prefix-arg (read-from-minibuffer "Name server: ")))) (let ((options (append dns-lookup-program-options (list host) @@ -633,20 +600,12 @@ DNS resolution. Interactively, prompt for NAME-SERVER if invoked with prefix argument. This command uses `dig-program' for looking up the DNS information." + (declare (obsolete dig "29.1")) (interactive - (list (read-from-minibuffer "Lookup host: " (net-utils-machine-at-point)) + (list (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Lookup host" default) nil nil default)) (if current-prefix-arg (read-from-minibuffer "Name server: ")))) - (let ((options - (append dig-program-options (list host) - (if name-server (list (concat "@" name-server)))))) - (net-utils-run-program - "Dig" - (concat "** " - (mapconcat #'identity - (list "Dig" host dig-program) - " ** ")) - dig-program - options))) + (dig host nil nil nil nil name-server)) (autoload 'comint-exec "comint") (declare-function comint-watch-for-password-prompt "comint" (string)) @@ -656,9 +615,8 @@ This command uses `dig-program' for looking up the DNS information." (defun ftp (host) "Run `ftp-program' to connect to HOST." (interactive - (list - (read-from-minibuffer - "Ftp to Host: " (net-utils-machine-at-point)))) + (list (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Ftp to Host" default) nil nil default)))) (let ((buf (get-buffer-create (concat "*ftp [" host "]*")))) (set-buffer buf) (ftp-mode) @@ -668,14 +626,12 @@ This command uses `dig-program' for looking up the DNS information." (list host))) (pop-to-buffer buf))) -(defvar ftp-mode-map - (let ((map (make-sparse-keymap))) - ;; Occasionally useful - (define-key map "\t" #'completion-at-point) - map)) +(defvar-keymap ftp-mode-map + "TAB" #'completion-at-point) (define-derived-mode ftp-mode comint-mode "FTP" "Major mode for interacting with the ftp program." + :interactive nil (setq comint-prompt-regexp ftp-prompt-regexp) (setq comint-input-autoexpand t) ;; Only add the password-prompting hook if it's not already in the @@ -695,8 +651,8 @@ This command uses `dig-program' for looking up the DNS information." This command uses `smbclient-program' to connect to HOST." (interactive (list - (read-from-minibuffer - "Connect to Host: " (net-utils-machine-at-point)) + (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Connect to Host" default) nil nil default)) (read-from-minibuffer "SMB Service: "))) (let* ((name (format "smbclient [%s\\%s]" host service)) (buf (get-buffer-create (concat "*" name "*"))) @@ -714,8 +670,8 @@ This command uses `smbclient-program' to connect to HOST." This command uses `smbclient-program' to connect to HOST." (interactive (list - (read-from-minibuffer - "Connect to Host: " (net-utils-machine-at-point)))) + (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Connect to Host" default) nil nil default)))) (let ((buf (get-buffer-create (format "*SMB Shares on %s*" host)))) (set-buffer buf) (smbclient-mode) @@ -725,6 +681,7 @@ This command uses `smbclient-program' to connect to HOST." (define-derived-mode smbclient-mode comint-mode "smbclient" "Major mode for interacting with the smbclient program." + :interactive nil (setq comint-prompt-regexp smbclient-prompt-regexp) (setq comint-input-autoexpand t) ;; Only add the password-prompting hook if it's not already in the @@ -813,15 +770,15 @@ and `network-connection-service-alist', which see." ;; uses a string like "pbreton@cs.umb.edu", we won't ask for the ;; host name. If we don't see an "@", we'll prompt for the host. (interactive - (let* ((answer (read-from-minibuffer "Finger User: " - (net-utils-url-at-point))) + (let* ((answer (let ((default (ffap-url-at-point))) + (read-string (format-prompt "Finger User" default) nil nil default))) (index (string-match (regexp-quote "@") answer))) (if index (list (substring answer 0 index) (substring answer (1+ index))) (list answer - (read-from-minibuffer "At Host: " - (net-utils-machine-at-point)))))) + (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "At Host" default) nil nil default)))))) (let* ((user-and-host (concat user "@" host)) (process-name (concat "Finger [" user-and-host "]")) (regexps finger-X.500-host-regexps) @@ -940,10 +897,9 @@ The port is deduced from `network-connection-service-alist'." ;;; General Network connection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Using a derived mode gives us keymaps, hooks, etc. -(define-derived-mode - network-connection-mode comint-mode "Network-Connection" - "Major mode for interacting with the `network-connection' program.") +(define-derived-mode network-connection-mode comint-mode "Network-Connection" + "Major mode for interacting with the `network-connection' program." + :interactive nil) (defun network-connection-mode-setup (host service) (setq-local network-connection-host host) @@ -955,7 +911,8 @@ The port is deduced from `network-connection-service-alist'." This command uses `network-connection-service-alist', which see." (interactive (list - (read-from-minibuffer "Host: " (net-utils-machine-at-point)) + (let ((default (ffap-machine-at-point))) + (read-string (format-prompt "Host" default) nil nil default)) (completing-read "Service: " (mapcar (lambda (elt) @@ -1008,6 +965,9 @@ This command uses `network-connection-service-alist', which see." (and old-comint-input-ring (setq comint-input-ring old-comint-input-ring))))) +(define-obsolete-function-alias 'net-utils-machine-at-point #'ffap-machine-at-point "29.1") +(define-obsolete-function-alias 'net-utils-url-at-point #'ffap-url-at-point "29.1") + (provide 'net-utils) ;;; net-utils.el ends here diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index a62a7bd8b7d..5ae2df769a2 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -40,7 +40,6 @@ ;; Silence warnings (defvar newsticker-groups) -(defvar w3-mode-map) (defvar w3m-minor-mode-map) (defvar newsticker--retrieval-timer-list nil @@ -1697,11 +1696,11 @@ Checks list of active processes against list of newsticker processes." ;; ====================================================================== (defun newsticker--images-dir () "Return directory where feed images are saved." - (concat newsticker-dir "/images/")) + (expand-file-name "images/" newsticker-dir)) (defun newsticker--icons-dir () "Return directory where feed icons are saved." - (concat newsticker-dir "/icons/")) + (expand-file-name "icons/" newsticker-dir)) (defun newsticker--image-get (feed-name filename directory url) "Get image for FEED-NAME by returning FILENAME from DIRECTORY. @@ -2114,7 +2113,7 @@ FEED is a symbol!" (defun newsticker--cache-dir () "Return directory for saving cache data." - (concat newsticker-dir "/feeds")) + (expand-file-name "feeds/" newsticker-dir)) (defun newsticker--cache-save () "Save cache data for all feeds." @@ -2125,13 +2124,15 @@ FEED is a symbol!" (defun newsticker--cache-save-feed (feed) "Save cache data for FEED." - (let ((dir (concat (newsticker--cache-dir) "/" (symbol-name (car feed))))) + (let ((dir (file-name-as-directory + (expand-file-name (symbol-name (car feed)) + (newsticker--cache-dir))))) (unless (file-directory-p dir) (make-directory dir t)) (let ((coding-system-for-write 'utf-8)) - (with-temp-file (concat dir "/data") + (with-temp-file (expand-file-name "data" dir) (insert ";; -*- coding: utf-8 -*-\n") - (insert (prin1-to-string (cdr feed))))))) + (prin1 (cdr feed) (current-buffer) t))))) (defun newsticker--cache-read () "Read cache data." @@ -2141,7 +2142,9 @@ FEED is a symbol!" (defun newsticker--cache-read-feed (feed-name) "Read cache data for feed named FEED-NAME." - (let ((file-name (concat (newsticker--cache-dir) "/" feed-name "/data")) + (let ((file-name (expand-file-name + "data" (expand-file-name + feed-name (newsticker--cache-dir)))) (coding-system-for-read 'utf-8)) (when (file-exists-p file-name) (with-temp-buffer @@ -2213,8 +2216,7 @@ Export subscriptions to a buffer in OPML Format." (newsticker--opml-insert-feed (car f) 4))) (insert " </body>\n</opml>\n"))) (pop-to-buffer "*OPML Export*") - (when (fboundp 'sgml-mode) - (sgml-mode))) + (sgml-mode)) (defun newsticker--opml-insert-elt (elt depth) "Insert an OPML ELT with indentation level DEPTH." @@ -2334,14 +2336,19 @@ This function just prints out the values of the FEEDNAME and title of the ITEM." "Download the first image. If FEEDNAME equals \"imagefeed\" download the first image URL found in the description=contents of ITEM to the directory -\"~/tmp/newsticker/FEEDNAME/TITLE\" where TITLE is the title of -the item." +`temporary-file-directory'/newsticker/FEEDNAME/TITLE where TITLE +is the title of the item." (when (string= feedname "imagefeed") (let ((title (newsticker--title item)) (desc (newsticker--desc item))) (when (string-match "<img src=\"\\(http://[^ \"]+\\)\"" desc) (let ((url (substring desc (match-beginning 1) (match-end 1))) - (temp-dir (concat "~/tmp/newsticker/" feedname "/" title)) + (temp-dir (file-name-as-directory + (expand-file-name + title (expand-file-name + feedname (expand-file-name + "newsticker" + temporary-file-directory))))) (org-dir default-directory)) (unless (file-directory-p temp-dir) (make-directory temp-dir t)) @@ -2355,7 +2362,8 @@ the item." (defun newsticker-download-enclosures (feedname item) "In all feeds download the enclosed object of the news ITEM. -The object is saved to the directory \"~/tmp/newsticker/FEEDNAME/TITLE\", which +The object is saved to the directory +`temporary-file-directory'/newsticker/FEEDNAME/TITLE, which is created if it does not exist. TITLE is the title of the news item. Argument FEEDNAME is ignored. This function is suited for adding it to `newsticker-new-item-functions'." @@ -2363,7 +2371,12 @@ This function is suited for adding it to `newsticker-new-item-functions'." (enclosure (newsticker--enclosure item))) (when enclosure (let ((url (cdr (assoc 'url enclosure))) - (temp-dir (concat "~/tmp/newsticker/" feedname "/" title)) + (temp-dir (file-name-as-directory + (expand-file-name + title (expand-file-name + feedname (expand-file-name + "newsticker" + temporary-file-directory))))) (org-dir default-directory)) (unless (file-directory-p temp-dir) (make-directory temp-dir t)) diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index df574dfa2f4..4eb6f6c695e 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -37,7 +37,6 @@ (require 'xml) ;; Silence warnings -(defvar w3-mode-map) (defvar w3m-minor-mode-map) ;; ====================================================================== @@ -1232,7 +1231,6 @@ item-retrieval time is added as well." (newsticker--buffer-do-insert-text item 'desc feed-name-symbol)) (defvar w3m-fill-column) -(defvar w3-maximum-line-length) (defun newsticker--buffer-do-insert-text (item type feed-name-symbol) "Actually insert contents of news item, format it, render it and all that. @@ -1366,19 +1364,14 @@ FEED-NAME-SYMBOL tells to which feed this item belongs." "</?[A-Za-z1-6]*\\|&#?[A-Za-z0-9]+;" pos-text-end t) ;; (message "%s" (newsticker--title item)) (let ((w3m-fill-column (if newsticker-use-full-width - -1 fill-column)) - (w3-maximum-line-length - (if newsticker-use-full-width nil fill-column))) + -1 fill-column))) (save-excursion (funcall newsticker-html-renderer pos-text-start pos-text-end))) - (cond ((eq newsticker-html-renderer 'w3m-region) - (add-text-properties pos (point-max) - (list 'keymap - w3m-minor-mode-map))) - ((eq newsticker-html-renderer 'w3-region) - (add-text-properties pos (point-max) - (list 'keymap w3-mode-map)))) + (when (eq newsticker-html-renderer 'w3m-region) + (add-text-properties pos (point-max) + (list 'keymap + w3m-minor-mode-map))) (setq is-rendered-HTML t))) (error (message "Error: HTML rendering failed: %s, %s" diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el index 7e00ac93e75..4a7f0b8e3ee 100644 --- a/lisp/net/newst-reader.el +++ b/lisp/net/newst-reader.el @@ -112,18 +112,18 @@ window is used when filling. See also `newsticker-justification'." "Function for rendering HTML contents. If non-nil, newsticker.el will call this function whenever it finds HTML-like tags in item descriptions. -Possible functions include `shr-render-region', `w3m-region', `w3-region', and +Possible functions include `shr-render-region', `w3m-region', and `newsticker-htmlr-render'. -Newsticker automatically loads the respective package w3m, w3, or +Newsticker automatically loads the respective package w3m, or htmlr if this option is set." :type '(choice :tag "Function" (const :tag "None" nil) (const :tag "SHR" shr-render-region) - (const :tag "w3" w3-region) (const :tag "w3m" w3m-region) (const :tag "htmlr" newsticker-htmlr-render)) :set #'newsticker--set-customvar-formatting - :group 'newsticker-reader) + :group 'newsticker-reader + :version "29.1") (defcustom newsticker-date-format "(%A, %H:%M)" @@ -315,8 +315,6 @@ Return the image." (if newsticker-html-renderer (cond ((eq newsticker-html-renderer 'w3m-region) (require 'w3m)) - ((eq newsticker-html-renderer 'w3-region) - (require 'w3-auto)) ((eq newsticker-html-renderer 'newsticker-htmlr-render) (require 'htmlr)))) (funcall newsticker-frontend)) diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index 80d9fd1cef2..637f53e6550 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -106,13 +106,13 @@ applies to newsticker only." (defcustom newsticker-treeview-use-feed-name-from-url-list-in-treeview t - "Use the feed names from 'newsticker-url-list' for display in treeview." + "Use the feed names from `newsticker-url-list' for display in treeview." :version "28.1" :type 'boolean) (defcustom newsticker-treeview-use-feed-name-from-url-list-in-itemview t - "Use feed names from 'newsticker-url-list' in itemview." + "Use feed names from `newsticker-url-list' in itemview." :version "28.1" :type 'boolean) @@ -252,7 +252,6 @@ their id stays constant." (declare-function w3m-toggle-inline-images "ext:w3m" (&optional force no-cache)) (defvar w3m-fill-column) -(defvar w3-maximum-line-length) (defun newsticker--treeview-render-text (start end) "Render text between markers START and END." @@ -272,17 +271,13 @@ their id stays constant." "</?[A-Za-z1-6]*\\|&#?[A-Za-z0-9]+;" end t) ;; (message "%s" (newsticker--title item)) (let ((w3m-fill-column (if newsticker-use-full-width - -1 fill-column)) - (w3-maximum-line-length - (if newsticker-use-full-width nil fill-column))) + -1 fill-column))) (select-window (newsticker--treeview-item-window)) (save-excursion (funcall newsticker-html-renderer start end))) ;;(cond ((eq newsticker-html-renderer 'w3m-region) ;; (add-text-properties start end (list 'keymap ;; w3m-minor-mode-map))) - ;;((eq newsticker-html-renderer 'w3-region) - ;;(add-text-properties start end (list 'keymap w3-mode-map)))) (if (eq newsticker-html-renderer 'w3m-region) (w3m-toggle-inline-images t)) t))) @@ -608,14 +603,10 @@ If CLEAR-BUFFER is non-nil the list buffer is completely erased." (newsticker--treeview-list-update-faces) (goto-char (point-min)))) -(defvar newsticker-treeview-list-sort-button-map - (let ((map (make-sparse-keymap))) - (define-key map [header-line mouse-1] - #'newsticker--treeview-list-sort-by-column) - (define-key map [header-line mouse-2] - #'newsticker--treeview-list-sort-by-column) - map) - "Local keymap for newsticker treeview list window sort buttons.") +(defvar-keymap newsticker-treeview-list-sort-button-map + :doc "Local keymap for newsticker treeview list window sort buttons." + "<header-line> <mouse-1>" #'newsticker--treeview-list-sort-by-column + "<header-line> <mouse-2>" #'newsticker--treeview-list-sort-by-column) (defun newsticker--treeview-list-sort-by-column (&optional event) "Sort the newsticker list window buffer by the column clicked on. @@ -1257,20 +1248,20 @@ Note: does not update the layout." "Save treeview group settings." (interactive) (let ((coding-system-for-write 'utf-8) - (buf (find-file-noselect (concat newsticker-dir "/groups")))) + (buf (find-file-noselect (expand-file-name "groups" newsticker-dir)))) (when buf (with-current-buffer buf (setq buffer-undo-list t) (erase-buffer) (insert ";; -*- coding: utf-8 -*-\n") - (insert (prin1-to-string newsticker-groups)) + (prin1 newsticker-groups (current-buffer) t) (save-buffer) (kill-buffer))))) (defun newsticker--treeview-load () "Load treeview settings." (let* ((coding-system-for-read 'utf-8) - (filename (concat newsticker-dir "/groups")) + (filename (expand-file-name "groups" newsticker-dir)) (buf (and (file-exists-p filename) (find-file-noselect filename)))) (when buf @@ -1283,7 +1274,6 @@ Note: does not update the layout." (setq newsticker-groups nil))) (kill-buffer buf)))) - (defun newsticker-treeview-scroll-item () "Scroll current item." (interactive) @@ -2013,41 +2003,39 @@ Return t if groups have changed, nil otherwise." menu) "Map for newsticker item menu.") -(defvar newsticker-treeview-mode-map - (let ((map (make-sparse-keymap 'newsticker-treeview-mode-map))) - (define-key map " " #'newsticker-treeview-next-page) - (define-key map "a" #'newsticker-add-url) - (define-key map "b" #'newsticker-treeview-browse-url-item) - (define-key map "c" #'newsticker-treeview-customize-current-feed) - (define-key map "F" #'newsticker-treeview-prev-feed) - (define-key map "f" #'newsticker-treeview-next-feed) - (define-key map "g" #'newsticker-treeview-get-news) - (define-key map "G" #'newsticker-get-all-news) - (define-key map "i" #'newsticker-treeview-toggle-item-immortal) - (define-key map "j" #'newsticker-treeview-jump) - (define-key map "n" #'newsticker-treeview-next-item) - (define-key map "N" #'newsticker-treeview-next-new-or-immortal-item) - (define-key map "O" #'newsticker-treeview-mark-list-items-old) - (define-key map "o" #'newsticker-treeview-mark-item-old) - (define-key map "p" #'newsticker-treeview-prev-item) - (define-key map "P" #'newsticker-treeview-prev-new-or-immortal-item) - (define-key map "q" #'newsticker-treeview-quit) - (define-key map "S" #'newsticker-treeview-save-item) - (define-key map "s" #'newsticker-treeview-save) - (define-key map "u" #'newsticker-treeview-update) - (define-key map "v" #'newsticker-treeview-browse-url) - ;;(define-key map "\n" #'newsticker-treeview-scroll-item) - ;;(define-key map "\C-m" #'newsticker-treeview-scroll-item) - (define-key map "\M-m" #'newsticker-group-move-feed) - (define-key map "\M-a" #'newsticker-group-add-group) - (define-key map "\M-d" #'newsticker-group-delete-group) - (define-key map "\M-r" #'newsticker-group-rename-group) - (define-key map [M-down] #'newsticker-group-shift-feed-down) - (define-key map [M-up] #'newsticker-group-shift-feed-up) - (define-key map [M-S-down] #'newsticker-group-shift-group-down) - (define-key map [M-S-up] #'newsticker-group-shift-group-up) - map) - "Mode map for newsticker treeview.") +(defvar-keymap newsticker-treeview-mode-map + :doc "Mode map for newsticker treeview." + "SPC" #'newsticker-treeview-next-page + "a" #'newsticker-add-url + "b" #'newsticker-treeview-browse-url-item + "c" #'newsticker-treeview-customize-current-feed + "F" #'newsticker-treeview-prev-feed + "f" #'newsticker-treeview-next-feed + "g" #'newsticker-treeview-get-news + "G" #'newsticker-get-all-news + "i" #'newsticker-treeview-toggle-item-immortal + "j" #'newsticker-treeview-jump + "n" #'newsticker-treeview-next-item + "N" #'newsticker-treeview-next-new-or-immortal-item + "O" #'newsticker-treeview-mark-list-items-old + "o" #'newsticker-treeview-mark-item-old + "p" #'newsticker-treeview-prev-item + "P" #'newsticker-treeview-prev-new-or-immortal-item + "q" #'newsticker-treeview-quit + "S" #'newsticker-treeview-save-item + "s" #'newsticker-treeview-save + "u" #'newsticker-treeview-update + "v" #'newsticker-treeview-browse-url + ;;"C-j" #'newsticker-treeview-scroll-item + ;;"RET" #'newsticker-treeview-scroll-item + "M-m" #'newsticker-group-move-feed + "M-a" #'newsticker-group-add-group + "M-d" #'newsticker-group-delete-group + "M-r" #'newsticker-group-rename-group + "M-<down>" #'newsticker-group-shift-feed-down + "M-<up>" #'newsticker-group-shift-feed-up + "M-S-<down>" #'newsticker-group-shift-group-down + "M-S-<up>" #'newsticker-group-shift-group-up) (define-derived-mode newsticker-treeview-mode fundamental-mode "Newsticker TV" "Major mode for Newsticker Treeview. diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index 0f6dfb6ad46..de225d76dcc 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -59,7 +59,7 @@ (defcustom pop3-port 110 "POP3 port." :version "22.1" ;; Oort Gnus - :type 'number + :type 'natnum :group 'pop3) (defcustom pop3-password-required t @@ -88,7 +88,7 @@ valid value is `apop'." The lower the number, the more latency-sensitive the fetching will be. If your pop3 server doesn't support streaming at all, set this to 1." - :type 'number + :type 'natnum :version "24.1" :group 'pop3) diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index 598a7da0712..61cae43a88a 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -163,19 +163,17 @@ in your init file (after loading/requiring quickurl).") (defvar quickurl-urls nil "URL alist for use with `quickurl' and `quickurl-ask'.") -(defvar quickurl-list-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "a" #'quickurl-list-add-url) - (define-key map [(control m)] #'quickurl-list-insert-url) - (define-key map "u" #'quickurl-list-insert-naked-url) - (define-key map " " #'quickurl-list-insert-with-lookup) - (define-key map "l" #'quickurl-list-insert-lookup) - (define-key map "d" #'quickurl-list-insert-with-desc) - (define-key map [(control g)] #'quickurl-list-quit) - (define-key map "q" #'quickurl-list-quit) - (define-key map [mouse-2] #'quickurl-list-mouse-select) - map) - "Local keymap for a `quickurl-list-mode' buffer.") +(defvar-keymap quickurl-list-mode-map + :doc "Local keymap for a `quickurl-list-mode' buffer." + "a" #'quickurl-list-add-url + "RET" #'quickurl-list-insert-url + "u" #'quickurl-list-insert-naked-url + "SPC" #'quickurl-list-insert-with-lookup + "l" #'quickurl-list-insert-lookup + "d" #'quickurl-list-insert-with-desc + "C-g" #'quickurl-list-quit + "q" #'quickurl-list-quit + "<mouse-2>" #'quickurl-list-mouse-select) (defvar quickurl-list-buffer-name "*quickurl-list*" "Name for the URL listing buffer.") diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 9a1153b3c6a..54d7861f445 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -130,7 +130,7 @@ be displayed instead." (defcustom rcirc-default-port 6667 "The default port to connect to." - :type 'integer) + :type 'natnum) (defcustom rcirc-default-nick (user-login-name) "Your nick." @@ -267,6 +267,7 @@ The ARGUMENTS for each METHOD symbol are: Examples: ((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\") (\"Libera.Chat\" chanserv \"bob\" \"#bobland\" \"passwd99\") + (\"Libera.Chat\" certfp \"/path/to/key\" \"/path/to/cert\") (\"bitlbee\" bitlbee \"robert\" \"sekrit\") (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") (\"quakenet.org\" quakenet \"bobby\" \"sekrit\") @@ -433,6 +434,20 @@ will be killed." :version "28.1" :type 'boolean) +(defcustom rcirc-cycle-completion-flag nil + "Non-nil means to use cycling for completion in rcirc buffers. +See the Info node `(emacs) Completion Options' for background on +what cycling completion means." + :version "29.1" + :set (lambda (sym val) + (dolist (buf (match-buffers '(major-mode . rcirc-mode))) + (with-current-buffer buf + (if val + (setq-local completion-cycle-threshold t) + (kill-local-variable 'completion-cycle-threshold)))) + (set-default sym val)) + :type 'boolean) + (defvar-local rcirc-nick nil "The nickname used for the current connection.") @@ -560,8 +575,8 @@ If ARG is non-nil, instead prompt for connection parameters." (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)) @@ -757,18 +772,26 @@ SERVER-PLIST is the property list for the server." (yes-or-no-p "Encrypt connection?")) 'tls 'plain)) +(defvar rcirc-reconnect-delay) (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. Kill processes that have not received a server message since the last ping." (if (rcirc-process-list) (mapc (lambda (process) - (with-rcirc-process-buffer process - (when (not rcirc-connecting) - (rcirc-send-ctcp process - rcirc-nick - (format "KEEPALIVE %f" - (float-time)))))) + (with-rcirc-process-buffer process + (when (not rcirc-connecting) + (condition-case nil + (rcirc-send-ctcp process + rcirc-nick + (format "KEEPALIVE %f" + (float-time))) + (rcirc-closed-connection + (if (zerop rcirc-reconnect-delay) + (message "rcirc: Connection to %s closed" + (process-name process)) + (rcirc-reconnect process)) + (message "")))))) (rcirc-process-list)) ;; no processes, clean up timer (when (timerp rcirc-keepalive-timer) @@ -1060,17 +1083,18 @@ Note that the messages are stored in reverse order.") ;; expression and `rcirc-process-regexp'. (error "Malformed tag %S" tag)) (cons (match-string 1 tag) - (replace-regexp-in-string - (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) - (lambda (rep) - (concat (substring rep 0 -2) - (cl-case (aref rep (1- (length rep))) - (?: ";") - (?s " ") - (?\\ "\\\\") - (?r "\r") - (?n "\n")))) - (match-string 2 tag)))) + (when (match-string 2 tag) + (replace-regexp-in-string + (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) + (lambda (rep) + (concat (substring rep 0 -2) + (cl-case (aref rep (1- (length rep))) + (?: ";") + (?s " ") + (?\\ "\\\\") + (?r "\r") + (?n "\n")))) + (match-string 2 tag))))) (split-string tag-data ";")))) rcirc-message-tags)) (user (match-string 3 text)) @@ -1122,6 +1146,8 @@ used as the message body." "Check if PROCESS is open or running." (memq (process-status process) '(run open))) +(define-error 'rcirc-closed-connection "Network connection not open") + (defun rcirc-send-string (process &rest parts) "Send PROCESS a PARTS plus a newline. PARTS may contain a `:' symbol, to designate that the next string @@ -1139,8 +1165,7 @@ element in PARTS is a list, append it to PARTS." rcirc-encode-coding-system) "\n"))) (unless (rcirc--connection-open-p process) - (error "Network connection to %s is not open" - (process-name process))) + (signal 'rcirc-closed-connection process)) (rcirc-debug process string) (process-send-string process string))) @@ -1321,33 +1346,30 @@ The list is updated automatically by `defun-rcirc-command'.") 'set-rcirc-encode-coding-system "28.1") -(defvar rcirc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'rcirc-send-input) - (define-key map (kbd "M-p") 'rcirc-insert-prev-input) - (define-key map (kbd "M-n") 'rcirc-insert-next-input) - (define-key map (kbd "TAB") 'completion-at-point) - (define-key map (kbd "C-c C-b") 'rcirc-browse-url) - (define-key map (kbd "C-c C-c") 'rcirc-edit-multiline) - (define-key map (kbd "C-c C-j") 'rcirc-cmd-join) - (define-key map (kbd "C-c C-k") 'rcirc-cmd-kick) - (define-key map (kbd "C-c C-l") 'rcirc-toggle-low-priority) - (define-key map (kbd "C-c C-d") 'rcirc-cmd-mode) - (define-key map (kbd "C-c C-m") 'rcirc-cmd-msg) - (define-key map (kbd "C-c C-r") 'rcirc-cmd-nick) ; rename - (define-key map (kbd "C-c C-o") 'rcirc-omit-mode) - (define-key map (kbd "C-c C-p") 'rcirc-cmd-part) - (define-key map (kbd "C-c C-q") 'rcirc-cmd-query) - (define-key map (kbd "C-c C-t") 'rcirc-cmd-topic) - (define-key map (kbd "C-c C-n") 'rcirc-cmd-names) - (define-key map (kbd "C-c C-w") 'rcirc-cmd-whois) - (define-key map (kbd "C-c C-x") 'rcirc-cmd-quit) - (define-key map (kbd "C-c TAB") ; C-i - 'rcirc-toggle-ignore-buffer-activity) - (define-key map (kbd "C-c C-s") 'rcirc-switch-to-server-buffer) - (define-key map (kbd "C-c C-a") 'rcirc-jump-to-first-unread-line) - map) - "Keymap for rcirc mode.") +(defvar-keymap rcirc-mode-map + :doc "Keymap for rcirc mode." + "RET" #'rcirc-send-input + "M-p" #'rcirc-insert-prev-input + "M-n" #'rcirc-insert-next-input + "TAB" #'completion-at-point + "C-c C-b" #'rcirc-browse-url + "C-c C-c" #'rcirc-edit-multiline + "C-c C-j" #'rcirc-cmd-join + "C-c C-k" #'rcirc-cmd-kick + "C-c C-l" #'rcirc-toggle-low-priority + "C-c C-d" #'rcirc-cmd-mode + "C-c C-m" #'rcirc-cmd-msg + "C-c C-r" #'rcirc-cmd-nick ; rename + "C-c C-o" #'rcirc-omit-mode + "C-c C-p" #'rcirc-cmd-part + "C-c C-q" #'rcirc-cmd-query + "C-c C-t" #'rcirc-cmd-topic + "C-c C-n" #'rcirc-cmd-names + "C-c C-w" #'rcirc-cmd-whois + "C-c C-x" #'rcirc-cmd-quit + "C-c C-i" #'rcirc-toggle-ignore-buffer-activity + "C-c C-s" #'rcirc-switch-to-server-buffer + "C-c C-a" #'rcirc-jump-to-first-unread-line) (defvar-local rcirc-short-buffer-name nil "Generated abbreviation to use to indicate buffer activity.") @@ -1434,7 +1456,8 @@ PROCESS is the process object used for communication. (add-hook 'completion-at-point-functions 'rcirc-completion-at-point nil 'local) - (setq-local completion-cycle-threshold t) + (when rcirc-cycle-completion-flag + (setq-local completion-cycle-threshold t)) (run-mode-hooks 'rcirc-mode-hook)) @@ -1683,16 +1706,17 @@ extracted." (setq rcirc-parent-buffer parent) (insert text) (and (> pos 0) (goto-char pos)) - (message "Type C-c C-c to return text to %s, or C-c C-k to cancel" parent)))) - -(defvar rcirc-multiline-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-c") 'rcirc-multiline-minor-submit) - (define-key map (kbd "C-x C-s") 'rcirc-multiline-minor-submit) - (define-key map (kbd "C-c C-k") 'rcirc-multiline-minor-cancel) - (define-key map (kbd "ESC ESC ESC") 'rcirc-multiline-minor-cancel) - map) - "Keymap for multiline mode in rcirc.") + (message "Type %s to return text to %s, or %s to cancel" + (substitute-command-keys "\\[rcirc-multiline-minor-submit]") + parent + (substitute-command-keys "\\[rcirc-multiline-minor-cancel]"))))) + +(defvar-keymap rcirc-multiline-minor-mode-map + :doc "Keymap for multiline mode in rcirc." + "C-c C-c" #'rcirc-multiline-minor-submit + "C-x C-s" #'rcirc-multiline-minor-submit + "C-c C-k" #'rcirc-multiline-minor-cancel + "ESC ESC ESC" #'rcirc-multiline-minor-cancel) (define-minor-mode rcirc-multiline-minor-mode "Minor mode for editing multiple lines in rcirc." @@ -2240,12 +2264,10 @@ This function does not alter the INPUT string." (mapconcat rcirc-nick-filter sorted sep))) ;;; activity tracking -(defvar rcirc-track-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-@") 'rcirc-next-active-buffer) - (define-key map (kbd "C-c C-SPC") 'rcirc-next-active-buffer) - map) - "Keymap for rcirc track minor mode.") +(defvar-keymap rcirc-track-minor-mode-map + :doc "Keymap for rcirc track minor mode." + "C-c C-@" #'rcirc-next-active-buffer + "C-c C-SPC" #'rcirc-next-active-buffer) (defcustom rcirc-track-abbrevate-flag t "Non-nil means `rcirc-track-minor-mode' should abbreviate names." @@ -2592,15 +2614,22 @@ that, an interactive form can specified." (defun ,fn-name (,argument &optional process target) ,(concat documentation "\n\nNote: If PROCESS or TARGET are nil, the values given" - "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - (interactive (list ,interactive-spec)) + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + (interactive ,(if (stringp interactive-spec) + ;; HACK: Necessary to wrap the result of + ;; the interactive spec in a list. + `(list (call-interactively + (lambda (&rest args) + (interactive ,interactive-spec) + args))) + `(list ,interactive-spec))) (unless (if (listp ,argument) (<= ,required (length ,argument) ,total) (string-match ,regexp ,argument)) (user-error "Malformed input (%s): %S" ',command ,argument)) (push ,(upcase (symbol-name command)) rcirc-pending-requests) (let ((process (or process (rcirc-buffer-process))) - (target (or target rcirc-target))) + (target (or target rcirc-target))) (ignore target process) (let (,@(cl-loop for i from 0 for arg in (delq '&optional arguments) @@ -3266,7 +3295,7 @@ PROCESS is the process object for the current connection." (with-current-buffer chat-buffer (rcirc-print process sender "NICK" old-nick new-nick) (setq rcirc-target new-nick) - (rename-buffer (rcirc-generate-new-buffer-name process new-nick))) + (rename-buffer (rcirc-generate-new-buffer-name process new-nick) t)) (setf rcirc-buffer-alist (cons (cons new-nick chat-buffer) (delq (assoc-string old-nick rcirc-buffer-alist t) @@ -3447,7 +3476,7 @@ form \"PARAMETER\" to enable a feature, \"PARAMETER=VALUE\" to configure a specific option or \"-PARAMETER\" to disable a previously specified feature. SENDER is passed on to `rcirc-handler-generic'. PROCESS is the process object for the -current connection. Note that this is not the behaviour as +current connection. Note that this is not the behavior as specified in RFC2812, where 005 stood for RPL_BOUNCE." (rcirc-handler-generic process "005" sender args text) (with-rcirc-process-buffer process diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el index 98b660dcc43..a6d0edae072 100644 --- a/lisp/net/rlogin.el +++ b/lisp/net/rlogin.el @@ -1,7 +1,6 @@ ;;; rlogin.el --- remote login interface -*- lexical-binding:t -*- -;; Copyright (C) 1992-1995, 1997-1998, 2001-2022 Free Software -;; Foundation, Inc. +;; Copyright (C) 1992-2022 Free Software Foundation, Inc. ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: unix, comm @@ -118,19 +117,15 @@ this variable is set from that." :type '(choice (const nil) string) :group 'rlogin) -(defvar rlogin-mode-map - (let ((map (if (consp shell-mode-map) - (cons 'keymap shell-mode-map) - (copy-keymap shell-mode-map)))) - (define-key map "\C-c\C-c" 'rlogin-send-Ctrl-C) - (define-key map "\C-c\C-d" 'rlogin-send-Ctrl-D) - (define-key map "\C-c\C-z" 'rlogin-send-Ctrl-Z) - (define-key map "\C-c\C-\\" 'rlogin-send-Ctrl-backslash) - (define-key map "\C-d" 'rlogin-delchar-or-send-Ctrl-D) - (define-key map "\C-i" 'rlogin-tab-or-complete) - map) - "Keymap for `rlogin-mode'.") - +(defvar-keymap rlogin-mode-map + :doc "Keymap for `rlogin-mode'." + :parent shell-mode-map + "C-c C-c" #'rlogin-send-Ctrl-C + "C-c C-d" #'rlogin-send-Ctrl-D + "C-c C-z" #'rlogin-send-Ctrl-Z + "C-c C-\\" #'rlogin-send-Ctrl-backslash + "C-d" #'rlogin-delchar-or-send-Ctrl-D + "TAB" #'rlogin-tab-or-complete) (defvar rlogin-history nil) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index d8341774e47..c4f97a92fb5 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -741,14 +741,13 @@ ITEM can also be an object path, which is used if contained in COLLECTION." ;;; Visualization. -(defvar secrets-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map (make-composed-keymap special-mode-map widget-keymap)) - (define-key map "n" #'next-line) - (define-key map "p" #'previous-line) - (define-key map "z" #'kill-current-buffer) - map) - "Keymap used in `secrets-mode' buffers.") +(defvar-keymap secrets-mode-map + :doc "Keymap used in `secrets-mode' buffers." + :parent (make-composed-keymap special-mode-map + widget-keymap) + "n" #'next-line + "p" #'previous-line + "z" #'kill-current-buffer) (define-derived-mode secrets-mode special-mode "Secrets" "Major mode for presenting password entries retrieved by Security Service. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 7363874cf3c..c4f0d3b9404 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -40,6 +40,7 @@ (require 'image) (require 'puny) (require 'url-cookie) +(require 'url-file) (require 'pixel-fill) (require 'text-property-search) @@ -227,6 +228,15 @@ temporarily blinks with this face." "Face for <h6> elements." :version "28.1") +(defface shr-code '((t :inherit fixed-pitch)) + "Face used for rendering <code> blocks." + :version "29.1") + +(defface shr-mark + '((t :background "yellow" :foreground "black")) + "Face used for <mark> elements." + :version "29.1") + (defcustom shr-inhibit-images nil "If non-nil, inhibit loading images." :version "28.1" @@ -280,11 +290,10 @@ and other things: "O" #'shr-save-contents "RET" #'shr-browse-url) -(defvar shr-image-map - (let ((map (copy-keymap shr-map))) - (when (boundp 'image-map) - (set-keymap-parent map image-map)) - map)) +(defvar-keymap shr-image-map + :parent (if (boundp 'image-map) + (make-composed-keymap shr-map image-map) + shr-map)) ;; Public functions and commands. (declare-function libxml-parse-html-region "xml.c" @@ -332,6 +341,11 @@ and other things: 0)) (pixel-fill-width))) +(defmacro shr-string-pixel-width (string) + `(if (not shr-use-fonts) + (length ,string) + (string-pixel-width ,string))) + ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -356,6 +370,7 @@ DOM should be a parse tree as generated by (shr--window-width))) (max-specpdl-size max-specpdl-size) (shr--link-targets nil) + (hscroll (window-hscroll)) ;; `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 @@ -375,17 +390,20 @@ DOM should be a parse tree as generated by ;; below will misbehave, because it silently assumes that it ;; starts with a non-hscrolled window (vertical-motion will move ;; to a wrong place otherwise). - (set-window-hscroll nil 0) - (shr-descend dom) - (shr-fill-lines start (point)) - (shr--remove-blank-lines-at-the-end start (point)) - (shr--set-target-ids shr--link-targets) + (unwind-protect + (progn + (set-window-hscroll nil 0) + (shr-descend dom) + (shr-fill-lines start (point)) + (shr--remove-blank-lines-at-the-end start (point)) + (shr--set-target-ids shr--link-targets)) + (set-window-hscroll nil hscroll)) (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)) + (unless (zerop (- (point-max) (point-min))) ;; 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. @@ -630,7 +648,7 @@ size, and full-buffer size." (t (shr-generic dom))) (when-let ((id (dom-attr dom 'id))) - (push (cons id (point)) shr--link-targets)) + (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 @@ -668,19 +686,6 @@ size, and full-buffer size." (goto-char (mark)) (shr-pixel-column)))) -(defun shr-string-pixel-width (string) - (if (not shr-use-fonts) - (length string) - ;; Save and restore point across with-temp-buffer, since - ;; shr-pixel-column uses save-window-excursion, which can reset - ;; point to 1. - (let ((pt (point))) - (prog1 - (with-temp-buffer - (insert string) - (shr-pixel-column)) - (goto-char pt))))) - (defsubst shr--translate-insertion-chars () ;; Remove soft hyphens. (goto-char (point-min)) @@ -877,8 +882,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) @@ -987,8 +994,7 @@ the mouse click event." (let ((url (get-text-property (point) 'shr-url))) (if (not url) (message "No link under point") - (url-retrieve (shr-encode-url url) - #'shr-store-contents (list url directory))))) + (url-retrieve url #'shr-store-contents (list url directory))))) (defun shr-store-contents (status url directory) (unless (plist-get status :error) @@ -1147,7 +1153,7 @@ Return a string with image data." (with-temp-buffer (set-buffer-multibyte nil) (when (ignore-errors - (url-cache-extract (url-cache-create-filename (shr-encode-url url))) + (url-cache-extract (url-cache-create-filename url)) t) (when (re-search-forward "\r?\n\r?\n" nil t) (shr-parse-image-data))))) @@ -1245,6 +1251,7 @@ START, and END. Note that START and END should be markers." (defun shr-encode-url (url) "Encode URL." + (declare (obsolete nil "29.1")) (browse-url-url-encode-chars url "[)$ ]")) (autoload 'shr-color-visible "shr-color") @@ -1319,6 +1326,11 @@ ones, in case fg and bg are nil." (defun shr-tag-comment (_dom) ) +;; Introduced in HTML5. For text browsers, functionally similar to a +;; comment. +(defun shr-tag-template (_dom) + ) + (defun shr-dom-to-xml (dom &optional charset) (with-temp-buffer (shr-dom-print dom) @@ -1407,13 +1419,21 @@ ones, in case fg and bg are nil." (shr-fontize-dom dom 'underline)) (defun shr-tag-code (dom) - (let ((shr-current-font 'fixed-pitch)) + (let ((shr-current-font 'shr-code)) (shr-generic dom))) (defun shr-tag-tt (dom) ;; The `tt' tag is deprecated in favor of `code'. (shr-tag-code dom)) +(defun shr-tag-mark (dom) + (when (and (not (bobp)) + (not (= (char-after (1- (point))) ?\s))) + (insert " ")) + (let ((start (point))) + (shr-generic dom) + (shr-add-font start (point) 'shr-mark))) + (defun shr-tag-ins (cont) (let* ((start (point)) (color "green") @@ -1465,9 +1485,20 @@ ones, in case fg and bg are nil." (shr-generic dom) (when-let* ((id (and (not (dom-attr dom 'id)) ; Handled by `shr-descend'. (dom-attr dom 'name)))) ; Obsolete since HTML5. - (push (cons id (point)) shr--link-targets)) + (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)) @@ -1654,13 +1685,13 @@ The preference is a float determined from `shr-prefer-media-type'." (setq shr-start (point)) (shr-insert alt)) ((and (not shr-ignore-cache) - (url-is-cached (shr-encode-url url))) + (url-is-cached url)) (funcall shr-put-image-function (shr-get-image-data url) alt (list :width width :height height))) (t (when (and shr-ignore-cache - (url-is-cached (shr-encode-url url))) - (let ((file (url-cache-create-filename (shr-encode-url url)))) + (url-is-cached url)) + (let ((file (url-cache-create-filename url))) (when (file-exists-p file) (delete-file file)))) (when (image-type-available-p 'svg) @@ -1669,7 +1700,7 @@ The preference is a float determined from `shr-prefer-media-type'." (or alt ""))) (insert " ") (url-queue-retrieve - (shr-encode-url url) #'shr-image-fetched + url #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) (list :width width :height height)) t diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index 468bc90a9d7..a39e35a53a1 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: @@ -130,7 +131,7 @@ for doing the actual authentication." (defcustom sieve-manage-default-port "sieve" "Default port number or service name for managesieve protocol." - :type '(choice integer string) + :type '(choice natnum string) :version "24.4") (defcustom sieve-manage-default-stream 'network @@ -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/sieve-mode.el b/lisp/net/sieve-mode.el index 58fd41d8995..f62af03534a 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -137,13 +137,11 @@ ;; Key map definition -(defvar sieve-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-l" #'sieve-upload) - (define-key map "\C-c\C-c" #'sieve-upload-and-kill) - (define-key map "\C-c\C-m" #'sieve-manage) - map) - "Key map used in sieve mode.") +(defvar-keymap sieve-mode-map + :doc "Keymap used in sieve mode." + "C-c C-l" #'sieve-upload + "C-c C-c" #'sieve-upload-and-kill + "C-c RET" #'sieve-manage) ;; Menu diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index 630ea04070b..3a6067ee10b 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -106,33 +106,31 @@ require \"fileinto\"; ;; FIXME: This is arguably a bug/problem in `easy-menu-define'. (declare-function sieve-manage-mode-menu "sieve") -(defvar sieve-manage-mode-map - (let ((map (make-sparse-keymap))) - ;; various - (define-key map "?" #'sieve-help) - (define-key map "h" #'sieve-help) - ;; activating - (define-key map "m" #'sieve-activate) - (define-key map "u" #'sieve-deactivate) - (define-key map "\M-\C-?" #'sieve-deactivate-all) - ;; navigation keys - (define-key map "\C-p" #'sieve-prev-line) - (define-key map [up] #'sieve-prev-line) - (define-key map "\C-n" #'sieve-next-line) - (define-key map [down] #'sieve-next-line) - (define-key map " " #'sieve-next-line) - (define-key map "n" #'sieve-next-line) - (define-key map "p" #'sieve-prev-line) - (define-key map "\C-m" #'sieve-edit-script) - (define-key map "f" #'sieve-edit-script) - ;; (define-key map "o" #'sieve-edit-script-other-window) - (define-key map "r" #'sieve-remove) - (define-key map "q" #'sieve-bury-buffer) - (define-key map "Q" #'sieve-manage-quit) - (define-key map [(down-mouse-2)] #'sieve-edit-script) - (define-key map [(down-mouse-3)] #'sieve-manage-mode-menu) - map) - "Keymap for `sieve-manage-mode'.") +(defvar-keymap sieve-manage-mode-map + :doc "Keymap for `sieve-manage-mode'." + ;; various + "?" #'sieve-help + "h" #'sieve-help + ;; activating + "m" #'sieve-activate + "u" #'sieve-deactivate + "M-DEL" #'sieve-deactivate-all + ;; navigation keys + "C-p" #'sieve-prev-line + "<up>" #'sieve-prev-line + "C-n" #'sieve-next-line + "<down>" #'sieve-next-line + "SPC" #'sieve-next-line + "n" #'sieve-next-line + "p" #'sieve-prev-line + "RET" #'sieve-edit-script + "f" #'sieve-edit-script + ;; "o" #'sieve-edit-script-other-window + "r" #'sieve-remove + "q" #'sieve-bury-buffer + "Q" #'sieve-manage-quit + "<down-mouse-2>" #'sieve-edit-script + "<down-mouse-3>" #'sieve-manage-mode-menu) (easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map "Sieve Menu." diff --git a/lisp/net/snmp-mode.el b/lisp/net/snmp-mode.el index de84b4f8dd1..394c4a9666d 100644 --- a/lisp/net/snmp-mode.el +++ b/lisp/net/snmp-mode.el @@ -248,14 +248,12 @@ This is used during Tempo template completion." ;; Set up our keymap ;; -(defvar snmp-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\177" 'backward-delete-char-untabify) - (define-key map "\C-c\C-i" 'tempo-complete-tag) - (define-key map "\C-c\C-f" 'tempo-forward-mark) - (define-key map "\C-c\C-b" 'tempo-backward-mark) - map) - "Keymap used in SNMP mode.") +(defvar-keymap snmp-mode-map + :doc "Keymap used in SNMP mode." + "DEL" #'backward-delete-char-untabify + "C-c TAB" #'tempo-complete-tag + "C-c C-f" #'tempo-forward-mark + "C-c C-b" #'tempo-backward-mark) ;; Set up our syntax table diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index d2092633d89..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)) @@ -1937,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/socks.el b/lisp/net/socks.el index 8df0773e1d2..2ba1c20566f 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -407,11 +407,10 @@ When ATYPE indicates an IP, param ADDRESS must be given as raw bytes." (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) - (setq request (format (eval-when-compile - (concat - "CONNECT %s:%d HTTP/1.0\r\n" - "User-Agent: Emacs/SOCKS v1.0\r\n" - "\r\n")) + (setq request (format (concat + "CONNECT %s:%d HTTP/1.0\r\n" + "User-Agent: Emacs/SOCKS v1.0\r\n" + "\r\n") (cond ((equal atype socks-address-type-name) address) (t diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index 0d54d2220b6..802e7bc0a28 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -1,7 +1,6 @@ ;;; telnet.el --- run a telnet session from within an Emacs buffer -*- lexical-binding: t; -*- -;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2022 Free Software -;; Foundation, Inc. +;; Copyright (C) 1985-2022 Free Software Foundation, Inc. ;; Author: William F. Schelter ;; Maintainer: emacs-devel@gnu.org @@ -61,14 +60,13 @@ PROGRAM says which program to run, to talk to that machine. LOGIN-NAME, which is optional, says what to log in as on that machine.") (defvar telnet-new-line "\r") -(defvar telnet-mode-map - (let ((map (nconc (make-sparse-keymap) comint-mode-map))) - (define-key map "\C-m" #'telnet-send-input) - ;; (define-key map "\C-j" #'telnet-send-input) - (define-key map "\C-c\C-q" #'send-process-next-char) - (define-key map "\C-c\C-c" #'telnet-interrupt-subjob) - (define-key map "\C-c\C-z" #'telnet-c-z) - map)) +(defvar-keymap telnet-mode-map + :parent comint-mode-map + "RET" #'telnet-send-input + ;; "C-j" #'telnet-send-input + "C-c C-q" #'send-process-next-char + "C-c C-c" #'telnet-interrupt-subjob + "C-c C-z" #'telnet-c-z) (defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *") (defvar telnet-replace-c-g nil) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index ed73a86ef03..b504ce600d1 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -159,6 +159,7 @@ It is used for TCP/IP devices." ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -168,6 +169,7 @@ It is used for TCP/IP devices." (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-adb-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-adb-handle-process-file) (rename-file . tramp-adb-handle-rename-file) (set-file-acl . ignore) @@ -179,6 +181,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) @@ -267,7 +270,7 @@ arguments to pass to the OPERATION." "Parse `file-attributes' for Tramp files using the ls(1) command." (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (let ((file-properties nil)) + (let (file-properties) (while (re-search-forward tramp-adb-ls-toolbox-regexp nil t) (let* ((mod-string (match-string 1)) (is-dir (eq ?d (aref mod-string 0))) @@ -545,28 +548,8 @@ Emacs dired can't find files." (defun tramp-adb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let ((tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) @@ -579,33 +562,7 @@ Emacs dired can't find files." (unless (tramp-adb-execute-adb-command v "push" tmpfile (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Cannot write: `%s'" filename)) - (delete-file tmpfile))) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - - (unless (equal curbuf (current-buffer)) - (tramp-error - v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - - ;; 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. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + (delete-file tmpfile)))))) (defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -776,7 +733,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 +772,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 +806,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 +827,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 +858,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. @@ -972,6 +929,7 @@ implementation will be used." (tramp-make-tramp-temp-file v)))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) (command @@ -984,102 +942,115 @@ implementation will be used." (or (null program) tramp-process-connection-type)) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + p) + + (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) name1 (format "%s<%d>" name i))) (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' - ;; could be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (coding-system-for-write - (if (symbolp coding) coding (car coding))) - (coding-system-for-read - (if (symbolp coding) coding (cdr coding)))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', - ;; in order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (delete-region (point-min) (point-max)) - ;; Send the command. - (let* ((p (tramp-get-connection-process v))) - (tramp-adb-send-command v command nil t) ; nooutput - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for - ;; this process. We ignore errors, because - ;; the process could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; We must flush them here already; - ;; otherwise `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Read initial output. Remove the first - ;; line, which is the command echo. - (unless (eq filter t) - (while - (progn - (goto-char (point-min)) - (not (re-search-forward "[\n]" nil t))) - (tramp-accept-process-output p 0)) - (delete-region (point-min) (point))) - ;; Provide error buffer. This shows only - ;; initial error messages; messages arriving - ;; later on will be inserted when the - ;; process is deleted. The temporary file - ;; will exist until the process is deleted. - (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit)) - ;; Delete tmpstderr file. - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit nil nil 'replace)) - (delete-file remote-tmpstderr)))) - ;; Return process. - p)))) - - ;; Save exit. - (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer"))))))))) + + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, + ;; `make-process' could be called on the local + ;; host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save + ;; BUFFER contents. Clear also the + ;; modification time; otherwise we might be + ;; interrupted by `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (coding-system-for-write + (if (symbolp coding) coding (car coding))) + (coding-system-for-read + (if (symbolp coding) coding (cdr coding)))) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', + ;; in order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (setq p (tramp-get-connection-process v)) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) + ;; Set query flag and process marker for + ;; this process. We ignore errors, + ;; because the process could have finished + ;; already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point)) + ;; We must flush them here already; + ;; otherwise `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property + v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Read initial output. Remove the + ;; first line, which is the command + ;; echo. + (unless (eq filter t) + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point))) + ;; Provide error buffer. This shows + ;; only initial error messages; messages + ;; arriving later on will be inserted + ;; when the process is deleted. The + ;; temporary file will exist until the + ;; process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) + ;; Return process. + p)))) + + ;; Save exit. + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)))))))))))) (defun tramp-adb-handle-exec-path () "Like `exec-path' for Tramp files." @@ -1108,9 +1079,9 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" tramp-prefix-port-format ":" (cond ((member host devices) host) ;; This is the case when the host is connected to the default port. - ((member (format "%s%s%d" host tramp-prefix-port-format port) + ((member (format "%s%s%s" host tramp-prefix-port-format port) devices) - (format "%s:%d" host port)) + (format "%s:%s" host port)) ;; An empty host name shall be mapped as well, when there ;; is exactly one entry in `devices'. ((and (zerop (length host)) (= (length devices) 1)) @@ -1264,7 +1235,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") @@ -1318,8 +1289,7 @@ connection if a previous connection has died for some reason." "echo \\\"`getprop ro.product.model` " "`getprop ro.product.version` " "`getprop ro.build.version.release`\\\"")) - (let ((old-getprop - (tramp-get-connection-property vec "getprop" nil)) + (let ((old-getprop (tramp-get-connection-property vec "getprop")) (new-getprop (tramp-set-connection-property vec "getprop" @@ -1359,10 +1329,47 @@ connection if a previous connection has died for some reason." 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) +(defconst tramp-adb-connection-local-default-ps-variables + '((tramp-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ((user . string) + (pid . number) + (ppid . number) + (vsize . number) + (rss . number) + (wchan . string) ; ?? + (pc . string) ; ?? + (state . string) + (args . nil)))) + "Default connection-local ps variables for remote adb connections.") + +(connection-local-set-profile-variables + 'tramp-adb-connection-local-default-ps-profile + tramp-adb-connection-local-default-ps-variables) + (with-eval-after-load 'shell (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) - 'tramp-adb-connection-local-default-shell-profile)) + 'tramp-adb-connection-local-default-shell-profile + 'tramp-adb-connection-local-default-ps-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 () diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 8a88057d38a..119ac54dd29 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -57,6 +57,7 @@ ;; * ".crate" - Cargo (Rust) packages ;; * ".deb" - Debian packages ;; * ".depot" - HP-UX SD depots +;; * ".epub" - Electronic publications ;; * ".exe" - Self extracting Microsoft Windows EXE files ;; * ".iso" - ISO 9660 images ;; * ".jar" - Java archives @@ -145,6 +146,7 @@ "crate" ;; Cargo (Rust) packages. Not in libarchive testsuite. "deb" ;; Debian packages. Not in libarchive testsuite. "depot" ;; HP-UX SD depot. Not in libarchive testsuite. + "epub" ;; Electronic publications. Not in libarchive testsuite. "exe" ;; Self extracting Microsoft Windows EXE files. "iso" ;; ISO 9660 images. "jar" ;; Java archives. Not in libarchive testsuite. @@ -190,6 +192,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. @@ -265,6 +269,7 @@ It must be supported by libarchive(3).") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-archive-handle-insert-directory) (insert-file-contents . tramp-archive-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-archive-handle-load) (lock-file . ignore) (make-auto-save-file-name . ignore) @@ -274,6 +279,7 @@ It must be supported by libarchive(3).") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-archive-handle-not-implemented) (set-file-acl . ignore) @@ -285,6 +291,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) @@ -302,7 +309,8 @@ Operations not mentioned here will be handled by the default Emacs primitives.") #'tramp-archive-file-name-p)) (apply #'tramp-file-name-for-operation operation args))) -(defun tramp-archive-run-real-handler (operation args) +;;;###tramp-autoload +(progn (defun tramp-archive-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. First arg specifies the OPERATION, second arg ARGS is a list of arguments to pass to the OPERATION." @@ -312,7 +320,7 @@ arguments to pass to the OPERATION." ,(and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation)) - (apply operation args))) + (apply operation args)))) ;;;###tramp-autoload (defun tramp-archive-file-name-handler (operation &rest args) @@ -357,24 +365,29 @@ arguments to pass to the OPERATION." (progn (defun tramp-archive-autoload-file-name-handler (operation &rest args) "Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) - (when tramp-archive-enabled - ;; We cannot use `tramp-compat-temporary-file-directory' here due - ;; to autoload. When installing Tramp's GNU ELPA package, there - ;; might be an older, incompatible version active. We try to - ;; overload this. - (let ((default-directory temporary-file-directory) - (tramp-archive-autoload t)) - (apply #'tramp-autoload-file-name-handler operation args))))) + (let (;; We cannot use `tramp-compat-temporary-file-directory' here + ;; due to autoload. When installing Tramp's GNU ELPA package, + ;; there might be an older, incompatible version active. We + ;; try to overload this. + (default-directory temporary-file-directory) + (tramp-archive-autoload tramp-archive-enabled)) + (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'." - (when tramp-archive-enabled + (when (and tramp-archive-enabled + (not + (rassq #'tramp-archive-file-name-handler file-name-handler-alist))) (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t)))) +(put #'tramp-register-archive-file-name-handler 'tramp-autoload t) + ;;;###autoload (progn (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) @@ -457,7 +470,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)) @@ -560,8 +573,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. diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 715b537247f..dbebcad1a84 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -122,14 +122,14 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (puthash key (make-hash-table :test #'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (tramp-compat-string-search + (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)))) ;;;###tramp-autoload -(defun tramp-get-file-property (key file property default) +(defun tramp-get-file-property (key file property &optional default) "Get the PROPERTY of FILE from the cache context of KEY. Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. @@ -240,7 +240,7 @@ Return VALUE." (defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." (let* ((file (tramp-run-real-handler #'directory-file-name (list file))) - (truename (tramp-get-file-property key file "file-truename" nil))) + (truename (tramp-get-file-property key file "file-truename"))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -262,7 +262,7 @@ Remove also properties of all files in subdirectories." (setq directory (tramp-compat-file-name-unquote directory)) (let* ((directory (tramp-run-real-handler #'directory-file-name (list directory))) - (truename (tramp-get-file-property key directory "file-truename" nil))) + (truename (tramp-get-file-property key directory "file-truename"))) (tramp-message key 8 "%s" directory) (dolist (key (hash-table-keys tramp-cache-data)) (when (and (tramp-file-name-p key) @@ -311,7 +311,7 @@ This is suppressed for temporary buffers." ;;; -- Properties -- ;;;###tramp-autoload -(defun tramp-get-connection-property (key property default) +(defun tramp-get-connection-property (key property &optional default) "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is @@ -427,7 +427,7 @@ used to cache connection properties of the local machine." ;;;###tramp-autoload (defun tramp-list-connections () - "Return all known `tramp-file-name' structs according to `tramp-cache'." + "Return all active `tramp-file-name' structs according to `tramp-cache-data'." (let ((tramp-verbose 0)) (delq nil (mapcar (lambda (key) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index c18ab4972d2..bd2dbf4a1e0 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -51,6 +51,7 @@ SYNTAX can be one of the symbols `default' (default), (when syntax (customize-set-variable 'tramp-syntax syntax))) +;;;###tramp-autoload (defun tramp-list-tramp-buffers () "Return a list of all Tramp connection buffers." (append @@ -61,6 +62,7 @@ SYNTAX can be one of the symbols `default' (default), (all-completions "*trace tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))))) +;;;###tramp-autoload (defun tramp-list-remote-buffers () "Return a list of all buffers with remote `default-directory'." (delq @@ -133,7 +135,7 @@ When called interactively, a Tramp connection has to be selected." (get-buffer (tramp-debug-buffer-name vec))) (unless keep-debug (get-buffer (tramp-trace-buffer-name vec))) - (tramp-get-connection-property vec "process-buffer" nil))) + (tramp-get-connection-property vec "process-buffer"))) (when (bufferp buf) (kill-buffer buf))) ;; Flush file cache. @@ -720,7 +722,7 @@ the debug buffer(s).") (when (y-or-n-p "Do you want to append the buffer(s)?") ;; OK, let's send. First we delete the buffer list. - (kill-buffer nil) + (kill-buffer) (switch-to-buffer curbuf) (goto-char (point-max)) (insert (propertize "\n" 'display "\n\ diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 0a45b12a04a..a12e4859ac4 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -31,12 +31,13 @@ (require 'auth-source) (require 'format-spec) -(require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. +(require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. (require 'parse-time) (require 'shell) (require 'subr-x) (declare-function tramp-error "tramp") +(declare-function tramp-file-name-handler "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -133,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. @@ -233,7 +234,7 @@ CONDITION can also be a list of error conditions." (if (fboundp 'string-replace) #'string-replace (lambda (from-string to-string in-string) - (let ((case-fold-search nil)) + (let (case-fold-search) (replace-regexp-in-string (regexp-quote from-string) to-string in-string t t))))) @@ -242,7 +243,7 @@ CONDITION can also be a list of error conditions." (if (fboundp 'string-search) #'string-search (lambda (needle haystack &optional start-pos) - (let ((case-fold-search nil)) + (let (case-fold-search) (string-match-p (regexp-quote needle) haystack start-pos))))) ;; Function `make-lock-file-name' is new in Emacs 28.1. @@ -283,6 +284,16 @@ CONDITION can also be a list of 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)) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 36443e09830..6cb1237a0f4 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -39,7 +39,7 @@ ;; first time you access a crypted remote directory. It is kept in ;; your user directory "~/.emacs.d/" with the url-encoded directory ;; name as part of the basename, and ".encfs6.xml" as suffix. Do not -;; loose this file and the corresponding password; otherwise there is +;; lose this file and the corresponding password; otherwise there is ;; no way to decrypt your crypted files. ;; If the user option `tramp-crypt-save-encfs-config-remote' is @@ -151,7 +151,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (dolist (dir tramp-crypt-directories) (and (string-prefix-p dir (file-name-as-directory (expand-file-name name))) - (throw 'crypt-file-name-p dir)))))) + (throw 'crypt-file-name-p dir)))))) ;; New handlers should be added here. @@ -193,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) @@ -208,7 +208,8 @@ 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) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -218,6 +219,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-crypt-handle-rename-file) (set-file-acl . ignore) @@ -229,6 +231,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) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index ff8caa570ca..dd7e0f9f342 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -125,7 +125,7 @@ pass to the OPERATION." ;; "ftp" method is used in the Tramp file name. So we unset ;; those values. (ange-ftp-ftp-name-arg "") - (ange-ftp-ftp-name-res nil)) + ange-ftp-ftp-name-res) (cond ;; If argument is a symlink, `file-directory-p' and ;; `file-exists-p' call the traversed file recursively. So we @@ -135,12 +135,21 @@ pass to the OPERATION." ;; completion. We don't use `with-parsed-tramp-file-name', ;; because this returns another user but the one declared in ;; "~/.netrc". + ;; For file names which look like Tramp archive files like + ;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.0.39.tar.gz", + ;; we must disable tramp-archive.el, because in + ;; `ange-ftp-get-files' this is "normalized" by + ;; `file-name-as-directory' with unwelcome side side-effects. + ;; This disables the file archive functionality, perhaps we + ;; could fix this otherwise. (Bug#56078) ((memq operation '(file-directory-p file-exists-p)) - (if (apply #'ange-ftp-hook-function operation args) + (cl-letf (((symbol-function #'tramp-archive-file-name-handler) + (lambda (operation &rest args) + (tramp-archive-run-real-handler operation args)))) + (prog1 (apply #'ange-ftp-hook-function operation args) (let ((v (tramp-dissect-file-name (car args) t))) (setf (tramp-file-name-method v) tramp-ftp-method) - (tramp-set-connection-property v "started" t)) - nil)) + (tramp-set-connection-property v "started" t))))) ;; If the second argument of `copy-file' or `rename-file' is a ;; remote file name but via FTP, ange-ftp doesn't check this. diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 2a73d5aa02b..2ff106d6023 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -44,6 +44,17 @@ (delete-file (tramp-fuse-local-file-name filename) trash) (tramp-flush-file-properties v localname))) +(defvar tramp-fuse-remove-hidden-files nil + "Remove hidden files from directory listings.") + +(defsubst tramp-fuse-remove-hidden-files (files) + "Remove hidden files from FILES." + (if tramp-fuse-remove-hidden-files + (cl-remove-if + (lambda (x) (and (stringp x) (string-match-p "\\.fuse_hidden" x))) + files) + files)) + (defun tramp-fuse-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." @@ -75,7 +86,8 @@ result))) (setq result (cons item result)))) ;; Return result. - (if nosort result (sort result #'string<)))))) + (tramp-fuse-remove-hidden-files + (if nosort result (sort result #'string<))))))) (defun tramp-fuse-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -92,20 +104,21 @@ (defun tramp-fuse-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (delete-dups - (append - (file-name-all-completions - filename (tramp-fuse-local-file-name directory)) - ;; Some storage systems do not return "." and "..". - (let (result) - (dolist (item '(".." ".") result) - (when (string-prefix-p filename item) - (catch 'match - (dolist (elt completion-regexp-list) - (unless (string-match-p elt item) (throw 'match nil))) - (setq result (cons (concat item "/") result)))))))))) + (tramp-fuse-remove-hidden-files + (all-completions + filename + (delete-dups + (append + (file-name-all-completions + filename (tramp-fuse-local-file-name directory)) + ;; Some storage systems do not return "." and "..". + (let (result) + (dolist (item '(".." ".") result) + (when (string-prefix-p filename item) + (catch 'match + (dolist (elt completion-regexp-list) + (unless (string-match-p elt item) (throw 'match nil))) + (setq result (cons (concat item "/") result))))))))))) ;; This function isn't used. (defun tramp-fuse-handle-insert-directory @@ -140,7 +153,7 @@ (defun tramp-fuse-mount-point (vec) "Return local mount point of VEC." - (or (tramp-get-connection-property vec "mount-point" nil) + (or (tramp-get-connection-property vec "mount-point") (expand-file-name (concat tramp-temp-name-prefix @@ -164,7 +177,7 @@ It has the same meaning as `remote-file-name-inhibit-cache'.") ;; cannot use `with-tramp-file-property', because we don't want to ;; cache a nil result. (let ((remote-file-name-inhibit-cache tramp-fuse-mount-timeout)) - (or (tramp-get-file-property vec "/" "mounted" nil) + (or (tramp-get-file-property vec "/" "mounted") (let* ((default-directory tramp-compat-temporary-file-directory) (command (format "mount -t fuse.%s" (tramp-file-name-method vec))) (mount (shell-command-to-string command))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 221ee547a2b..056237fd55c 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -796,6 +796,7 @@ It has been changed in GVFS 1.14.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -805,6 +806,7 @@ It has been changed in GVFS 1.14.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-gvfs-handle-rename-file) (set-file-acl . ignore) @@ -816,6 +818,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) @@ -836,6 +839,8 @@ Operations not mentioned here will be handled by the default Emacs primitives.") (let ((method (tramp-file-name-method vec))) (and (stringp method) (member method tramp-gvfs-methods))))) +(defvar tramp-gvfs-dbus-event-vector) + ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) "Invoke the GVFS related OPERATION and ARGS. @@ -843,7 +848,11 @@ First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled (tramp-user-error nil "Package `tramp-gvfs' not supported")) - (if-let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) + (if-let ((filename (apply #'tramp-file-name-for-operation operation args)) + (tramp-gvfs-dbus-event-vector + (and (tramp-tramp-file-p filename) + (tramp-dissect-file-name filename))) + (fn (assoc operation tramp-gvfs-file-name-handler-alist))) (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args))) @@ -916,8 +925,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. @@ -932,12 +939,11 @@ 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 -is no information where to trace the message.") +is no information where to trace the message. +Globally, the value shall always be nil; it is bound where needed.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." @@ -1014,7 +1020,7 @@ file names." ;; We cannot copy or rename directly. ((or (and equal-remote - (tramp-get-connection-property v "direct-copy-failed" nil)) + (tramp-get-connection-property v "direct-copy-failed")) (and t1 (not (tramp-gvfs-file-name-p filename))) (and t2 (not (tramp-gvfs-file-name-p newname)))) (let ((tmpfile (tramp-compat-make-temp-file filename))) @@ -1051,7 +1057,7 @@ file names." (if (or (not equal-remote) (and equal-remote (tramp-get-connection-property - v "direct-copy-failed" nil))) + v "direct-copy-failed"))) ;; Propagate the error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -1139,22 +1145,22 @@ file names." (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) + (tramp-run-real-handler #'expand-file-name (list name)) ;; 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))) - (unless (string-empty-p - (tramp-get-connection-property v "default-location" "")) - (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 (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 "/..". @@ -1172,7 +1178,7 @@ file names." ;; Do normal `expand-file-name' (this does "/./" and "/../"), ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (if (string-match-p "\\`~" localname) + v (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) localname (tramp-run-real-handler #'expand-file-name (list localname))))))) @@ -1330,32 +1336,29 @@ If FILE-SYSTEM is non-nil, return file system attributes." (or (cdr (assoc "standard::size" attributes)) "0"))) ;; ... file mode flags (setq res-filemodes - (let ((n (cdr (assoc "unix::mode" attributes)))) - (if n - (tramp-file-mode-from-int (string-to-number n)) - (format - "%s%s%s%s------" - (if dirp "d" (if res-symlink-target "l" "-")) - (if (equal (cdr (assoc "access::can-read" attributes)) - "FALSE") - "-" "r") - (if (equal (cdr (assoc "access::can-write" attributes)) - "FALSE") - "-" "w") - (if (equal (cdr (assoc "access::can-execute" attributes)) - "FALSE") - "-" "x"))))) + (if-let ((n (cdr (assoc "unix::mode" attributes)))) + (tramp-file-mode-from-int (string-to-number n)) + (format + "%s%s%s%s------" + (if dirp "d" (if res-symlink-target "l" "-")) + (if (equal (cdr (assoc "access::can-read" attributes)) + "FALSE") + "-" "r") + (if (equal (cdr (assoc "access::can-write" attributes)) + "FALSE") + "-" "w") + (if (equal (cdr (assoc "access::can-execute" attributes)) + "FALSE") + "-" "x")))) ;; ... inode and device (setq res-inode - (let ((n (cdr (assoc "unix::inode" attributes)))) - (if n - (string-to-number n) - (tramp-get-inode (tramp-dissect-file-name filename))))) + (if-let ((n (cdr (assoc "unix::inode" attributes)))) + (string-to-number n) + (tramp-get-inode (tramp-dissect-file-name filename)))) (setq res-device - (let ((n (cdr (assoc "unix::device" attributes)))) - (if n - (string-to-number n) - (tramp-get-device (tramp-dissect-file-name filename))))) + (if-let ((n (cdr (assoc "unix::device" attributes)))) + (string-to-number n) + (tramp-get-device (tramp-dissect-file-name filename)))) ;; Return data gathered. (list @@ -1389,7 +1392,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." @@ -1575,8 +1579,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) (when (looking-at-p "gio: Operation not supported") - (tramp-set-connection-property vec key nil))) - nil)))) + (tramp-set-connection-property vec key nil))))))) (defun tramp-gvfs-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -1600,15 +1603,33 @@ If FILE-SYSTEM is non-nil, return file system attributes." 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")) + result) + (cond + ((zerop (length localname)) + (tramp-get-connection-property (tramp-get-process vec) "share")) + ;; 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'." (if (equal id-format 'string) (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-get-connection-property (tramp-get-process vec) "share"))) (file-attribute-user-id (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) @@ -1616,9 +1637,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'." (when-let ((localname - (tramp-get-connection-property - (tramp-get-process vec) "share" - (tramp-get-connection-property vec "default-location" nil)))) + (tramp-get-connection-property (tramp-get-process vec) "share"))) (file-attribute-group-id (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) @@ -1656,7 +1675,7 @@ ID-FORMAT valid values are `string' and `integer'." (concat (tramp-gvfs-get-remote-prefix v) localname))) (when (string-equal "mtp" method) (when-let - ((media (tramp-get-connection-property v "media-device" nil))) + ((media (tramp-get-connection-property v "media-device"))) (setq method (tramp-media-device-method media) host (tramp-media-device-host media) port (tramp-media-device-port media)))) @@ -1731,7 +1750,7 @@ a downcased host name only." (setq domain (read-string "Domain name: "))) (tramp-message l 6 "%S %S %S %d" message user domain flags) - (unless (tramp-get-connection-property l "first-password-request" nil) + (unless (tramp-get-connection-property l "first-password-request") (tramp-clear-passwd l)) (setq password (tramp-read-passwd @@ -1769,22 +1788,26 @@ a downcased host name only." (list t ;; handled. nil ;; no abort of D-Bus. - (with-tramp-connection-property (tramp-get-process v) message - ;; In theory, there can be several choices. - ;; Until now, there is only the question whether - ;; to accept an unknown host signature or certificate. - (with-temp-buffer - ;; Preserve message for `progress-reporter'. - (with-temp-message "" - (insert message) - (goto-char (point-max)) - (if noninteractive - (message "%s" message) - (pop-to-buffer (current-buffer))) - (if (yes-or-no-p - (buffer-substring - (line-beginning-position) (point))) - 0 1))))) + ;; Preserve message for `progress-reporter'. + (with-temp-message "" + (if noninteractive + ;; Keep regression tests running. + (progn + (message "%s" message) + 0) + (with-tramp-connection-property (tramp-get-process v) message + ;; In theory, there can be several choices. + ;; Until now, there is only the question + ;; whether to accept an unknown host + ;; signature or certificate. + (with-temp-buffer + (insert message) + (goto-char (point-max)) + (pop-to-buffer (current-buffer)) + (if (yes-or-no-p + (buffer-substring + (line-beginning-position) (point))) + 0 1)))))) ;; When QUIT is raised, we shall return this ;; information to D-Bus. @@ -1849,14 +1872,13 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (when (member method tramp-media-methods) ;; Ensure that media devices are cached. (tramp-get-media-devices nil) - (let ((v (tramp-get-connection-property - (make-tramp-media-device - :method method :host host :port port) - "vector" nil))) - (when v - (setq method (tramp-file-name-method v) - host (tramp-file-name-host v) - port (tramp-file-name-port v))))) + (when-let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v)))) (when (member method tramp-gvfs-methods) (let ((v (make-tramp-file-name :method method :user user :domain domain @@ -1894,15 +1916,14 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (defun tramp-gvfs-connection-mounted-p (vec) "Check, whether the location is already mounted." (or - (tramp-get-file-property vec "/" "fuse-mountpoint" nil) + (tramp-get-file-property vec "/" "fuse-mountpoint") (catch 'mounted (dolist (elt (with-tramp-file-property vec "/" "list-mounts" (with-tramp-dbus-call-method vec t :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker - tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts)) - nil) + tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts))) ;; Jump over the first elements of the mount info. Since there ;; were changes in the entries, we cannot access dedicated ;; elements. @@ -1951,14 +1972,13 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (when (member method tramp-media-methods) ;; Ensure that media devices are cached. (tramp-get-media-devices vec) - (let ((v (tramp-get-connection-property - (make-tramp-media-device - :method method :host host :port port) - "vector" nil))) - (when v - (setq method (tramp-file-name-method v) - host (tramp-file-name-host v) - port (tramp-file-name-port v))))) + (when-let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector"))) + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v)))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) @@ -2112,10 +2132,6 @@ connection if a previous connection has died for some reason." (unless (tramp-connectable-p vec) (throw 'non-essential 'non-essential)) - ;; We set the file name, in case there are incoming D-Bus signals or - ;; D-Bus errors. - (setq tramp-gvfs-dbus-event-vector vec) - ;; For password handling, we need a process bound to the connection ;; buffer. Therefore, we create a dummy process. Maybe there is a ;; better solution? @@ -2218,7 +2234,7 @@ connection if a previous connection has died for some reason." (tramp-error vec 'file-error "Timeout reached mounting %s@%s using %s" user host method))) - (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil)) + (while (not (tramp-get-file-property vec "/" "fuse-mountpoint")) (read-event nil nil 0.1))) ;; If `tramp-gvfs-handler-askquestion' has returned "No", it @@ -2246,13 +2262,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)) @@ -2262,7 +2272,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))))) @@ -2355,11 +2372,11 @@ It checks for registered GNOME Online Accounts." (defun tramp-get-media-device (vec) "Transform VEC into a `tramp-media-device' structure. Check, that respective cache values do exist." - (if-let ((media (tramp-get-connection-property vec "media-device" nil)) - (prop (tramp-get-connection-property media "vector" nil))) + (if-let ((media (tramp-get-connection-property vec "media-device")) + (prop (tramp-get-connection-property media "vector"))) media (tramp-get-media-devices vec) - (tramp-get-connection-property vec "media-device" nil))) + (tramp-get-connection-property vec "media-device"))) (defun tramp-get-media-devices (vec) "Retrieve media devices, and cache them. @@ -2404,9 +2421,9 @@ It checks for mounted media devices." (lambda (key) (and (tramp-media-device-p key) (string-equal service (tramp-media-device-method key)) - (tramp-get-connection-property key "vector" nil) + (tramp-get-connection-property key "vector") (list nil (tramp-file-name-host - (tramp-get-connection-property key "vector" nil))))) + (tramp-get-connection-property key "vector"))))) (hash-table-keys tramp-cache-data))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 03a2c2457a2..226113d8800 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -39,6 +39,7 @@ (declare-function info-lookup->topic-value "info-look") (declare-function info-lookup-maybe-add-help "info-look") (declare-function recentf-cleanup "recentf") +(declare-function shortdoc-add-function "shortdoc") (declare-function tramp-dissect-file-name "tramp") (declare-function tramp-file-name-equal-p "tramp") (declare-function tramp-tramp-file-p "tramp") @@ -49,6 +50,7 @@ (defvar info-lookup-alist) (defvar ivy-completing-read-handlers-alist) (defvar recentf-exclude) +(defvar shortdoc--groups) (defvar tramp-current-connection) (defvar tramp-postfix-host-format) (defvar tramp-use-ssh-controlmaster-options) @@ -106,7 +108,7 @@ been set up by `rfn-eshadow-setup-minibuffer'." end)) (point-max)) (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay) - (rfn-eshadow-update-overlay-hook nil) + rfn-eshadow-update-overlay-hook file-name-handler-alist) (move-overlay rfn-eshadow-overlay (point-max) (point-max)) (rfn-eshadow-update-overlay)))))))) @@ -257,6 +259,33 @@ NAME must be equal to `tramp-current-connection'." (delete (info-lookup->mode-cache 'symbol ',mode) (info-lookup->topic-cache 'symbol)))))))) +;;; Integration of shortdoc.el: + +(with-eval-after-load 'shortdoc + (dolist (elem '((file-remote-p + :eval (file-remote-p "/ssh:user@host:/tmp/foo") + :eval (file-remote-p "/ssh:user@host:/tmp/foo" 'method)) + (file-local-name + :eval (file-local-name "/ssh:user@host:/tmp/foo")) + (file-local-copy + :no-eval (file-local-copy "/ssh:user@host:/tmp/foo") + :eg-result "/tmp/tramp.8ihLbO" + :eval (file-local-copy "/tmp/foo")))) + (unless (assoc (car elem) + (member "Remote Files" (assq 'file shortdoc--groups))) + (shortdoc-add-function 'file "Remote Files" elem))) + + (add-hook + 'tramp-integration-unload-hook + (lambda () + (let ((glist (assq 'file shortdoc--groups))) + (while (and (consp glist) + (not (and (stringp (cadr glist)) + (string-equal (cadr glist) "Remote Files")))) + (setq glist (cdr glist))) + (when (consp glist) + (setcdr glist nil)))))) + ;;; Integration of compile.el: ;; Compilation processes use `accept-process-output' such a way that @@ -271,7 +300,7 @@ 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. @@ -303,6 +332,220 @@ NAME must be equal to `tramp-current-connection'." '(:application tramp) 'tramp-connection-local-default-shell-profile)) +;; Tested with FreeBSD 12.2. +(defconst tramp-bsd-process-attributes-ps-args + `("-acxww" + "-o" + ,(mapconcat + #'identity + '("pid" + "euid" + "user" + "egid" + "egroup" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" + ,(mapconcat + #'identity + '("state" + "ppid" + "pgid" + "sid" + "tty" + "tpgid" + "minflt" + "majflt" + "time" + "pri" + "nice" + "vsz" + "rss" + "etimes" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-bsd-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (group . string) + (comm . 52) + (state . string) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . tramp-ps-time) + (pri . number) + (nice . number) + (vsize . number) + (rss . number) + (etime . number) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-bsd-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-bsd-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-bsd-process-attributes-ps-format)) + "Default connection-local ps variables for remote BSD connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-bsd-ps-profile + tramp-connection-local-bsd-ps-variables) + +;; Tested with BusyBox v1.24.1. +(defconst tramp-busybox-process-attributes-ps-args + `("-o" + ,(mapconcat + #'identity + '("pid" + "user" + "group" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" "stat=abcde" + "-o" + ,(mapconcat + #'identity + '("ppid" + "pgid" + "tty" + "time" + "nice" + "etime" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-busybox-process-attributes-ps-format + '((pid . number) + (user . string) + (group . string) + (comm . 52) + (state . 5) + (ppid . number) + (pgrp . number) + (ttname . string) + (time . tramp-ps-time) + (nice . number) + (etime . tramp-ps-time) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-busybox-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-busybox-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-busybox-process-attributes-ps-format)) + "Default connection-local ps variables for remote Busybox connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-busybox-ps-profile + tramp-connection-local-busybox-ps-variables) + +;; Darwin (macOS). +(defconst tramp-darwin-process-attributes-ps-args + `("-acxww" + "-o" + ,(mapconcat + #'identity + '("pid" + "uid" + "user" + "gid" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" "state=abcde" + "-o" + ,(mapconcat + #'identity + '("ppid" + "pgid" + "sess" + "tty" + "tpgid" + "minflt" + "majflt" + "time" + "pri" + "nice" + "vsz" + "rss" + "etime" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-darwin-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (comm . 52) + (state . 5) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . tramp-ps-time) + (pri . number) + (nice . number) + (vsize . number) + (rss . number) + (etime . tramp-ps-time) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-darwin-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-darwin-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-darwin-process-attributes-ps-format)) + "Default connection-local ps variables for remote Darwin connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-darwin-ps-profile + tramp-connection-local-darwin-ps-variables) + +;; Preset default "ps" profile for local hosts, based on system type. + +(when-let ((local-profile + (cond ((eq system-type 'darwin) + 'tramp-connection-local-darwin-ps-profile) + ;; ... Add other system types here. + ))) + (connection-local-set-profiles + `(:application tramp :machine ,(system-name)) + local-profile) + (connection-local-set-profiles + '(:application tramp :machine "localhost") + local-profile)) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-integration 'force))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 259e85a04a3..bbc76851318 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -107,9 +107,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-rclone-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) @@ -123,6 +123,7 @@ ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -132,6 +133,7 @@ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-rclone-handle-rename-file) (set-file-acl . ignore) @@ -143,6 +145,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) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 72b1ebb3e06..174fde720e4 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -38,6 +38,7 @@ (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) @@ -117,7 +118,7 @@ configuration." "Which ssh Control* arguments to use. If it is a string, it should have the form -\"-o ControlMaster=auto -o ControlPath=\\='tramp.%%r@%%h:%%p\\=' +\"-o ControlMaster=auto -o ControlPath=tramp.%%C -o ControlPersist=no\". Percent characters in the ControlPath spec must be doubled, because the string is used as format string. @@ -136,6 +137,21 @@ be auto-detected by Tramp. The string is used in `tramp-methods'.") +(defvar tramp-scp-force-scp-protocol nil + "Force scp protocol. + +It is the string \"-O\" if supported by the local scp (since +release 8.6), otherwise the string \"\". If it is nil, it will +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 @@ -172,7 +188,8 @@ 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") ("%z") + ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -188,7 +205,8 @@ 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") ("%z") + ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -294,7 +312,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") @@ -302,7 +321,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") @@ -996,6 +1016,7 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -1005,6 +1026,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-sh-handle-process-file) (rename-file . tramp-sh-handle-rename-file) (set-file-acl . tramp-sh-handle-set-file-acl) @@ -1016,6 +1038,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) @@ -1123,8 +1146,8 @@ component is used as the target of the symlink." ;; Use Perl implementation. ((and (tramp-get-remote-perl v) - (tramp-get-connection-property v "perl-file-spec" nil) - (tramp-get-connection-property v "perl-cwd-realpath" nil)) + (tramp-get-connection-property v "perl-file-spec") + (tramp-get-connection-property v "perl-cwd-realpath")) (tramp-maybe-send-script v tramp-perl-file-truename "tramp_perl_file_truename") (setq result @@ -1149,8 +1172,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. @@ -1163,9 +1185,9 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-exists-p" (or (not (null (tramp-get-file-property - v localname "file-attributes-integer" nil))) + v localname "file-attributes-integer"))) (not (null (tramp-get-file-property - v localname "file-attributes-string" nil))) + v localname "file-attributes-string"))) (tramp-send-command-and-check v (format @@ -1194,12 +1216,18 @@ component is used as the target of the symlink." ;; The scripts could fail, for example with huge file size. (tramp-do-file-attributes-with-ls v localname id-format)))))))) +(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + "Regexp to determine remote SunOS.") + (defun tramp-sh--quoting-style-options (vec) "Quoting style options to be used for VEC." (or (tramp-get-ls-command-with vec "--quoting-style=literal --show-control-chars") - (tramp-get-ls-command-with vec "-w") + ;; ls on Solaris does not return an error in that case. We've got + ;; reports for "SunOS 5.11" so far. + (unless (tramp-check-remote-uname vec tramp-sunos-unames) + (tramp-get-ls-command-with vec "-w")) "")) (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) @@ -1435,12 +1463,26 @@ of." v (format "env TZ=UTC %s %s %s %s" (tramp-get-remote-touch v) - (if (tramp-get-connection-property v "touch-t" nil) + (if (tramp-get-connection-property v "touch-t") (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t)) "") (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-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'." @@ -1579,6 +1621,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) @@ -2241,200 +2284,211 @@ 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") + "") + ;; 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-force-scp-protocol v) + ?z (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 + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + ;; 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))))) + + ;; 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 - (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." @@ -2681,7 +2735,9 @@ The method used must be an out-of-band method." ;; Try to insert the amount of free space. (goto-char (point-min)) ;; First find the line to put it on. - (when (re-search-forward "^\\([[:space:]]*total\\)" nil t) + (when (and (re-search-forward "^\\([[:space:]]*total\\)" nil t) + ;; Emacs 29.1 or later. + (not (fboundp 'dired--insert-disk-space))) (when-let ((available (get-free-disk-space "."))) ;; Replace "total" with "total used", to avoid confusion. (replace-match "\\1 used in directory") @@ -2715,34 +2771,28 @@ the result will be a local, non-Tramp, file 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)) + (tramp-run-real-handler #'expand-file-name (list name)) (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) @@ -2750,15 +2800,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: @@ -2824,6 +2876,7 @@ implementation will be used." stderr (tramp-make-tramp-temp-name v))))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -2835,8 +2888,10 @@ implementation will be used." (string-match-p "sh$" program) (= (length args) 2) (string-equal "-c" (car args)) - ;; Don't if there is a string. - (not (string-match-p "'\\|\"" (cadr args))))) + ;; Don't if there is a quoted string. + (not (string-match-p "'\\|\"" (cadr args))) + ;; Check, that /dev/tty is usable. + (tramp-get-remote-dev-tty v))) ;; When PROGRAM is nil, we just provide a tty. (args (if (not heredoc) args (let ((i 250)) @@ -2852,7 +2907,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'. @@ -2921,91 +2976,103 @@ implementation will be used." (setq i (1+ i) name1 (format "%s<%d>" name i))) (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' - ;; could be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (mark (point-max)) - (coding-system-for-write - (if (symbolp coding) coding (car coding))) - (coding-system-for-read - (if (symbolp coding) coding (cdr coding)))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - (catch 'suppress - ;; Set the pid of the remote shell. This is - ;; needed when sending signals remotely. - (let ((pid (tramp-send-command-and-read v "echo $$"))) - (setq p (tramp-get-connection-process v)) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) - ;; Disable carriage return to newline - ;; translation. This does not work on - ;; macOS, see Bug#50748. - (when (and (memq connection-type '(nil pipe)) - (not (tramp-check-remote-uname v "Darwin"))) - (tramp-send-command v "stty -icrnl")) - ;; `tramp-maybe-open-connection' and - ;; `tramp-send-command-and-read' could have - ;; trashed the connection buffer. Remove this. - (widen) - (delete-region mark (point-max)) - (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" - name)))) - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, + ;; `make-process' could be called on the local + ;; host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save + ;; BUFFER contents. Clear also the + ;; modification time; otherwise we might be + ;; interrupted by `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max)) + (coding-system-for-write + (if (symbolp coding) coding (car coding))) + (coding-system-for-read + (if (symbolp coding) coding (cdr coding)))) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + (catch 'suppress + ;; Set the pid of the remote shell. This is + ;; needed when sending signals remotely. + (let ((pid + (tramp-send-command-and-read v "echo $$"))) + (setq p (tramp-get-connection-process v)) + (process-put p 'remote-pid pid) + (tramp-set-connection-property + p "remote-pid" pid)) + ;; Disable carriage return to newline + ;; translation. This does not work on + ;; macOS, see Bug#50748. + (when (and (memq connection-type '(nil pipe)) + (not + (tramp-check-remote-uname v "Darwin"))) + (tramp-send-command v "stty -icrnl")) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could have + ;; trashed the connection buffer. Remove this. + (widen) + (delete-region mark (point-max)) + (narrow-to-region (point-max) (point-max)) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) + ;; Set query flag and process marker for + ;; this process. We ignore errors, + ;; because the process could have finished + ;; already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; + ;; otherwise `delete-file' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Kill stderr process and delete named pipe. + (when (bufferp stderr) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (ignore-errors + (while (accept-process-output + (get-buffer-process stderr) 0 nil t)) + (delete-process (get-buffer-process stderr))) + (ignore-errors + (delete-file remote-tmpstderr))))) + ;; Return process. + p))) + + ;; Save exit. + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; Kill stderr process and delete named pipe. - (when (bufferp stderr) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (ignore-errors - (while (accept-process-output - (get-buffer-process stderr) 0 nil t)) - (delete-process (get-buffer-process stderr))) - (ignore-errors - (delete-file remote-tmpstderr))))) - ;; Return process. - p))) - - ;; Save exit. - (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer"))))))))) + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)))))))))))) (defun tramp-sh-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." @@ -3013,7 +3080,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 @@ -3098,13 +3165,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))) @@ -3132,11 +3199,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))))) @@ -3153,7 +3220,8 @@ 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. @@ -3184,8 +3252,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. @@ -3282,251 +3349,197 @@ implementation will be used." (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (uid (or (file-attribute-user-id (file-attributes filename 'integer)) - (tramp-get-remote-uid v 'integer))) - (gid (or (file-attribute-group-id (file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer)))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - - (if (and (tramp-local-host-p v) - ;; `file-writable-p' calls `file-expand-file-name'. We - ;; cannot use `tramp-run-real-handler' therefore. - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))) - ;; Short track: if we are on the local host, we can run directly. - (let ((create-lockfiles (not file-locked))) - (write-region start end localname append 'no-message lockname)) - - (let* ((modes (tramp-default-file-modes - filename (and (eq mustbenew 'excl) 'nofollow))) - ;; We use this to save the value of - ;; `last-coding-system-used' after writing the tmp - ;; file. At the end of the function, we set - ;; `last-coding-system-used' to this saved value. This - ;; way, any intermediary coding systems used while - ;; talking to the remote shell or suchlike won't hose - ;; this variable. This approach was snarfed from - ;; ange-ftp.el. - coding-system-used - ;; Write region into a tmp file. This isn't really - ;; needed if we use an encoding function, but currently - ;; we use it always because this makes the logic - ;; simpler. We must also set `temporary-file-directory', - ;; because it could point to a remote directory. - (temporary-file-directory tramp-compat-temporary-file-directory) - (tmpfile (or tramp-temp-buffer-file-name - (tramp-compat-make-temp-file filename)))) - - ;; If `append' is non-nil, we copy the file locally, and let - ;; the native `write-region' implementation do the job. - (when (and append (file-exists-p filename)) - (copy-file filename tmpfile 'ok)) - - ;; We say `no-message' here because we don't want the - ;; visited file modtime data to be clobbered from the temp - ;; file. We call `set-visited-file-modtime' ourselves later - ;; on. We must ensure that `file-coding-system-alist' - ;; matches `tmpfile'. - (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile)) - create-lockfiles) - (condition-case err - (write-region start end tmpfile append 'no-message) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Now, `last-coding-system-used' has the right value. Remember it. - (setq coding-system-used last-coding-system-used)) - - ;; The permissions of the temporary file should be set. If - ;; FILENAME does not exist (eq modes nil) it has been - ;; renamed to the backup file. This case `save-buffer' - ;; handles permissions. - ;; Ensure that it is still readable. - (when modes - (set-file-modes tmpfile (logior (or modes 0) #o0400))) - - ;; This is a bit lengthy due to the different methods - ;; possible for file transfer. First, we check whether the - ;; method uses an scp program. If so, we call it. - ;; Otherwise, both encoding and decoding command must be - ;; specified. However, if the method _also_ specifies an - ;; encoding function, then that is used for encoding the - ;; contents of the tmp file. - (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 - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (if (and (not (stringp start)) - (= (or end (point-max)) (point-max)) - (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter v 'tramp-copy-keep-tmpfile)) - (progn - (setq tramp-temp-buffer-file-name tmpfile) - (condition-case err - ;; We keep the local file for performance - ;; reasons, useful for "rsync". - (copy-file tmpfile filename t) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err))))) - (setq tramp-temp-buffer-file-name nil) - ;; Don't rename, in order to keep context in SELinux. - (unwind-protect - (copy-file tmpfile filename t) - (delete-file tmpfile)))) - - ;; Use inline file transfer. - (rem-dec - ;; Encode tmpfile. + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (if (and (tramp-local-host-p v) + ;; `file-writable-p' calls `file-expand-file-name'. We + ;; cannot use `tramp-run-real-handler' therefore. + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))) + ;; Short track: if we are on the local host, we can run directly. + (let ((create-lockfiles (not file-locked))) + (write-region start end localname append 'no-message lockname)) + + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + ;; We use this to save the value of + ;; `last-coding-system-used' after writing the tmp file. + ;; At the end of the function, we set + ;; `last-coding-system-used' to this saved value. This + ;; way, any intermediary coding systems used while + ;; talking to the remote shell or suchlike won't hose + ;; this variable. This approach was snarfed from + ;; ange-ftp.el. + coding-system-used + ;; Write region into a tmp file. This isn't really + ;; needed if we use an encoding function, but currently + ;; we use it always because this makes the logic simpler. + ;; We must also set `temporary-file-directory', because + ;; it could point to a remote directory. + (temporary-file-directory + tramp-compat-temporary-file-directory) + (tmpfile (or tramp-temp-buffer-file-name + (tramp-compat-make-temp-file filename)))) + + ;; If `append' is non-nil, we copy the file locally, and let + ;; the native `write-region' implementation do the job. + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) + + ;; We say `no-message' here because we don't want the visited + ;; file modtime data to be clobbered from the temp file. We + ;; call `set-visited-file-modtime' ourselves later on. We + ;; must ensure that `file-coding-system-alist' matches + ;; `tmpfile'. + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist filename tmpfile)) + create-lockfiles) + (condition-case err + (write-region start end tmpfile append 'no-message) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Now, `last-coding-system-used' has the right value. + ;; Remember it. + (setq coding-system-used last-coding-system-used)) + + ;; The permissions of the temporary file should be set. If + ;; FILENAME does not exist (eq modes nil) it has been renamed + ;; to the backup file. This case `save-buffer' handles + ;; permissions. Ensure that it is still readable. + (when modes + (set-file-modes tmpfile (logior (or modes 0) #o0400))) + + ;; This is a bit lengthy due to the different methods possible + ;; for file transfer. First, we check whether the method uses + ;; an scp program. If so, we call it. Otherwise, both + ;; encoding and decoding command must be specified. However, + ;; if the method _also_ specifies an encoding function, then + ;; that is used for encoding the contents of the tmp file. + (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 + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (if (and (not (stringp start)) + (= (or end (point-max)) (point-max)) + (= (or start (point-min)) (point-min)) + (tramp-get-method-parameter + v 'tramp-copy-keep-tmpfile)) + (progn + (setq tramp-temp-buffer-file-name tmpfile) + (condition-case err + ;; We keep the local file for performance + ;; reasons, useful for "rsync". + (copy-file tmpfile filename t) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err))))) + (setq tramp-temp-buffer-file-name nil) + ;; Don't rename, in order to keep context in SELinux. (unwind-protect - (with-temp-buffer - (set-buffer-multibyte nil) - ;; Use encoding function or command. - (with-tramp-progress-reporter - v 3 (format-message - "Encoding local file `%s' using `%s'" - tmpfile loc-enc) - (if (functionp loc-enc) - ;; The following `let' is a workaround for - ;; the base64.el that comes with pgnus-0.84. - ;; If both of the following conditions are - ;; satisfied, it tries to write to a local - ;; file in default-directory, but at this - ;; point, default-directory is remote. - ;; (`call-process-region' can't write to - ;; remote files, it seems.) The file in - ;; question is a tmp file anyway. - (let ((coding-system-for-read 'binary) - (default-directory - tramp-compat-temporary-file-directory)) - (insert-file-contents-literally tmpfile) - (funcall loc-enc (point-min) (point-max))) - - (unless (zerop (tramp-call-local-coding-command - loc-enc tmpfile t)) - (tramp-error - v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") - filename loc-enc)))) - - ;; Send buffer into remote decoding command which - ;; writes to remote file. Because this happens on - ;; the remote host, we cannot use the function. - (with-tramp-progress-reporter - v 3 (format-message - "Decoding remote file `%s' using `%s'" - filename rem-dec) - (goto-char (point-max)) - (unless (bolp) (newline)) - (tramp-send-command - v - (format - (concat rem-dec " <<'%s'\n%s%s") - (tramp-shell-quote-argument localname) - tramp-end-of-heredoc - (buffer-string) - tramp-end-of-heredoc)) - (tramp-barf-unless-okay - v nil - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec) - ;; When `file-precious-flag' is set, the region is - ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfile. - (when file-precious-flag - (erase-buffer) - (and - ;; cksum runs locally, if possible. - (zerop (tramp-call-process v "cksum" tmpfile t)) - ;; cksum runs remotely. - (tramp-send-command-and-check - v - (format - "cksum <%s" (tramp-shell-quote-argument localname))) - ;; ... they are different. - (not - (string-equal - (buffer-string) - (tramp-get-buffer-string (tramp-get-buffer v)))) - (tramp-error - v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") - filename rem-dec))))) + (copy-file tmpfile filename t) + (delete-file tmpfile)))) - ;; Save exit. - (delete-file tmpfile))) - - ;; That's not expected. - (t - (tramp-error - v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program") - method)))) + ;; Use inline file transfer. + (rem-dec + ;; Encode tmpfile. + (unwind-protect + (with-temp-buffer + (set-buffer-multibyte nil) + ;; Use encoding function or command. + (with-tramp-progress-reporter + v 3 (format-message + "Encoding local file `%s' using `%s'" + tmpfile loc-enc) + (if (functionp loc-enc) + ;; The following `let' is a workaround for the + ;; base64.el that comes with pgnus-0.84. If + ;; both of the following conditions are + ;; satisfied, it tries to write to a local + ;; file in default-directory, but at this + ;; point, default-directory is remote. + ;; (`call-process-region' can't write to + ;; remote files, it seems.) The file in + ;; question is a tmp file anyway. + (let ((coding-system-for-read 'binary) + (default-directory + tramp-compat-temporary-file-directory)) + (insert-file-contents-literally tmpfile) + (funcall loc-enc (point-min) (point-max))) + + (unless (zerop (tramp-call-local-coding-command + loc-enc tmpfile t)) + (tramp-error + v 'file-error + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") + filename loc-enc)))) + + ;; Send buffer into remote decoding command which + ;; writes to remote file. Because this happens on + ;; the remote host, we cannot use the function. + (with-tramp-progress-reporter + v 3 (format-message + "Decoding remote file `%s' using `%s'" + filename rem-dec) + (goto-char (point-max)) + (unless (bolp) (newline)) + (tramp-send-command + v + (format + (concat rem-dec " <<'%s'\n%s%s") + (tramp-shell-quote-argument localname) + tramp-end-of-heredoc + (buffer-string) + tramp-end-of-heredoc)) + (tramp-barf-unless-okay + v nil + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec) + ;; When `file-precious-flag' is set, the region is + ;; written to a temporary file. Check that the + ;; checksum is equal to that from the local tmpfile. + (when file-precious-flag + (erase-buffer) + (and + ;; cksum runs locally, if possible. + (zerop (tramp-call-process v "cksum" tmpfile t)) + ;; cksum runs remotely. + (tramp-send-command-and-check + v + (format + "cksum <%s" + (tramp-shell-quote-argument localname))) + ;; ... they are different. + (not + (string-equal + (buffer-string) + (tramp-get-buffer-string (tramp-get-buffer v)))) + (tramp-error + v 'file-error + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec))))) - ;; Make `last-coding-system-used' have the right value. - (when coding-system-used - (setq last-coding-system-used coding-system-used)))) + ;; Save exit. + (delete-file tmpfile))) - (tramp-flush-file-properties v localname) + ;; That's not expected. + (t + (tramp-error + v 'file-error + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program") + method)))) - ;; We must protect `last-coding-system-used', now we have set it - ;; to its correct value. - (let (last-coding-system-used (need-chown t)) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (let ((file-attr (file-attributes filename 'integer))) - (set-visited-file-modtime - ;; We must pass modtime explicitly, because FILENAME can - ;; be different from (buffer-file-name), f.e. if - ;; `file-precious-flag' is set. - (or (file-attribute-modification-time file-attr) - (current-time))) - (when (and (= (file-attribute-user-id file-attr) uid) - (= (file-attribute-group-id file-attr) gid)) - (setq need-chown nil)))) - - ;; Set the ownership. - (when need-chown - (tramp-set-file-uid-gid filename uid gid)) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))))) + ;; Make `last-coding-system-used' have the right value. + (when coding-system-used + (setq last-coding-system-used coding-system-used)))))) (defvar tramp-vc-registered-file-names nil "List used to collect file names, which are checked during `vc-registered'.") @@ -3650,8 +3663,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. @@ -3964,7 +3976,7 @@ Only send the definition if it has not already been done." ;; We cannot let-bind (tramp-get-connection-process vec) because it ;; might be nil. (let ((scripts (tramp-get-connection-property - (tramp-get-connection-process vec) "scripts" nil))) + (tramp-get-connection-process vec) "scripts"))) (unless (member name scripts) (with-tramp-progress-reporter vec 5 (format-message "Sending script `%s'" name) @@ -3997,9 +4009,6 @@ Returns the exit code of the `test' program." switch (tramp-shell-quote-argument localname))))) -(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) - "Regexp to determine remote SunOS.") - (defun tramp-find-executable (vec progname dirlist &optional ignore-tilde ignore-path) "Search for PROGNAME in $PATH and all directories mentioned in DIRLIST. @@ -4105,13 +4114,10 @@ file exists and nonzero exit status otherwise." ;; The algorithm is as follows: we try a list of several commands. ;; For each command, we first run `$cmd /' -- this should return ;; true, as the root directory always exists. And then we run - ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed - ;; does not exist. This should return false. We use the first - ;; command we find that seems to work. + ;; `$cmd /\ this\ file\ does\ not\ exist\ ', hoping that the file + ;; indeed does not exist. This should return false. We use the + ;; first command we find that seems to work. ;; The list of commands to try is as follows: - ;; `ls -d' This works on most systems, but NetBSD 1.4 - ;; has a bug: `ls' always returns zero exit - ;; status, even for files which don't exist. ;; `test -e' Some Bourne shells have a `test' builtin ;; which does not know the `-e' option. ;; `/bin/test -e' For those, the `test' binary on disk normally @@ -4119,6 +4125,10 @@ file exists and nonzero exit status otherwise." ;; is sometimes `/bin/test' and sometimes it's ;; `/usr/bin/test'. ;; `/usr/bin/test -e' In case `/bin/test' does not exist. + ;; `ls -d' This works on most systems, but NetBSD 1.4 + ;; has a bug: `ls' always returns zero exit + ;; status, even for files which don't exist. + (unless (or (ignore-errors (and (setq result (format "%s -e" (tramp-get-test-command vec))) @@ -4216,7 +4226,7 @@ file exists and nonzero exit status otherwise." (defun tramp-find-shell (vec) "Open a shell on the remote host which groks tilde expansion." ;; If we are in `make-process', we don't need another shell. - (unless (tramp-get-connection-property vec "process-name" nil) + (unless (tramp-get-connection-property vec "process-name") (with-current-buffer (tramp-get-buffer vec) (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) shell) @@ -4313,11 +4323,10 @@ process to set up. VEC specifies the connection." ;; connection properties. We start again with ;; `tramp-maybe-open-connection', it will be caught there. (tramp-message vec 5 "Checking system information") - (let* ((old-uname (tramp-get-connection-property vec "uname" nil)) + (let* ((old-uname (tramp-get-connection-property vec "uname")) (uname ;; If we are in `make-process', we don't need to recompute. - (if (and old-uname - (tramp-get-connection-property vec "process-name" nil)) + (if (and old-uname (tramp-get-connection-property vec "process-name")) old-uname (tramp-set-connection-property vec "uname" @@ -4765,36 +4774,33 @@ Goes through the list `tramp-inline-compress-commands'." (t (setq tramp-ssh-controlmaster-options "") (let ((case-fold-search t)) (ignore-errors - (when (executable-find "ssh") - (with-tramp-progress-reporter - vec 4 "Computing ControlMaster options" - (with-temp-buffer - (tramp-call-process vec "ssh" nil t nil "-o" "ControlMaster") - (goto-char (point-min)) - (when (search-forward-regexp "missing.+argument" nil t) - (setq tramp-ssh-controlmaster-options - "-o ControlMaster=auto"))) - (unless (zerop (length tramp-ssh-controlmaster-options)) - (with-temp-buffer - ;; We use a non-existing IP address, in order to - ;; avoid useless connections, and DNS timeouts. - ;; Setting ConnectTimeout is needed since OpenSSH 7. - (tramp-call-process - vec "ssh" nil t nil - "-o" "ConnectTimeout=1" "-o" "ControlPath=%C" "0.0.0.1") - (goto-char (point-min)) + (with-tramp-progress-reporter + vec 4 "Computing ControlMaster options" + ;; We use a non-existing IP address, in order to avoid + ;; useless connections, and DNS timeouts. + (when (zerop + (tramp-call-process + vec "ssh" nil nil nil + "-G" "-o" "ControlMaster=auto" "0.0.0.1")) + (setq tramp-ssh-controlmaster-options + "-o ControlMaster=auto") + (if (zerop + (tramp-call-process + vec "ssh" nil nil nil + "-G" "-o" "ControlPath=tramp.%C" "0.0.0.1")) (setq tramp-ssh-controlmaster-options (concat tramp-ssh-controlmaster-options - (if (search-forward-regexp "unknown.+key" nil t) - " -o ControlPath='tramp.%%r@%%h:%%p'" - " -o ControlPath='tramp.%%C'")))) - (with-temp-buffer - (tramp-call-process vec "ssh" nil t nil "-o" "ControlPersist") - (goto-char (point-min)) - (when (search-forward-regexp "missing.+argument" nil t) - (setq tramp-ssh-controlmaster-options - (concat tramp-ssh-controlmaster-options - " -o ControlPersist=no"))))))))) + " -o ControlPath=tramp.%%C")) + (setq tramp-ssh-controlmaster-options + (concat tramp-ssh-controlmaster-options + " -o ControlPath=tramp.%%r@%%h:%%p"))) + (when (zerop + (tramp-call-process + vec "ssh" nil nil nil + "-G" "-o" "ControlPersist=no" "0.0.0.1")) + (setq tramp-ssh-controlmaster-options + (concat tramp-ssh-controlmaster-options + " -o ControlPersist=no"))))))) tramp-ssh-controlmaster-options))) (defun tramp-scp-strict-file-name-checking (vec) @@ -4808,7 +4814,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 @@ -4824,11 +4830,111 @@ 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-force-scp-protocol (vec) + "Return the force scp protocol argument of the local scp." + (cond + ;; No options to be computed. + ((null (assoc "%y" (tramp-get-method-parameter vec 'tramp-copy-args))) + "") + + ;; There is already a value to be used. + ((stringp tramp-scp-force-scp-protocol) + tramp-scp-force-scp-protocol) + + ;; Determine the options. + (t (setq tramp-scp-force-scp-protocol "") + (let ((case-fold-search t)) + (ignore-errors + (when (executable-find "scp") + (with-tramp-progress-reporter + vec 4 "Computing force scp protocol argument" + (with-temp-buffer + (tramp-call-process vec "scp" nil t nil "-O") + (goto-char (point-min)) + (unless + (search-forward-regexp + "\\(illegal\\|unknown\\) option -- O" nil t) + (setq tramp-scp-force-scp-protocol "-O"))))))) + tramp-scp-force-scp-protocol))) + +(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 "%z" (tramp-get-method-parameter vec1 'tramp-copy-args))) + (null (assoc "%z" (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) "ssh-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." (if (and (tramp-get-connection-property - (tramp-get-connection-process vec) "locked" nil) + (tramp-get-connection-process vec) "locked") (tramp-file-name-equal-p vec (car tramp-current-connection))) (progn (tramp-message @@ -4847,13 +4953,14 @@ connection if a previous connection has died for some reason." (throw 'non-essential 'non-essential)) (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name" nil)) + (process-name (tramp-get-connection-property vec "process-name")) (process-environment (copy-sequence process-environment)) (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) ;; If Tramp opens the same connection within a short time frame, ;; there is a problem. We shall signal this. (unless (or (process-live-p p) + (and (processp p) (not non-essential)) (not (tramp-file-name-equal-p vec (car tramp-current-connection))) (time-less-p @@ -4917,8 +5024,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)) @@ -5003,9 +5109,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 @@ -5056,9 +5167,9 @@ connection if a previous connection has died for some reason." previous-hop hop))) ;; Activate session timeout. - (when (tramp-get-connection-property p "session-timeout" nil) + (when (tramp-get-connection-property p "session-timeout") (run-at-time - (tramp-get-connection-property p "session-timeout" nil) nil + (tramp-get-connection-property p "session-timeout") nil #'tramp-timeout-session vec)) ;; Make initial shell settings. @@ -5080,7 +5191,7 @@ is meant to be used from `tramp-maybe-open-connection' only. The function waits for output unless NOOUTPUT is set." (unless neveropen (tramp-maybe-open-connection vec)) (let ((p (tramp-get-connection-process vec))) - (when (tramp-get-connection-property p "remote-echo" nil) + (when (tramp-get-connection-property p "remote-echo") ;; We mark the command string that it can be erased in the output buffer. (tramp-set-connection-property p "check-remote-echo" t) ;; If we put `tramp-echo-mark' after a trailing newline (which @@ -5441,7 +5552,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)))))) @@ -5830,6 +5941,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." command)) (delete-file tmpfile))))) +(defun tramp-get-remote-dev-tty (vec) + "Check, whether remote /dev/tty is usable." + (with-tramp-connection-property vec "dev-tty" + (tramp-send-command-and-check + vec "echo </dev/tty"))) + ;; Some predefined connection properties. (defun tramp-get-inline-compress (vec prop size) "Return the compress command related to PROP. @@ -5841,7 +5958,7 @@ If no corresponding command is found, nil is returned." (> size tramp-inline-compress-start-size)) (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-compress vec) - (tramp-get-connection-property (tramp-get-process vec) prop nil)))) + (tramp-get-connection-property (tramp-get-process vec) prop)))) (defun tramp-get-inline-coding (vec prop size) "Return the coding command related to PROP. @@ -5861,7 +5978,7 @@ function cell is returned to be applied on a buffer." (let ((coding (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) - (tramp-get-connection-property (tramp-get-process vec) prop nil))) + (tramp-get-connection-property (tramp-get-process vec) prop))) (prop1 (if (tramp-compat-string-search "encoding" prop) "inline-compress" "inline-decompress")) compress) @@ -5977,9 +6094,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. ;; diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index c5f423fa3f0..b717c4dcc38 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -274,6 +274,7 @@ See `tramp-actions-before-shell' for more info.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -283,6 +284,7 @@ See `tramp-actions-before-shell' for more info.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . tramp-smb-handle-process-file) (rename-file . tramp-smb-handle-rename-file) (set-file-acl . tramp-smb-handle-set-file-acl) @@ -294,6 +296,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) @@ -383,14 +386,13 @@ arguments to pass to the OPERATION." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v2 v2-localname) - (unless - (tramp-smb-send-command - v1 - (format - "%s \"%s\" \"%s\"" - (if (tramp-smb-get-cifs-capabilities v1) "link" "hardlink") - (tramp-smb-get-localname v1) - (tramp-smb-get-localname v2))) + (unless (tramp-smb-send-command + v1 + (format + "%s %s %s" + (if (tramp-smb-get-cifs-capabilities v1) "link" "hardlink") + (tramp-smb-shell-quote-localname v1) + (tramp-smb-shell-quote-localname v2))) (tramp-error v2 'file-error "error with add-name-to-file, see buffer `%s' for details" @@ -517,50 +519,50 @@ arguments to pass to the OPERATION." "tar qx -"))))) (unwind-protect - (with-temp-buffer - ;; 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 t1 - ;; The smbclient tar command creates always - ;; complete paths. We must emulate the - ;; directory structure, and symlink to the - ;; real target. - (make-directory - (expand-file-name - ".." (concat tmpdir localname)) - 'parents) - (make-symbolic-link - newname - (directory-file-name (concat tmpdir localname)))) - - ;; Use an asynchronous processes. By this, - ;; password can be handled. - (let* ((default-directory tmpdir) - (p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-program 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) - (tramp-process-actions - p v nil tramp-smb-actions-with-tar) - - (while (process-live-p p) - (sleep-for 0.1)) - (tramp-message v 6 "\n%s" (buffer-string)))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + (with-temp-buffer + ;; 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 t1 + ;; The smbclient tar command creates + ;; always complete paths. We must emulate + ;; the directory structure, and symlink to + ;; the real target. + (make-directory + (expand-file-name + ".." (concat tmpdir localname)) + 'parents) + (make-symbolic-link + newname + (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By this, + ;; password can be handled. + (let* ((default-directory tmpdir) + (p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-program 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) + (tramp-process-actions + p v nil tramp-smb-actions-with-tar) + + (while (process-live-p p) + (sleep-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))))) + + ;; Save exit. (when t1 (delete-directory tmpdir 'recursive)))) ;; Handle KEEP-DATE argument. @@ -606,7 +608,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (tramp-tramp-file-p filename) filename newname)) 'file-missing filename)) - (if-let ((tmpfile (file-local-copy filename))) + ;; `file-local-copy' returns a file name also for a local file + ;; with `jka-compr-handler', so we cannot trust its result as + ;; indication for a remote file name. + (if-let ((tmpfile + (and (file-remote-p filename) (file-local-copy filename)))) ;; Remote filename. (condition-case err (rename-file tmpfile newname ok-if-already-exists) @@ -634,9 +640,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-error v 'file-error "Target `%s' must contain a share name" newname)) (unless (tramp-smb-send-command - v (format "put \"%s\" \"%s\"" - (tramp-compat-file-name-unquote filename) - (tramp-smb-get-localname v))) + v (format "put %s %s" + (tramp-smb-shell-quote-argument filename) + (tramp-smb-shell-quote-localname v))) (tramp-error v 'file-error "Cannot copy `%s' to `%s'" filename newname))))) @@ -665,10 +671,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-flush-directory-properties v localname) (unless (tramp-smb-send-command v (format - "%s \"%s\"" + "%s %s" (if (tramp-smb-get-cifs-capabilities v) "posix_rmdir" "rmdir") - (tramp-smb-get-localname v))) + (tramp-smb-shell-quote-localname v))) ;; Error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -691,9 +697,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (move-file-to-trash filename) (unless (tramp-smb-send-command v (format - "%s \"%s\"" + "%s %s" (if (tramp-smb-get-cifs-capabilities v) "posix_unlink" "rm") - (tramp-smb-get-localname v))) + (tramp-smb-shell-quote-localname v))) ;; Error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -742,28 +748,33 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) + (tramp-run-real-handler #'expand-file-name (list name)) ;; 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." @@ -813,33 +824,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (concat "2>" (tramp-get-remote-null-device v))))) (unwind-protect - (with-temp-buffer - ;; 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)) - - ;; Use an asynchronous process. By this, password can - ;; be handled. - (let ((p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program 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) - (tramp-process-actions p v nil tramp-smb-actions-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string))))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + (with-temp-buffer + ;; 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)) + + ;; Use an asynchronous process. By this, + ;; password can be handled. + (let ((p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program 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) + (tramp-process-actions p v nil tramp-smb-actions-get-acl) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string)))))))))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -886,7 +895,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." vec 5 "file attributes with stat: %s" (tramp-file-name-localname vec)) (let* (size id link uid gid atime mtime ctime mode inode) (when (tramp-smb-send-command - vec (format "stat \"%s\"" (tramp-smb-get-localname vec))) + vec (format "stat %s" (tramp-smb-shell-quote-localname vec))) ;; Loop the listing. (with-current-buffer (tramp-get-connection-buffer vec) @@ -960,7 +969,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (stringp id) (tramp-smb-send-command vec - (format "readlink \"%s\"" (tramp-smb-get-localname vec)))) + (format + "readlink %s" (tramp-smb-shell-quote-localname vec)))) (goto-char (point-min)) (and (looking-at ".+ -> \\(.+\\)") (setq id (match-string 1)))) @@ -979,8 +989,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) (unless (tramp-smb-send-command - v (format "get \"%s\" \"%s\"" - (tramp-smb-get-localname v) tmpfile)) + v (format "get %s %s" + (tramp-smb-shell-quote-localname v) + (tramp-smb-shell-quote-argument tmpfile))) ;; Oops, an error. We shall cleanup. (delete-file tmpfile) (tramp-error @@ -1013,7 +1024,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (tramp-smb-get-share v) (tramp-message v 5 "file system info: %s" localname) (tramp-smb-send-command - v (format "du %s/*" (tramp-smb-get-localname v))) + v (format "du %s/*" (tramp-smb-shell-quote-localname v))) (with-current-buffer (tramp-get-connection-buffer v) (let (total avail blocksize) (goto-char (point-min)) @@ -1123,7 +1134,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Insert size information. (when full-directory-p (insert - (if avail + (if (and avail + ;; Emacs 29.1 or later. + (not (fboundp 'dired--insert-disk-space))) (format "total used in directory %s available %s\n" used avail) (format "total %s\n" used)))) @@ -1201,18 +1214,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (file-name-absolute-p directory) (setq directory (expand-file-name directory default-directory))) (with-parsed-tramp-file-name directory nil - (let* ((file (tramp-smb-get-localname v))) - (when (file-directory-p (file-name-directory directory)) - (tramp-smb-send-command - v - (if (tramp-smb-get-cifs-capabilities v) - (format "posix_mkdir \"%s\" %o" file (default-file-modes)) - (format "mkdir \"%s\"" file))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname)) - (unless (file-directory-p directory) - (tramp-error v 'file-error "Couldn't make directory %s" directory))))) + (when (file-directory-p (file-name-directory directory)) + (tramp-smb-send-command + v (if (tramp-smb-get-cifs-capabilities v) + (format "posix_mkdir %s %o" + (tramp-smb-shell-quote-localname v) (default-file-modes)) + (format "mkdir %s" (tramp-smb-shell-quote-localname v)))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname)) + (unless (file-directory-p directory) + (tramp-error v 'file-error "Couldn't make directory %s" directory)))) (defun tramp-smb-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) @@ -1256,11 +1268,10 @@ component is used as the target of the symlink." ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v localname) - (unless - (tramp-smb-send-command - v (format "symlink \"%s\" \"%s\"" - (tramp-compat-file-name-unquote target) - (tramp-smb-get-localname v))) + (unless (tramp-smb-send-command + v (format "symlink %s %s" + (tramp-smb-shell-quote-argument target) + (tramp-smb-shell-quote-localname v))) (tramp-error v 'file-error "error with make-symbolic-link, see buffer `%s' for details" @@ -1281,10 +1292,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)) @@ -1329,31 +1340,34 @@ component is used as the target of the symlink." (setq i (1+ i) name1 (format "%s<%d>" name i))) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) - (tramp-set-connection-property - v "process-buffer" - (or outbuf (generate-new-buffer tramp-temp-buffer-name))) - ;; Call it. (condition-case nil - (with-current-buffer (tramp-get-connection-buffer v) - ;; Preserve buffer contents. - (narrow-to-region (point-max) (point-max)) - (tramp-smb-call-winexe v) - (when (tramp-smb-get-share v) - (tramp-smb-send-command - v (format "cd \"//%s%s\"" host (file-name-directory localname)))) - (tramp-smb-send-command v command) - ;; Preserve command output. - (narrow-to-region (point-max) (point-max)) - (let ((p (tramp-get-connection-process v))) - (tramp-smb-send-command v "exit $lasterrorcode") - (while (process-live-p p) - (sleep-for 0.1) - (setq ret (process-exit-status p)))) - (delete-region (point-min) (point-max)) - (widen)) + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property + v "process-buffer" + (or outbuf (generate-new-buffer tramp-temp-buffer-name))) + (with-current-buffer (tramp-get-connection-buffer v) + ;; Preserve buffer contents. + (narrow-to-region (point-max) (point-max)) + (tramp-smb-call-winexe v) + (when (tramp-smb-get-share v) + (tramp-smb-send-command + v (format "cd //%s%s" host + (tramp-smb-shell-quote-argument + (file-name-directory localname))))) + (tramp-smb-send-command v command) + ;; Preserve command output. + (narrow-to-region (point-max) (point-max)) + (let ((p (tramp-get-connection-process v))) + (tramp-smb-send-command v "exit $lasterrorcode") + (while (process-live-p p) + (sleep-for 0.1) + (setq ret (process-exit-status p)))) + (delete-region (point-min) (point-max)) + (widen)))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. @@ -1368,13 +1382,11 @@ component is used as the target of the symlink." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") (when tmpinput (delete-file tmpinput)) + ;; FIXME: Does connection-property "process-buffer" still exist? (unless outbuf - (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) - - (unless process-file-side-effects + (kill-buffer (tramp-get-connection-property v "process-buffer"))) + (when process-file-side-effects (tramp-flush-directory-properties v "")) ;; Return exit status. @@ -1419,9 +1431,9 @@ component is used as the target of the symlink." v2 'file-error "Target `%s' must contain a share name" newname)) (unless (tramp-smb-send-command - v2 (format "rename \"%s\" \"%s\"" - (tramp-smb-get-localname v1) - (tramp-smb-get-localname v2))) + v2 (format "rename %s %s" + (tramp-smb-shell-quote-localname v1) + (tramp-smb-shell-quote-localname v2))) (tramp-error v2 'file-error "Cannot rename `%s'" filename)))) ;; We must rename via copy. @@ -1474,42 +1486,44 @@ component is used as the target of the symlink." "||" "echo" "tramp_exit_status" "1"))) (unwind-protect - (with-temp-buffer - ;; 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)) - - ;; Use an asynchronous process. By this, password can - ;; be handled. - (let ((p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program 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) - (tramp-process-actions p v nil tramp-smb-actions-set-acl) - ;; This is meant for traces, and returning from the - ;; function. No error is propagated outside, due to - ;; the `ignore-errors' closure. - (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") - (tramp-error - v 'file-error - "Couldn't find exit status of `%s'" tramp-smb-acl-program)) - (skip-chars-forward "^ ") - (when (zerop (read (current-buffer))) - ;; Success. - (tramp-set-file-property v localname "file-acl" acl-string) - t))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer"))))))) + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + (with-temp-buffer + ;; 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)) + + ;; Use an asynchronous process. By this, password + ;; can be handled. + (let ((p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program 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) + (tramp-process-actions p v nil tramp-smb-actions-set-acl) + ;; This is meant for traces, and returning from + ;; the function. No error is propagated + ;; outside, due to the `ignore-errors' closure. + (unless + (tramp-search-regexp "tramp_exit_status [[:digit:]]+") + (tramp-error + v 'file-error + "Couldn't find exit status of `%s'" + tramp-smb-acl-program)) + (skip-chars-forward "^ ") + (when (zerop (read (current-buffer))) + ;; Success. + (tramp-set-file-property + v localname "file-acl" acl-string) + t))))))))))) (defun tramp-smb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -1519,7 +1533,8 @@ component is used as the target of the symlink." (when (tramp-smb-get-cifs-capabilities v) (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command - v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) + v + (format "chmod %s %o" (tramp-smb-shell-quote-localname v) mode)) (tramp-error v 'file-error "Error while changing file's mode %s" filename)))))) @@ -1537,41 +1552,50 @@ component is used as the target of the symlink." (command (string-join (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + p) (unwind-protect - (save-excursion - (save-restriction - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) - (tramp-set-connection-property v "process-buffer" buffer) - ;; Activate narrowing in order to save BUFFER contents. - (with-current-buffer (tramp-get-connection-buffer v) - (let ((buffer-undo-list t)) - (narrow-to-region (point-max) (point-max)) - (tramp-smb-call-winexe v) - (when (tramp-smb-get-share v) - (tramp-smb-send-command - v (format - "cd \"//%s%s\"" - host (file-name-directory localname)))) - (tramp-message v 6 "(%s); exit" command) - (tramp-send-string v command))) - ;; Return value. - (tramp-get-connection-process v))) + (with-tramp-saved-connection-property v "process-name" + (with-tramp-saved-connection-property v "process-buffer" + (save-excursion + (save-restriction + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property v "process-buffer" buffer) + ;; Activate narrowing in order to save BUFFER contents. + (with-current-buffer (tramp-get-connection-buffer v) + (let ((buffer-undo-list t)) + (narrow-to-region (point-max) (point-max)) + (tramp-smb-call-winexe v) + (when (tramp-smb-get-share v) + (tramp-smb-send-command + v (format + "cd //%s%s" + host + (tramp-smb-shell-quote-argument + (file-name-directory localname))))) + (tramp-message v 6 "(%s); exit" command) + (tramp-send-string v command))) + (setq p (tramp-get-connection-process v)) + (when program + (process-put p 'remote-command (cons program args)) + (tramp-set-connection-property + p "remote-command" (cons program args))) + ;; Return value. + p)))) ;; Save exit. + ;; FIXME: Does `tramp-get-connection-buffer' return the proper value? (with-current-buffer (tramp-get-connection-buffer v) (if (tramp-compat-string-search tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp))) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer"))))) + (set-buffer-modified-p bmp))))))) (defun tramp-smb-handle-substitute-in-file-name (filename) "Like `substitute-in-file-name' for Tramp files. @@ -1590,31 +1614,20 @@ 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." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let ((tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the visited file @@ -1627,36 +1640,11 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." v 3 (format "Moving tmp file %s to %s" tmpfile filename) (unwind-protect (unless (tramp-smb-send-command - v (format "put %s \"%s\"" - tmpfile (tramp-smb-get-localname v))) + v (format "put %s %s" + (tramp-smb-shell-quote-argument tmpfile) + (tramp-smb-shell-quote-localname v))) (tramp-error v 'file-error "Cannot write `%s'" filename)) - (delete-file tmpfile))) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - - (unless (equal curbuf (current-buffer)) - (tramp-error - v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - - ;; 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. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + (delete-file tmpfile)))))) ;; Internal file name functions. @@ -1690,9 +1678,8 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (when (string-match "\\(\\$\\$\\)\\(/\\|$\\)" localname) (setq localname (replace-match "$" nil nil localname 1))) - ;; A period followed by a space, or trailing periods and spaces, - ;; are not supported. - (when (string-match-p "\\. \\|\\.$\\| $" localname) + ;; A trailing space is not supported. + (when (string-match-p " $" localname) (tramp-error vec 'file-error "Invalid file name %s" (tramp-make-tramp-file-name vec localname))) @@ -1713,7 +1700,7 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." (setq localname (or localname "/")) (with-tramp-file-property v localname "file-entries" (let* ((share (tramp-smb-get-share v)) - (cache (tramp-get-connection-property v "share-cache" nil)) + (cache (tramp-get-connection-property v "share-cache")) res entry) (if (and (not share) cache) @@ -1723,7 +1710,7 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." ;; Read entries. (if share (tramp-smb-send-command - v (format "dir \"%s*\"" (tramp-smb-get-localname v))) + v (format "dir %s*" (tramp-smb-shell-quote-localname v))) ;; `tramp-smb-maybe-open-connection' lists also the share names. (tramp-smb-maybe-open-connection v)) @@ -1927,7 +1914,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (if (and (tramp-smb-get-share vec) (process-live-p (tramp-get-connection-process vec))) (with-tramp-connection-property (tramp-get-process vec) "stat-capability" - (tramp-smb-send-command vec "stat \"/\"")))) + (tramp-smb-send-command vec "stat /")))) ;; Connection functions. @@ -2042,7 +2029,7 @@ If ARGUMENT is non-nil, use it as argument for (if (not (zerop (length user))) (concat user "@") "") host (or share "")) - (let* ((coding-system-for-read nil) + (let* (coding-system-for-read (process-connection-type tramp-process-connection-type) (p (let ((default-directory tramp-compat-temporary-file-directory) @@ -2187,6 +2174,10 @@ Removes smb prompt. Returns nil if an error message has appeared." (let ((system-type 'ms-dos)) (tramp-unquote-shell-quote-argument s))) +(defun tramp-smb-shell-quote-localname (vec) + "Call `tramp-smb-shell-quote-argument' on localname of VEC." + (tramp-smb-shell-quote-argument (tramp-smb-get-localname vec))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-smb 'force))) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 0a5bf2f43b3..d7c918fbc83 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -51,11 +51,14 @@ (add-to-list 'tramp-methods `(,tramp-sshfs-method (tramp-mount-args (("-C") ("-p" "%p") + ("-o" "dir_cache=no") + ("-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")) @@ -107,9 +110,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) @@ -118,11 +121,12 @@ (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) (insert-file-contents . tramp-sshfs-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -132,17 +136,19 @@ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-sshfs-handle-process-file) (rename-file . tramp-sshfs-handle-rename-file) (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) @@ -219,6 +225,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 +249,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 +319,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,44 +361,22 @@ 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." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - - (let (create-lockfiles) - (write-region - start end (tramp-fuse-local-file-name filename) append 'nomessage) - (tramp-flush-file-properties v localname)) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let (create-lockfiles) + (write-region + start end (tramp-fuse-local-file-name filename) append 'nomessage)))) ;; File name conversions. @@ -383,6 +437,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 a68d4b3e365..420a593644f 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")) @@ -100,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) @@ -116,6 +117,7 @@ See `tramp-actions-before-shell' for more info.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -125,6 +127,7 @@ See `tramp-actions-before-shell' for more info.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-sudoedit-handle-rename-file) (set-file-acl . tramp-sudoedit-handle-set-file-acl) @@ -136,6 +139,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) @@ -143,7 +147,7 @@ See `tramp-actions-before-shell' for more info.") (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) - (write-region . tramp-sudoedit-handle-write-region)) + (write-region . tramp-handle-write-region)) "Alist of handler functions for Tramp SUDOEDIT method.") ;; It must be a `defsubst' in order to push the whole code into @@ -168,6 +172,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. @@ -362,17 +372,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." @@ -572,8 +588,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." @@ -693,6 +708,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'." @@ -717,38 +739,6 @@ ID-FORMAT valid values are `string' and `integer'." (or gid (tramp-get-remote-gid v 'integer))) (tramp-unquote-file-local-name filename)))) -(defun tramp-sudoedit-handle-write-region - (start end filename &optional append visit lockname mustbenew) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - (let* ((uid (or (file-attribute-user-id (file-attributes filename 'integer)) - (tramp-get-remote-uid v '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)) - (attributes (file-extended-attributes filename))) - (prog1 - (tramp-handle-write-region - start end filename append visit lockname mustbenew) - - ;; Set the ownership, modes and extended attributes. This is - ;; not performed in `tramp-handle-write-region'. - (unless (and (= (file-attribute-user-id - (file-attributes filename 'integer)) - uid) - (= (file-attribute-group-id - (file-attributes filename 'integer)) - gid)) - (tramp-set-file-uid-gid filename uid gid)) - (tramp-compat-set-file-modes filename modes flag) - ;; We ignore possible errors, because ACL strings could be - ;; incompatible. - (when attributes - (ignore-errors - (set-file-extended-attributes filename attributes))))))) - ;; Internal functions. @@ -826,6 +816,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 adde443fdd6..37259107147 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.") @@ -238,7 +238,7 @@ pair of the form (KEY VALUE). The following KEYs are defined: unchanged after expansion (i.e. no host, no user or no port were specified), that sublist is not used. For e.g. - '((\"-a\" \"-b\") (\"-l\" \"%u\")) + \\='((\"-a\" \"-b\") (\"-l\" \"%u\")) that means that (\"-l\" \"%u\") is used only if the user was specified, and it is thus effectively optional. @@ -255,6 +255,10 @@ 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-force-scp-protocol' + argument if it is supported. + - \"%z\" 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 +317,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 @@ -495,7 +505,8 @@ interpreted as a regular expression which always matches." ;; either lower case or upper case letters. See ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38079#20>. (defcustom tramp-restricted-shell-hosts-alist - (when (eq system-type 'windows-nt) + (when (and (eq system-type 'windows-nt) + (not (string-match-p "sh$" tramp-encoding-shell))) (list (format "\\`\\(%s\\|%s\\)\\'" (regexp-quote (downcase tramp-system-name)) (regexp-quote (upcase tramp-system-name))))) @@ -511,11 +522,12 @@ host runs a restricted shell, it shall be added to this list, too." (concat "\\`" (regexp-opt - (list "localhost" "localhost6" tramp-system-name "127.0.0.1" "::1") t) + `("localhost" "localhost4" "localhost6" ,tramp-system-name "127.0.0.1" "::1") + t) "\\'") "Host names which are regarded as local host. If the local host runs a chrooted environment, set this to nil." - :version "27.1" + :version "29.1" :type '(choice (const :tag "Chrooted environment" nil) (regexp :tag "Host regexp"))) @@ -1372,7 +1384,8 @@ would require an immediate reread during filename completion, nil means to use always cached values for the directory contents." :type '(choice (const nil) (const t) integer)) (make-obsolete-variable - 'tramp-completion-reread-directory-timeout 'remote-file-name-inhibit-cache "27.2") + 'tramp-completion-reread-directory-timeout + 'remote-file-name-inhibit-cache "27.2") ;;; Internal Variables: @@ -1387,6 +1400,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) @@ -1408,7 +1426,10 @@ calling HANDLER.") ;; internal data structure. Convenience functions for internal ;; data structure. -;; The basic structure for remote file names. +;; The basic structure for remote file names. We must autoload it in +;; tramp-loaddefs.el, because some functions, which need it, wouldn't +;; work otherwise when unloading / reloading Tramp. (Bug#50869) +;;;###tramp-autoload (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1420,6 +1441,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)) @@ -1476,7 +1502,7 @@ entry does not exist, return nil." (replace-regexp-in-string "^tramp-" "" (symbol-name param)))) (if (tramp-connection-property-p vec hash-entry) ;; We use the cached property. - (tramp-get-connection-property vec hash-entry nil) + (tramp-get-connection-property vec hash-entry) ;; Use the static value from `tramp-methods'. (when-let ((methods-entry (assoc @@ -1713,13 +1739,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)." @@ -1735,8 +1758,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) @@ -1769,15 +1797,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. @@ -1808,10 +1838,10 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." ;; as indication, whether a connection is active. (tramp-set-connection-property vec "process-buffer" - (tramp-get-connection-property vec "process-buffer" nil)) + (tramp-get-connection-property vec "process-buffer")) (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) @@ -1819,14 +1849,14 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." Unless DONT-CREATE, the buffer is created when it doesn't exist yet. In case a second asynchronous communication has been started, it is different from `tramp-get-buffer'." - (or (tramp-get-connection-property vec "process-buffer" nil) + (or (tramp-get-connection-property vec "process-buffer") (tramp-get-buffer vec dont-create))) (defun tramp-get-connection-name (vec) "Get the connection name to be used for VEC. In case a second asynchronous communication has been started, it is different from the default one." - (or (tramp-get-connection-property vec "process-name" nil) + (or (tramp-get-connection-property vec "process-name") (tramp-buffer-name vec))) (defun tramp-get-process (vec-or-proc) @@ -1926,7 +1956,8 @@ The outline level is equal to the verbosity of the Tramp message." "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 10) ";; Emacs:"))) + (string-equal + (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) ";; Emacs:"))) (put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) @@ -2120,15 +2151,17 @@ applicable)." (put #'tramp-message 'tramp-suppress-trace t) -(defsubst tramp-backtrace (&optional vec-or-proc) +(defsubst tramp-backtrace (&optional vec-or-proc force) "Dump a backtrace into the debug buffer. -If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This -function is meant for debugging purposes." - (when (>= tramp-verbose 10) - (if vec-or-proc - (tramp-message - vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) - (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) +If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE +forces the backtrace even if `tramp-verbose' is less than 10. +This function is meant for debugging purposes." + (let ((tramp-verbose (if force 10 tramp-verbose))) + (when (>= tramp-verbose 10) + (if vec-or-proc + (tramp-message + vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) + (with-output-to-temp-buffer "*debug tramp*" (backtrace)))))) (put #'tramp-backtrace 'tramp-suppress-trace t) @@ -2158,6 +2191,11 @@ FMT-STRING and ARGUMENTS." (put #'tramp-error 'tramp-suppress-trace t) +(defvar tramp-error-show-message-timeout 30 + "Time to show the Tramp buffer in case of an error. +If it is bound to nil, the buffer is not shown. This is used in +tramp-tests.el.") + (defsubst tramp-error-with-buffer (buf vec-or-proc signal fmt-string &rest arguments) "Emit an error, and show BUF. @@ -2175,6 +2213,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. (when (and buf + (natnump tramp-error-show-message-timeout) (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. (not non-essential) @@ -2188,7 +2227,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." ;; Show buffer. (pop-to-buffer buf) (discard-input) - (sit-for 30))) + (sit-for tramp-error-show-message-timeout))) ;; Reset timestamp. It would be wrong after waiting for a while. (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) @@ -2201,7 +2240,8 @@ an input event arrives. The other arguments are passed to `tramp-error'." (unwind-protect (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) ;; Save exit. - (when (and (not (zerop tramp-verbose)) + (when (and (natnump tramp-error-show-message-timeout) + (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. (not non-essential) ;; Show only when Emacs has started already. @@ -2211,7 +2251,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." ;; `tramp-error' does not show messages. So we must do it ourselves. (apply #'message fmt-string arguments) (discard-input) - (sit-for 30) + (sit-for tramp-error-show-message-timeout) ;; Reset timestamp. It would be wrong after waiting for a while. (when (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) @@ -2291,8 +2331,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)) @@ -2315,7 +2353,7 @@ without a visible progress reporter." ;; running, and when there is a minimum level. (when-let ((pr (and (null tramp-inhibit-progress-reporter) (<= ,level (min tramp-verbose 3)) - (make-progress-reporter ,message nil nil)))) + (make-progress-reporter ,message)))) (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) (unwind-protect ;; Execute the body. @@ -2329,9 +2367,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." @@ -2348,8 +2383,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)) @@ -2363,8 +2396,15 @@ 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\\>")) +(defmacro with-tramp-saved-connection-property (key property &rest body) + "Save PROPERTY, run BODY, reset PROPERTY." + (declare (indent 2) (debug t)) + `(let ((value (tramp-get-connection-property + ,key ,property tramp-cache-undefined))) + (unwind-protect (progn ,@body) + (if (eq value tramp-cache-undefined) + (tramp-flush-connection-property ,key ,property) + (tramp-set-connection-property ,key ,property value))))) (defun tramp-drop-volume-letter (name) "Cut off unnecessary drive letter from file NAME. @@ -2459,7 +2499,7 @@ For definition of that list see `tramp-set-completion-function'." (defun tramp-default-file-modes (filename &optional flag) "Return file modes of FILENAME as integer. -If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a +If optional FLAG is `nofollow', do not follow FILENAME if it is a symbolic link. If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." @@ -2501,6 +2541,7 @@ arguments to pass to the OPERATION." ,(and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation) + (args (if (tramp-file-name-p (car args)) (cons nil (cdr args)) args)) signal-hook-function) (apply operation args))) @@ -2584,23 +2625,26 @@ Must be handled by the callers." '(make-nearby-temp-file process-file shell-command start-file-process temporary-file-directory ;; Emacs 27+ only. - exec-path make-process)) + exec-path make-process + ;; Emacs 29+ only. + list-system-processes process-attributes)) default-directory) ;; PROC. ((member operation '(file-notify-rm-watch file-notify-valid-p)) (when (processp (nth 0 args)) (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) - (vec (tramp-dissect-file-name filename)) elt func res) (while handler (setq elt (car handler) @@ -2633,7 +2677,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'. @@ -2680,6 +2724,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (tramp-message v 5 "Non-essential received in operation %s" (cons operation args)) + (let ((tramp-verbose 10)) (tramp-backtrace v)) (tramp-run-real-handler operation args)) ((eq result 'suppress) (let ((inhibit-message t)) @@ -2732,17 +2777,21 @@ 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. ;;;###autoload (progn (defun tramp-register-autoload-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist' during autoload." - (add-to-list 'file-name-handler-alist - (cons tramp-autoload-file-name-regexp - #'tramp-autoload-file-name-handler)) - (put #'tramp-autoload-file-name-handler 'safe-magic t))) + (unless (rassq #'tramp-file-name-handler file-name-handler-alist) + (add-to-list 'file-name-handler-alist + (cons tramp-autoload-file-name-regexp + #'tramp-autoload-file-name-handler)) + (put #'tramp-autoload-file-name-handler 'safe-magic t)))) +(put #'tramp-register-autoload-file-name-handlers 'tramp-autoload t) ;;;###autoload (tramp-register-autoload-file-name-handlers) (defun tramp-use-absolute-autoload-file-names () @@ -2856,6 +2905,7 @@ whether HANDLER is to be called. Add operations defined in (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: @@ -2919,7 +2969,7 @@ not in completion mode." (m (tramp-find-method method user host)) all-user-hosts) - (unless localname ;; Nothing to complete. + (unless localname ;; Nothing to complete. (if (or user host) @@ -3323,6 +3373,129 @@ User is always nil." (forward-line 1) result)) +;;; Skeleton macros for file name handler functions. + +(defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body) + "Skeleton for `tramp-*-handle-delete-directory'. +BODY is the backend specific code." + (declare (indent 3) (debug t)) + `(with-parsed-tramp-file-name (expand-file-name ,directory) nil + (if (and delete-by-moving-to-trash ,trash) + ;; Move non-empty dir to trash only if recursive deletion was + ;; requested. + (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory))) + (tramp-error + v 'file-error "Directory is not empty, not moving to trash") + (move-file-to-trash ,directory)) + ,@body) + (tramp-flush-directory-properties v localname))) + +(put #'tramp-skeleton-delete-directory 'tramp-suppress-trace t) + +(defmacro tramp-skeleton-write-region + (start end filename append visit lockname mustbenew &rest body) + "Skeleton for `tramp-*-handle-write-region'. +BODY is the backend specific code." + (declare (indent 7) (debug t)) + ;; Sometimes, there is another file name handler responsible for + ;; VISIT, for example `jka-compr-handler'. We must respect this. + ;; See Bug#55166. + `(let* ((filename (expand-file-name ,filename)) + (lockname (file-truename (or ,lockname filename))) + (handler (and (stringp ,visit) + (let ((inhibit-file-name-handlers + `(tramp-file-name-handler + tramp-crypt-file-name-handler + . inhibit-file-name-handlers)) + (inhibit-file-name-operation 'write-region)) + (find-file-name-handler ,visit 'write-region))))) + (with-parsed-tramp-file-name filename nil + (if handler + (progn + (tramp-message + v 5 "Calling handler `%s' for visiting `%s'" handler ,visit) + (funcall + handler 'write-region + ,start ,end filename ,append ,visit lockname ,mustbenew)) + + (when (and ,mustbenew (file-exists-p filename) + (or (eq ,mustbenew 'excl) + (not + (y-or-n-p + (format + "File %s exists; overwrite anyway?" filename))))) + (tramp-error v 'file-already-exists filename)) + + (let ((file-locked (eq (file-locked-p lockname) t)) + (uid (or (file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer))) + (attributes (file-extended-attributes filename)) + (curbuf (current-buffer))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p + (file-name-nondirectory filename))) + (file-remote-p lockname) + (not file-locked)) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + + ;; The body. + ,@body + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + + ;; We must protect `last-coding-system-used', now we have + ;; set it to its correct value. + (let (last-coding-system-used (need-chown t)) + ;; Set file modification time. + (when (or (eq ,visit t) (stringp ,visit)) + (when-let ((file-attr (file-attributes filename 'integer))) + (set-visited-file-modtime + ;; We must pass modtime explicitly, because FILENAME + ;; can be different from (buffer-file-name), f.e. if + ;; `file-precious-flag' is set. + (or (file-attribute-modification-time file-attr) + (current-time))) + (when (and (= (file-attribute-user-id file-attr) uid) + (= (file-attribute-group-id file-attr) gid)) + (setq need-chown nil)))) + + ;; Set the ownership. + (when need-chown + (tramp-set-file-uid-gid filename uid gid))) + + ;; Set extended attributes. We ignore possible errors, + ;; because ACL strings could be incompatible. + (when attributes + (ignore-errors + (set-file-extended-attributes filename attributes))) + + ;; Unlock file. + (when file-locked + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; Sanity check. + (unless (equal curbuf (current-buffer)) + (tramp-error + v 'file-error + "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) + + (when (and (null noninteractive) + (or (eq ,visit t) (string-or-null-p ,visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))))) + +(put #'tramp-skeleton-write-region 'tramp-suppress-trace t) + ;;; Common file name handler functions for different backends: (defvar tramp-handle-file-local-copy-hook nil @@ -3331,6 +3504,10 @@ 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'. @@ -3338,20 +3515,30 @@ User is always nil." "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 - (with-tramp-connection-property vec "home-directory" - (tramp-compat-funcall + (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 "~")))) + (when home-dir + (setq home-dir + (tramp-compat-funcall 'directory-abbrev-apply - (expand-file-name (tramp-make-tramp-file-name vec "~")))))) + (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 (string-match - (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename) + (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)))) - filename))) + (tramp-make-tramp-file-name (tramp-dissect-file-name filename))))) (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." @@ -3465,23 +3652,37 @@ User is always nil." (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) + (tramp-run-real-handler #'expand-file-name (list name)) ;; Dissect NAME. (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 "/")) - ;; Do normal `expand-file-name' (this does "/./" and "/../"), - ;; unless there are tilde characters in file name. + ;; Do normal `expand-file-name' (this does "/./" and "/../"). ;; `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 (if (string-match-p "\\`~" localname) - localname - (tramp-drop-volume-letter + v (tramp-drop-volume-letter + (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname (tramp-run-real-handler #'expand-file-name (list localname))))))))) (defun tramp-handle-file-accessible-directory-p (filename) @@ -3678,10 +3879,10 @@ User is always nil." ;; 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)))) + (tramp-get-connection-property p "connected")))) ;; We expand the file name only, if there is already a connection. (with-parsed-tramp-file-name (if c (expand-file-name filename) filename) nil @@ -3693,7 +3894,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) @@ -3744,8 +3946,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 @@ -3904,8 +4105,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) @@ -3948,11 +4148,162 @@ 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))))) +(defun tramp-ps-time () + "Read printed time oif \"ps\" in format \"[[DD-]hh:]mm:ss\". +Return it as number of seconds. Used in `tramp-process-attributes-ps-format'." + (search-forward-regexp "\\s-+") + (search-forward-regexp + (concat + "\\(?:" "\\(?:" "\\([0-9]+\\)-" "\\)?" + "\\([0-9]+\\):" "\\)?" + "\\([0-9]+\\):" + ;; Seconds can also be a floating point number. + "\\([0-9.]+\\)") + (line-end-position) 'noerror) + (+ (* 24 60 60 (string-to-number (or (match-string 1) "0"))) + (* 60 60 (string-to-number (or (match-string 2) "0"))) + (* 60 (string-to-number (or (match-string 3) "0"))) + (string-to-number (or (match-string 4) "0")))) + +(defconst tramp-process-attributes-ps-args + `("-eww" + "-o" + ,(mapconcat + #'identity + '("pid" + "euid" + "euser" + "egid" + "egroup" + "comm:80" + "state" + "ppid" + "pgrp" + "sess" + "tname" + "tpgid" + "min_flt" + "maj_flt" + "times" + "pri" + "nice" + "thcount" + "vsize" + "rss" + "etimes" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for calling \"ps\". +See `tramp-get-process-attributes'. + +This list is the default value on remote GNU/Linux systems.") + +(defconst tramp-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (group . string) + (comm . 80) + (state . string) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . number) + (pri . number) + (nice . number) + (thcount . number) + (vsize . number) + (rss . number) + (etime . number) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist where each element is a cons cell of the form `\(KEY . TYPE)'. +KEY is a key (symbol) used in `process-attributes'. TYPE is the +printed result for KEY of the \"ps\" command, it can be `number', +`string', a number (string of that length), a symbol (a function +to be applied), or nil (for the last column of the \"ps\" output. + +This alist is used to parse the output of calling \"ps\" in +`tramp-get-process-attributes'. + +This alist is the default value on remote GNU/Linux systems.") + +(defun tramp-get-process-attributes (vec) + "Return all process attributes for connection VEC. +Parsing the remote \"ps\" output is controlled by +`tramp-process-attributes-ps-args' and +`tramp-process-attributes-ps-format'. + +It is not guaranteed, that all process attributes as described in +`process-attributes' are returned. The additional attribute +`pid' shall be returned always." + ;; Since Emacs 27.1. + (when (fboundp 'connection-local-criteria-for-default-directory) + (with-tramp-file-property vec "/" "process-attributes" + (ignore-errors + (with-temp-buffer + (hack-connection-local-variables-apply + (connection-local-criteria-for-default-directory)) + ;; (pop-to-buffer (current-buffer)) + (when (zerop + (apply + #'process-file + "ps" nil t nil tramp-process-attributes-ps-args)) + (let (result res) + (goto-char (point-min)) + (while (not (eobp)) + ;; (tramp-test-message + ;; "%s" (buffer-substring (point) (line-end-position))) + (when (save-excursion + (search-forward-regexp + "[[:digit:]]" (line-end-position) 'noerror)) + (setq res nil) + (dolist (elt tramp-process-attributes-ps-format) + (push + (cons + (car elt) + (cond + ((eq (cdr elt) 'number) (read (current-buffer))) + ((eq (cdr elt) 'string) + (search-forward-regexp "\\S-+") + (match-string 0)) + ((numberp (cdr elt)) + (search-forward-regexp "\\s-+") + (search-forward-regexp ".+" (+ (point) (cdr elt))) + (string-trim (match-string 0))) + ((fboundp (cdr elt)) + (funcall (cdr elt))) + ((null (cdr elt)) + (search-forward-regexp "\\s-+") + (buffer-substring (point) (line-end-position))) + (t nil))) + res)) + ;; `nice' could be `-'. + (setq res (rassq-delete-all '- res)) + (push (append res) result)) + (forward-line)) + ;; Return result. + result))))))) + +(defun tramp-handle-list-system-processes () + "Like `list-system-processes' for Tramp files." + (let ((v (tramp-dissect-file-name default-directory))) + (tramp-flush-file-property v "/" "process-attributes") + (mapcar (lambda (x) (cdr (assq 'pid x))) (tramp-get-process-attributes v)))) + (defun tramp-get-lock-file (file) "Read lockfile info of FILE. Return nil when there is no lockfile." @@ -3988,7 +4339,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (match (string-match tramp-lock-file-info-regexp info))) (or ; Locked by me. (and (string-equal (match-string 1 info) (user-login-name)) - (string-equal (match-string 2 info) (system-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)))) @@ -3999,6 +4350,14 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") ;; 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 @@ -4011,7 +4370,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") ;; 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. @@ -4037,7 +4396,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (make-symbolic-link info lockname 'ok-if-already-exists) (error (with-file-modes #o0644 - (write-region info nil lockname))))))))) + (write-region info nil lockname nil 'no-message))))))))) (defun tramp-handle-make-lock-file-name (file) "Like `make-lock-file-name' for Tramp files." @@ -4088,15 +4447,10 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (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)) @@ -4113,9 +4467,19 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (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) @@ -4204,7 +4568,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (and ;; The method supports it. (tramp-get-method-parameter v 'tramp-direct-async) ;; It has been indicated. - (tramp-get-connection-property v "direct-async-process" nil) + (tramp-get-connection-property v "direct-async-process") ;; There's no multi-hop. (or (not (tramp-multi-hop-p v)) (= (length (tramp-compute-multi-hops v)) 1)) @@ -4255,6 +4619,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) + (orig-command command) (env (mapcar (lambda (elt) (when (tramp-compat-string-search "=" elt) elt)) @@ -4276,7 +4641,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 @@ -4328,6 +4695,8 @@ substitution. SPEC-LIST is a list of char/value pairs used for ;; t. See Bug#51177. (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property p "remote-command" orig-command) (tramp-message v 6 "%s" (string-join (process-command p) " ")) p)))))) @@ -4341,6 +4710,14 @@ support symbolic links." (tramp-dissect-file-name (expand-file-name linkname)) 'file-error "make-symbolic-link not supported")) +(defun tramp-handle-process-attributes (pid) + "Like `process-attributes' for Tramp files." + (catch 'result + (dolist (elt (tramp-get-process-attributes + (tramp-dissect-file-name default-directory))) + (when (= (cdr (assq 'pid elt)) pid) + (throw 'result elt))))) + (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) @@ -4472,7 +4849,7 @@ support symbolic links." (prog1 ;; Run the process. - (process-file-shell-command command nil buffer nil) + (process-file-shell-command command nil buffer) ;; Insert error messages if they were separated. (when error-file (with-current-buffer error-buffer @@ -4537,10 +4914,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) @@ -4598,33 +4972,10 @@ of." (defun tramp-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (tmpfile (tramp-compat-make-temp-file filename)) + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let ((tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes - filename (and (eq mustbenew 'excl) 'nofollow))) - (uid (or (file-attribute-user-id (file-attributes filename 'integer)) - (tramp-get-remote-uid v 'integer))) - (gid (or (file-attribute-group-id (file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer)))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - + filename (and (eq mustbenew 'excl) 'nofollow)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -4643,29 +4994,7 @@ of." (error (delete-file tmpfile) (tramp-error - v 'file-error "Couldn't write region to `%s'" filename))) - - (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)))) - - ;; Set the ownership. - (tramp-set-file-uid-gid filename uid gid) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + v 'file-error "Couldn't write region to `%s'" filename)))))) ;; This is used in tramp-sh.el and tramp-sudoedit.el. (defconst tramp-stat-marker "/////" @@ -4744,7 +5073,8 @@ 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")) (tramp-clear-passwd vec)) (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) @@ -4752,7 +5082,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) @@ -4941,8 +5277,9 @@ performed successfully. Any other value means an error." (tramp-message vec 6 "\n%s" (buffer-string))) (if (eq exit 'ok) (ignore-errors - (and (functionp tramp-password-save-function) - (funcall tramp-password-save-function))) + (when (functionp tramp-password-save-function) + (funcall tramp-password-save-function) + (setq tramp-password-save-function nil))) ;; Not successful. (tramp-clear-passwd vec) (delete-process proc) @@ -4981,7 +5318,7 @@ performed successfully. Any other value means an error." "Lock PROC for other communication, and run BODY. Mostly useful to protect BODY from being interrupted by timers." (declare (indent 1) (debug t)) - `(if (tramp-get-connection-property ,proc "locked" nil) + `(if (tramp-get-connection-property ,proc "locked") ;; Be kind for older Emacsen. (if (member 'remote-file-error debug-ignored-errors) (throw 'non-essential 'non-essential) @@ -4993,9 +5330,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 @@ -5037,7 +5371,7 @@ Erase echoed commands if exists." ;; Check whether we need to remove echo output. The max length of ;; the echo mark regexp is taken for search. We restrict the ;; search for the second echo mark to PIPE_BUF characters. - (when (and (tramp-get-connection-property proc "check-remote-echo" nil) + (when (and (tramp-get-connection-property proc "check-remote-echo") (re-search-forward tramp-echoed-echo-mark-regexp (+ (point) (* 5 tramp-echo-mark-marker-length)) t)) @@ -5053,7 +5387,7 @@ Erase echoed commands if exists." (delete-region begin (point)) (goto-char (point-min))))) - (when (or (not (tramp-get-connection-property proc "check-remote-echo" nil)) + (when (or (not (tramp-get-connection-property proc "check-remote-echo")) ;; Sometimes, the echo string is suppressed on the remote side. (not (string-equal (substring-no-properties @@ -5115,7 +5449,7 @@ The STRING is expected to use Unix line-endings, but the lines sent to the remote host use line-endings as defined in the variable `tramp-rsh-end-of-line'. The communication buffer is erased before sending." (let* ((p (tramp-get-connection-process vec)) - (chunksize (tramp-get-connection-property p "chunksize" nil))) + (chunksize (tramp-get-connection-property p "chunksize"))) (unless p (tramp-error vec 'file-error "Can't send string to remote host -- not logged in")) @@ -5153,7 +5487,7 @@ the remote host use line-endings as defined in the variable (unless (process-live-p proc) (let ((vec (process-get proc 'vector)) (buf (process-buffer proc)) - (prompt (tramp-get-connection-property proc "prompt" nil))) + (prompt (tramp-get-connection-property proc "prompt"))) (when vec (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) (tramp-flush-connection-properties proc) @@ -5319,8 +5653,10 @@ If FILENAME is remote, a file name handler is called." (when (and modes (not (zerop (logand modes #o2000)))) (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) + (funcall (if (tramp-crypt-file-name-p filename) + #'tramp-crypt-file-name-handler #'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))) @@ -5375,11 +5711,12 @@ VEC is used for tracing." "Check `file-attributes' caches for VEC. Return t if according to the cache access type ACCESS is known to be granted." - (let ((result nil) + (let (result (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 @@ -5409,40 +5746,45 @@ be granted." ;; User accessible and owned by user. (and (eq access (aref (file-attribute-modes file-attr) offset)) - (or (equal remote-uid (file-attribute-user-id file-attr)) + (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 (file-attribute-modes file-attr) (+ offset 3))) - (or (equal remote-gid (file-attribute-group-id file-attr)) + (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." + (and (tramp-file-name-p vec) + (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)) - ;; Ensure there is a valid result. - (and (equal id-format 'integer) tramp-unknown-id-integer) - (and (equal id-format 'string) tramp-unknown-id-string)))) + (or (and (tramp-file-name-p vec) + (with-tramp-connection-property vec (format "uid-%s" id-format) + (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))) (defun tramp-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (or (when-let - ((handler - (find-file-name-handler - (tramp-make-tramp-file-name vec) 'tramp-get-remote-gid))) - (funcall handler #'tramp-get-remote-gid vec id-format)) - ;; Ensure there is a valid result. - (and (equal id-format 'integer) tramp-unknown-id-integer) - (and (equal id-format 'string) tramp-unknown-id-string)))) + (or (and (tramp-file-name-p vec) + (with-tramp-connection-property vec (format "gid-%s" id-format) + (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))) (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise. @@ -5462,8 +5804,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)))))) @@ -5685,39 +6026,44 @@ verbosity of 6." "Return t if system process PROCESS-NAME is running for `user-login-name'." (when (stringp process-name) (catch 'result - (dolist (pid (list-system-processes)) - (when-let ((attributes (process-attributes pid)) - (comm (cdr (assoc 'comm attributes)))) - (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) - ;; The returned command name could be truncated to 15 - ;; characters. Therefore, we cannot check for `string-equal'. - (string-prefix-p comm process-name) - (throw 'result t))))))) + (let ((default-directory temporary-file-directory)) + (dolist (pid (list-system-processes)) + (when-let ((attributes (process-attributes pid)) + (comm (cdr (assoc 'comm attributes)))) + (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) + ;; The returned command name could be truncated to 15 + ;; characters. Therefore, we cannot check for `string-equal'. + (string-prefix-p comm process-name) + (throw 'result t)))))))) ;; When calling "emacs -Q", `auth-source-search' won't be called. If ;; you want to debug exactly this case, call "emacs -Q --eval '(setq ;; 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"))) + (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 (buffer-local-value 'auth-sources (process-buffer proc))) @@ -5726,59 +6072,60 @@ Invokes `password-read' if available, `read-passwd' else." 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. - (progn - (setq auth-passwd (password-read pw-prompt key) - tramp-password-save-function - (lambda () (password-cache-add key auth-passwd))) - auth-passwd)) + ;; 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") + ;; 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)) @@ -5791,7 +6138,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) @@ -5884,32 +6231,54 @@ name of a process or buffer, or nil to default to the current buffer." (lambda () (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) +(defun tramp-signal-process (process sigcode &optional remote) + "Send PROCESS the signal with code SIGCODE. +PROCESS may also be a number specifying the process id of the +process to signal; in this case, the process need not be a child of +this Emacs. +If PROCESS is a process object which contains the property +`remote-pid', or PROCESS is a number and REMOTE is a remote file name, +PROCESS is interpreted as process on the respective remote host, which +will be the process to signal. +SIGCODE may be an integer, or a symbol whose name is a signal name." + (let (pid vec) + (cond + ((processp process) + (setq pid (process-get process 'remote-pid) + vec (process-get process 'vector))) + ((numberp process) + (setq pid process + vec (and (stringp remote) (tramp-dissect-file-name remote)))) + (t (signal 'wrong-type-argument (list #'processp process)))) + (unless (or (numberp sigcode) (symbolp sigcode)) + (signal 'wrong-type-argument (list #'numberp sigcode))) + ;; If it's a Tramp process, send SIGCODE remotely. + (when (and pid vec) + (tramp-message + vec 5 "Send signal %s to process %s with pid %s" sigcode process pid) + ;; This is for tramp-sh.el. Other backends do not support this (yet). + (if (tramp-compat-funcall + 'tramp-send-command-and-check + vec (format "\\kill -%s %d" sigcode pid)) + 0 -1)))) + +;; `signal-process-functions' exists since Emacs 29.1. +(when (boundp 'signal-process-functions) + (add-hook 'signal-process-functions #'tramp-signal-process) + (add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'signal-process-functions #'tramp-signal-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))) (tramp-compat-null-device))))) -(defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body) - "Skeleton for `tramp-*-handle-delete-directory'. -BODY is the backend specific code." - (declare (indent 3) (debug t)) - `(with-parsed-tramp-file-name (expand-file-name ,directory) nil - (if (and delete-by-moving-to-trash ,trash) - ;; Move non-empty dir to trash only if recursive deletion was - ;; requested. - (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory))) - (tramp-error - v 'file-error "Directory is not empty, not moving to trash") - (move-file-to-trash ,directory)) - ,@body) - (tramp-flush-directory-properties v localname))) - -(put #'tramp-skeleton-delete-directory 'tramp-suppress-trace t) - ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' @@ -5924,6 +6293,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) diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index e3bcd568d72..68fd110ec00 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -52,12 +52,13 @@ ;; Suppress message from `emacs-repository-get-branch'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) - (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") - source-directory))) + source-directory)) + debug-on-error) ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. (with-no-warnings (and (stringp dir) (file-directory-p dir) + (executable-find "git") (emacs-repository-get-branch dir))))) "The repository branch of the Tramp sources.") @@ -66,10 +67,11 @@ ;; Suppress message from `emacs-repository-get-version'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) - (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") - source-directory))) + source-directory)) + debug-on-error) (and (stringp dir) (file-directory-p dir) + (executable-find "git") (emacs-repository-get-version dir)))) "The repository revision of the Tramp sources.") |