diff options
Diffstat (limited to 'lisp/net')
36 files changed, 1093 insertions, 1433 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 4d97dbcc96a..a6904fc07e9 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1230,8 +1230,9 @@ only return the directory part of FILE." ;; found another machine with the same user. ;; Try that account. (read-passwd - (format "passwd for %s@%s (default same as %s@%s): " - user host user other) + (format-prompt "passwd for %s@%s" + (format "same as %s@%s" user other) + user host) nil (ange-ftp-lookup-passwd other user)) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 5f7140fac4f..e4c485eccde 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,6 +39,7 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany GNOME Web (Epiphany) Don't know +;; browse-url-webpositive WebPositive 1.2-alpha (Haiku R1/beta3) ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -156,6 +157,7 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "GNOME Web (Epiphany)" :value browse-url-epiphany) + (function-item :tag "WebPositive" :value browse-url-webpositive) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -219,7 +221,7 @@ be used instead." (defcustom browse-url-button-regexp (concat - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|gemini\\|" "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" "\\(//[-a-z0-9_.]+:[0-9]*\\)?" (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") @@ -238,33 +240,6 @@ be used instead." :version "27.1" :type 'regexp) -(defcustom browse-url-netscape-program "netscape" - ;; Info about netscape-remote from Karl Berry. - "The name by which to invoke Netscape. - -The free program `netscape-remote' from -<URL:http://home.netscape.com/newsref/std/remote.c> is said to start -up very much quicker than `netscape'. Reported to compile on a GNU -system, given vroot.h from the same directory, with cc flags - -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11." - :type 'string) - -(make-obsolete-variable 'browse-url-netscape-program nil "25.1") - -(defcustom browse-url-netscape-arguments nil - "A list of strings to pass to Netscape as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-arguments nil "25.1") - -(defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments - "A list of strings to pass to Netscape when it starts up. -Defaults to the value of `browse-url-netscape-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-startup-arguments nil "25.1") - (defcustom browse-url-browser-display nil "The X display for running the browser, if not same as Emacs's." :type '(choice string (const :tag "Default" nil))) @@ -283,11 +258,13 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) +(defun browse-url--find-executable (candidates default) + (while (and candidates (not (executable-find (car candidates)))) + (setq candidates (cdr candidates))) + (or (car candidates) default)) + (defcustom browse-url-firefox-program - (let ((candidates '("icecat" "iceweasel" "firefox"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "firefox")) + (browse-url--find-executable '("icecat" "iceweasel") "firefox") "The name by which to invoke Firefox or a variant of it." :type 'string) @@ -305,10 +282,8 @@ Defaults to the value of `browse-url-firefox-arguments' at the time "it no longer has any effect." "24.5") (defcustom browse-url-chrome-program - (let ((candidates '("google-chrome-stable" "google-chrome"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("google-chrome-stable" "google-chrome") + "chromium") "The name by which to invoke the Chrome browser." :type 'string :version "25.1") @@ -319,10 +294,7 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :version "25.1") (defcustom browse-url-chromium-program - (let ((candidates '("chromium" "chromium-browser"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("chromium" "chromium-browser") "chromium") "The name by which to invoke Chromium." :type 'string :version "24.1") @@ -332,26 +304,6 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :type '(repeat (string :tag "Argument")) :version "24.1") -(defcustom browse-url-galeon-program "galeon" - "The name by which to invoke Galeon." - :type 'string) - -(make-obsolete-variable 'browse-url-galeon-program nil "25.1") - -(defcustom browse-url-galeon-arguments nil - "A list of strings to pass to Galeon as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-arguments nil "25.1") - -(defcustom browse-url-galeon-startup-arguments browse-url-galeon-arguments - "A list of strings to pass to Galeon when it starts up. -Defaults to the value of `browse-url-galeon-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-startup-arguments nil "25.1") - (defcustom browse-url-epiphany-program "epiphany" "The name by which to invoke GNOME Web (Epiphany)." :type 'string) @@ -366,7 +318,12 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) -;; GNOME means of invoking either Mozilla or Netscape. +(defcustom browse-url-webpositive-program "WebPositive" + "The name by which to invoke WebPositive." + :type 'string + :version "29.1") + +;; GNOME means of invoking Mozilla. (defvar browse-url-gnome-moz-program "gnome-moz-remote") (make-obsolete-variable 'browse-url-gnome-moz-program nil "25.1") @@ -399,29 +356,12 @@ If non-nil, then open the URL in a new buffer rather than a new window if (make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1") -(defcustom browse-url-galeon-new-window-is-tab nil - "Whether to open up new windows in a tab or a new window. -If non-nil, then open the URL in a new tab rather than a new window if -`browse-url-galeon' is asked to open it in a new window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1") - (defcustom browse-url-epiphany-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if `browse-url-epiphany' is asked to open it in a new window." :type 'boolean) -(defcustom browse-url-netscape-new-window-is-tab nil - "Whether to open up new windows in a tab or a new window. -If non-nil, then open the URL in a new tab rather than a new -window if `browse-url-netscape' is asked to open it in a new -window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1") - (defcustom browse-url-new-window-flag nil "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser @@ -518,14 +458,6 @@ You might want to set this to somewhere with restricted read permissions for privacy's sake." :type 'string) -(defcustom browse-url-netscape-version 3 - "The version of Netscape you are using. -This affects how URL reloading is done; the mechanism changed -incompatibly at version 4." - :type 'number) - -(make-obsolete-variable 'browse-url-netscape-version nil "25.1") - (defcustom browse-url-text-browser "lynx" "The name of the text browser to invoke." :type 'string @@ -730,8 +662,7 @@ position clicked before acting. This function returns a list (URL NEW-WINDOW-FLAG) for use in `interactive'." (let ((event (elt (this-command-keys) 0))) - (when (mouse-event-p event) - (mouse-set-point event))) + (mouse-set-point event)) (list (read-string prompt (or (and transient-mark-mode mark-active ;; rfc2396 Appendix E. (replace-regexp-in-string @@ -770,8 +701,10 @@ interactively. Turn the filename into a URL with function (cond ((not (buffer-modified-p))) (browse-url-save-file (save-buffer)) (t (message "%s modified since last save" file)))))) - (when (file-remote-p file) - (setq file (file-local-copy file))) + (when (and (file-remote-p file) + (not browse-url-temp-file-name)) + (setq browse-url-temp-file-name (file-local-copy file) + file browse-url-temp-file-name)) (browse-url (browse-url-file-url file)) (run-hooks 'browse-url-of-file-hook)) @@ -856,6 +789,8 @@ See `browse-url' for details." ;; A generic command to call the current browse-url-browser-function +(declare-function pgtk-backend-display-class "pgtkfns.c" (&optional terminal)) + ;;;###autoload (defun browse-url (url &rest args) "Open URL using a configurable method. @@ -893,8 +828,17 @@ If ARGS are omitted, the default is to pass ;; When connected to various displays, be careful to use the display of ;; the currently selected frame, rather than the original start display, ;; which may not even exist any more. - (if (stringp (frame-parameter nil 'display)) - (setenv "DISPLAY" (frame-parameter nil 'display))) + (let ((dpy (frame-parameter nil 'display)) + classname) + (if (stringp dpy) + (cond + ((featurep 'pgtk) + (setq classname (pgtk-backend-display-class)) + (if (equal classname "GdkWaylandDisplay") + (setenv "WAYLAND_DISPLAY" dpy) + (setenv "DISPLAY" dpy))) + (t + (setenv "DISPLAY" dpy))))) (if (functionp function) (apply function url args) (error "No suitable browser for URL %s" url)))) @@ -1003,8 +947,6 @@ The optional NEW-WINDOW argument is not used." (function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind 'external) -;; --- Netscape --- - (defun browse-url-process-environment () "Set DISPLAY in the environment to the X display the browser will use. This is either the value of variable `browse-url-browser-display' if @@ -1047,10 +989,9 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) ((executable-find browse-url-firefox-program) 'browse-url-firefox) ((executable-find browse-url-chromium-program) 'browse-url-chromium) -;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon) ((executable-find browse-url-kde-program) 'browse-url-kde) -;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ((executable-find browse-url-chrome-program) 'browse-url-chrome) + ((executable-find browse-url-webpositive-program) 'browse-url-webpositive) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) (t @@ -1083,82 +1024,6 @@ The optional argument IGNORED is not used." (function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external) ;;;###autoload -(defun browse-url-netscape (url &optional new-window) - "Ask the Netscape WWW browser to load URL. -Default to the URL around or before point. The strings in variable -`browse-url-netscape-arguments' are also passed to Netscape. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Netscape window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-netscape-new-window-is-tab' is non-nil, then -whenever a document would otherwise be loaded in a new window, it -is loaded in a new tab in an existing window instead. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process - (apply #'start-process - (concat "netscape " url) nil - browse-url-netscape-program - (append - browse-url-netscape-arguments - (if (eq window-system 'w32) - (list url) - (append - (if new-window '("-noraise")) - (list "-remote" - (concat "openURL(" url - (if (browse-url-maybe-new-window - new-window) - (if browse-url-netscape-new-window-is-tab - ",new-tab" - ",new-window")) - ")")))))))) - (set-process-sentinel process - (lambda (process _change) - (browse-url-netscape-sentinel process url))))) - -(function-put 'browse-url-netscape 'browse-url-browser-kind 'external) - -(defun browse-url-netscape-sentinel (process url) - "Handle a change to the process communicating with Netscape." - (declare (obsolete nil "25.1")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Netscape not running - start it - (message "Starting %s..." browse-url-netscape-program) - (apply #'start-process (concat "netscape" url) nil - browse-url-netscape-program - (append browse-url-netscape-startup-arguments (list url)))))) - -(defun browse-url-netscape-reload () - "Ask Netscape to reload its current document. -How depends on `browse-url-netscape-version'." - (declare (obsolete nil "25.1")) - (interactive) - ;; Backwards incompatibility reported by - ;; <peter.kruse@psychologie.uni-regensburg.de>. - (browse-url-netscape-send (if (>= browse-url-netscape-version 4) - "xfeDoCommand(reload)" - "reload"))) - -(defun browse-url-netscape-send (command) - "Send a remote control command to Netscape." - (declare (obsolete nil "25.1")) - (let* ((process-environment (browse-url-process-environment))) - (apply #'start-process "netscape" nil - browse-url-netscape-program - (append browse-url-netscape-arguments - (list "-remote" command))))) - -;;;###autoload (defun browse-url-mozilla (url &optional new-window) "Ask the Mozilla WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1278,56 +1143,6 @@ The optional argument NEW-WINDOW is not used." (function-put 'browse-url-chrome 'browse-url-browser-kind 'external) -;;;###autoload -(defun browse-url-galeon (url &optional new-window) - "Ask the Galeon WWW browser to load URL. -Default to the URL around or before point. The strings in variable -`browse-url-galeon-arguments' are also passed to Galeon. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Galeon window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-galeon-new-window-is-tab' is non-nil, then whenever a -document would otherwise be loaded in a new window, it is loaded in a -new tab in an existing window instead. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process (apply #'start-process - (concat "galeon " url) - nil - browse-url-galeon-program - (append - browse-url-galeon-arguments - (if (browse-url-maybe-new-window new-window) - (if browse-url-galeon-new-window-is-tab - '("--new-tab") - '("--new-window" "--noraise")) - '("--existing")) - (list url))))) - (set-process-sentinel process - (lambda (process _change) - (browse-url-galeon-sentinel process url))))) - -(function-put 'browse-url-galeon 'browse-url-browser-kind 'external) - -(defun browse-url-galeon-sentinel (process url) - "Handle a change to the process communicating with Galeon." - (declare (obsolete nil "25.1")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Galeon is not running - start it - (message "Starting %s..." browse-url-galeon-program) - (apply #'start-process (concat "galeon " url) nil - browse-url-galeon-program - (append browse-url-galeon-startup-arguments (list url)))))) - (defun browse-url-epiphany (url &optional new-window) "Ask the GNOME Web (Epiphany) WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1378,6 +1193,18 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) ;;;###autoload +(defun browse-url-webpositive (url &optional _new-window) + "Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((process-environment (browse-url-process-environment))) + (start-process (concat "WebPositive " url) nil "WebPositive" url))) + +(function-put 'browse-url-webpositive 'browse-url-browser-kind 'external) + +;;;###autoload (defun browse-url-emacs (url &optional same-window) "Ask Emacs to load URL into a buffer and show it in another window. Optional argument SAME-WINDOW non-nil means show the URL in the @@ -1399,7 +1226,7 @@ currently selected window instead." ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) - "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. + "Ask Mozilla to load URL via the GNOME program `gnome-moz-remote'. Default to the URL around or before point. The strings in variable `browse-url-gnome-moz-arguments' are also passed. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 54e8d0c5d4e..6a8bf879671 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -36,6 +36,7 @@ ;; Declare used subroutines and variables. (declare-function dbus-message-internal "dbusbind.c") (declare-function dbus--init-bus "dbusbind.c") +(declare-function libxml-parse-xml-region "xml.c") (defvar dbus-message-type-invalid) (defvar dbus-message-type-method-call) (defvar dbus-message-type-method-return) @@ -2102,7 +2103,7 @@ has been handled by this function." (interface (dbus-event-interface-name event)) (member (dbus-event-member-name event)) (arguments (dbus-event-arguments event)) - (time (time-to-seconds (current-time)))) + (time (float-time))) (save-excursion ;; Check for matching method-call. (goto-char (point-max)) @@ -2252,15 +2253,19 @@ keywords `:system-private' or `:session-private', respectively." bus nil dbus-path-local dbus-interface-local "Disconnected" #'dbus-handle-bus-disconnect))) - -;; Initialize `:system' and `:session' buses. This adds their file -;; descriptors to input_wait_mask, in order to detect incoming -;; messages immediately. -(when (featurep 'dbusbind) - (dbus-ignore-errors - (dbus-init-bus :system)) - (dbus-ignore-errors - (dbus-init-bus :session))) + +(defun dbus--init () + ;; Initialize `:system' and `:session' buses. This adds their file + ;; descriptors to input_wait_mask, in order to detect incoming + ;; messages immediately. + (when (featurep 'dbusbind) + (dbus-ignore-errors + (dbus-init-bus :system)) + (dbus-ignore-errors + (dbus-init-bus :session)))) + +(add-hook 'after-pdump-load-hook #'dbus--init) +(dbus--init) (provide 'dbus) diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 5258947902d..6831c4ffe3d 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -46,16 +46,9 @@ ;;; Code: (require 'wid-edit) - (require 'cl-lib) - -(unless (fboundp 'custom-menu-create) - (autoload 'custom-menu-create "cus-edit")) - (require 'eudc-vars) - - ;;{{{ Internal cooking ;;{{{ Internal variables and compatibility tricks diff --git a/lisp/net/eww.el b/lisp/net/eww.el index c39f6e3e1e1..eaa5c119385 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -178,6 +178,40 @@ the tab bar is enabled." :group 'eww :type 'hook) +(defcustom eww-auto-rename-buffer nil + "Automatically rename EWW buffers once the page is rendered. + +When nil, do not rename the buffer. With a non-nil value +determine the renaming scheme, as follows: + +- `title': Use the web page's title. +- `url': Use the web page's URL. +- a function's symbol: Run a user-defined function that returns a + string with which to rename the buffer. Sample of a + user-defined function: + + (defun my-eww-rename-buffer () + (when (eq major-mode 'eww-mode) + (when-let ((string (or (plist-get eww-data :title) + (plist-get eww-data :url)))) + (format \"*%s*\" string)))) + +The string of `title' and `url' is always truncated to the value +of `eww-buffer-name-length'." + :version "29.1" + :type '(choice + (const :tag "Do not rename buffers (default)" nil) + (const :tag "Rename buffer to web page title" title) + (const :tag "Rename buffer to web page URL" url) + (function :tag "A user-defined function to rename the buffer")) + :group 'eww) + +(defcustom eww-buffer-name-length 40 + "Length of renamed buffer name, per `eww-auto-rename-buffer'." + :type 'natnum + :version "29.1" + :group 'eww) + (defcustom eww-form-checkbox-selected-symbol "[X]" "Symbol used to represent a selected checkbox. See also `eww-form-checkbox-symbol'." @@ -197,8 +231,15 @@ See also `eww-form-checkbox-selected-symbol'." (const "☐") ; Unicode BALLOT BOX string)) +(defcustom eww-url-transformers '(eww-remove-tracking) + "This is a list of transforming functions applied to an URL before usage. +The functions will be called with the URL as the single +parameter, and should return the (possibly) transformed URL." + :type '(repeat function) + :version "29.1") + (defface eww-form-submit - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -206,7 +247,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-file - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -214,7 +255,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-checkbox - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -222,7 +263,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-select - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -271,15 +312,13 @@ See also `eww-form-checkbox-selected-symbol'." "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" "Value used for the HTTP 'Accept' header.") -(defvar eww-link-keymap - (let ((map (copy-keymap shr-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-link-keymap + :parent shr-map + "RET" #'eww-follow-link) -(defvar eww-image-link-keymap - (let ((map (copy-keymap shr-image-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-image-link-keymap + :parent shr-map + "RET" #'eww-follow-link) (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. @@ -313,13 +352,13 @@ will start Emacs and browse the GNU web site." ;;;###autoload -(defun eww (url &optional arg buffer) +(defun eww (url &optional new-buffer buffer) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. -If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing the default EWW buffer. If BUFFER, the data to be rendered is in that buffer. In that case, this function doesn't actually fetch URL. BUFFER will be @@ -329,11 +368,11 @@ killed after rendering." (list (read-string (format-prompt "Enter URL or keywords" (and uris (car uris))) nil 'eww-prompt-history uris) - (prefix-numeric-value current-prefix-arg)))) + current-prefix-arg))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window (cond - ((eq arg 4) + (new-buffer (generate-new-buffer "*eww*")) ((eq major-mode 'eww-mode) (current-buffer)) @@ -353,9 +392,10 @@ killed after rendering." (while (string-match "\\`/[.][.]/" (url-filename parsed)) (setf (url-filename parsed) (substring (url-filename parsed) 3)))) (setq url (url-recreate-url parsed))) + (setq url (eww--transform-url url)) (plist-put eww-data :url url) (plist-put eww-data :title "") - (eww-update-header-line-format) + (eww--after-page-change) (let ((inhibit-read-only t)) (insert (format "Loading %s..." url)) (goto-char (point-min))) @@ -504,6 +544,30 @@ Currently this means either text/html or application/xhtml+xml." (member content-type '("text/html" "application/xhtml+xml"))) +(defun eww--rename-buffer () + "Rename the current EWW buffer. +The renaming scheme is performed in accordance with +`eww-auto-rename-buffer'." + (let ((rename-string) + (formatter + (lambda (string) + (format "*%s # eww*" (truncate-string-to-width + string eww-buffer-name-length)))) + (site-title (plist-get eww-data :title)) + (site-url (plist-get eww-data :url))) + (cond ((null eww-auto-rename-buffer)) + ((eq eww-auto-rename-buffer 'url) + (setq rename-string (funcall formatter site-url))) + ((functionp eww-auto-rename-buffer) + (setq rename-string (funcall eww-auto-rename-buffer))) + (t (setq rename-string + (funcall formatter (if (or (equal site-title "") + (null site-title)) + "Untitled" + site-title))))) + (when rename-string + (rename-buffer rename-string t)))) + (defun eww-render (status url &optional point buffer encode) (let* ((headers (eww-parse-headers)) (content-type @@ -554,7 +618,7 @@ Currently this means either text/html or application/xhtml+xml." (eww-display-raw buffer (or encode charset 'utf-8)))) (with-current-buffer buffer (plist-put eww-data :url url) - (eww-update-header-line-format) + (eww--after-page-change) (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) @@ -638,14 +702,15 @@ Currently this means either text/html or application/xhtml+xml." (meta . eww-tag-meta) (a . eww-tag-a))))) (erase-buffer) - (shr-insert-document document) + (with-delayed-message (2 "Rendering HTML...") + (shr-insert-document document)) (cond (point (goto-char point)) (shr-target-id (goto-char (point-min)) (let ((match (text-property-search-forward - 'shr-target-id shr-target-id t))) + 'shr-target-id shr-target-id #'member))) (when match (goto-char (prop-match-beginning match))))) (t @@ -798,12 +863,16 @@ Currently this means either text/html or application/xhtml+xml." `((?u . ,(or url "")) (?t . ,title)))))))) +(defun eww--after-page-change () + (eww-update-header-line-format) + (eww--rename-buffer)) + (defun eww-tag-title (dom) (plist-put eww-data :title (replace-regexp-in-string "^ \\| $" "" (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom)))) - (eww-update-header-line-format)) + (eww--after-page-change)) (defun eww-display-raw (buffer &optional encode) (let ((data (buffer-substring (point) (point-max)))) @@ -931,7 +1000,7 @@ the like." nil (current-buffer)) (dolist (elem '(:source :url :title :next :previous :up)) (plist-put eww-data elem (plist-get old-data elem))) - (eww-update-header-line-format))) + (eww--after-page-change))) (defun eww-score-readability (node) (let ((score -1)) @@ -973,67 +1042,67 @@ the like." (setq result highest)))) result)) -(defvar eww-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead! - (define-key map "G" 'eww) - (define-key map [?\M-\r] 'eww-open-in-new-buffer) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - (define-key map [delete] 'scroll-down-command) - (define-key map "l" 'eww-back-url) - (define-key map "r" 'eww-forward-url) - (define-key map "n" 'eww-next-url) - (define-key map "p" 'eww-previous-url) - (define-key map "u" 'eww-up-url) - (define-key map "t" 'eww-top-url) - (define-key map "&" 'eww-browse-with-external-browser) - (define-key map "d" 'eww-download) - (define-key map "w" 'eww-copy-page-url) - (define-key map "C" 'url-cookie-list) - (define-key map "v" 'eww-view-source) - (define-key map "R" 'eww-readable) - (define-key map "H" 'eww-list-histories) - (define-key map "E" 'eww-set-character-encoding) - (define-key map "s" 'eww-switch-to-buffer) - (define-key map "S" 'eww-list-buffers) - (define-key map "F" 'eww-toggle-fonts) - (define-key map "D" 'eww-toggle-paragraph-direction) - (define-key map [(meta C)] 'eww-toggle-colors) - (define-key map [(meta I)] 'eww-toggle-images) - - (define-key map "b" 'eww-add-bookmark) - (define-key map "B" 'eww-list-bookmarks) - (define-key map [(meta n)] 'eww-next-bookmark) - (define-key map [(meta p)] 'eww-previous-bookmark) - - (easy-menu-define nil map "" - '("Eww" - ["Exit" quit-window t] - ["Close browser" quit-window t] - ["Reload" eww-reload t] - ["Follow URL in new buffer" eww-open-in-new-buffer] - ["Back to previous page" eww-back-url - :active (not (zerop (length eww-history)))] - ["Forward to next page" eww-forward-url - :active (not (zerop eww-history-position))] - ["Browse with external browser" eww-browse-with-external-browser t] - ["Download" eww-download t] - ["View page source" eww-view-source] - ["Copy page URL" eww-copy-page-url t] - ["List histories" eww-list-histories t] - ["Switch to buffer" eww-switch-to-buffer t] - ["List buffers" eww-list-buffers t] - ["Add bookmark" eww-add-bookmark t] - ["List bookmarks" eww-list-bookmarks t] - ["List cookies" url-cookie-list t] - ["Toggle fonts" eww-toggle-fonts t] - ["Toggle colors" eww-toggle-colors t] - ["Toggle images" eww-toggle-images t] - ["Character Encoding" eww-set-character-encoding] - ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) - map)) +(defvar-keymap eww-mode-map + "g" #'eww-reload ;FIXME: revert-buffer-function instead! + "G" #'eww + "M-RET" #'eww-open-in-new-buffer + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<backtab>" #'shr-previous-link + "<delete>" #'scroll-down-command + "l" #'eww-back-url + "r" #'eww-forward-url + "n" #'eww-next-url + "p" #'eww-previous-url + "u" #'eww-up-url + "t" #'eww-top-url + "&" #'eww-browse-with-external-browser + "d" #'eww-download + "w" #'eww-copy-page-url + "C" #'url-cookie-list + "v" #'eww-view-source + "R" #'eww-readable + "H" #'eww-list-histories + "E" #'eww-set-character-encoding + "s" #'eww-switch-to-buffer + "S" #'eww-list-buffers + "F" #'eww-toggle-fonts + "D" #'eww-toggle-paragraph-direction + "M-C" #'eww-toggle-colors + "M-I" #'eww-toggle-images + + "b" #'eww-add-bookmark + "B" #'eww-list-bookmarks + "M-n" #'eww-next-bookmark + "M-p" #'eww-previous-bookmark + + "<mouse-8>" #'eww-back-url + "<mouse-9>" #'eww-forward-url + + :menu '("Eww" + ["Exit" quit-window t] + ["Close browser" quit-window t] + ["Reload" eww-reload t] + ["Follow URL in new buffer" eww-open-in-new-buffer] + ["Back to previous page" eww-back-url + :active (not (zerop (length eww-history)))] + ["Forward to next page" eww-forward-url + :active (not (zerop eww-history-position))] + ["Browse with external browser" eww-browse-with-external-browser t] + ["Download" eww-download t] + ["View page source" eww-view-source] + ["Copy page URL" eww-copy-page-url t] + ["List histories" eww-list-histories t] + ["Switch to buffer" eww-switch-to-buffer t] + ["List buffers" eww-list-buffers t] + ["Add bookmark" eww-add-bookmark t] + ["List bookmarks" eww-list-bookmarks t] + ["List cookies" url-cookie-list t] + ["Toggle fonts" eww-toggle-fonts t] + ["Toggle colors" eww-toggle-colors t] + ["Toggle images" eww-toggle-images t] + ["Character Encoding" eww-set-character-encoding] + ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) (defun eww-context-menu (menu click) "Populate MENU with eww commands at CLICK." @@ -1166,7 +1235,7 @@ instead of `browse-url-new-window-flag'." (goto-char (plist-get elem :point)) ;; Make buffer listings more informative. (setq list-buffers-directory (plist-get elem :url)) - (eww-update-header-line-format)))) + (eww--after-page-change)))) (defun eww-next-url () "Go to the page marked `next'. @@ -1230,54 +1299,43 @@ just re-display the HTML already fetched." (defvar eww-form nil) -(defvar eww-submit-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-submit) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-submit-file - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-select-file) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-checkbox-map - (let ((map (make-sparse-keymap))) - (define-key map " " 'eww-toggle-checkbox) - (define-key map "\r" 'eww-toggle-checkbox) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-text-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'eww-submit) - (define-key map [(control a)] 'eww-beginning-of-text) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [(control e)] 'eww-end-of-text) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-textarea-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'forward-line) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-select-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-change-select) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'eww-change-select) - (define-key map [(control c) (control c)] 'eww-submit) - map)) +(defvar-keymap eww-submit-map + "RET" #'eww-submit + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-submit-file + "RET" #'eww-select-file + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-checkbox-map + "SPC" #'eww-toggle-checkbox + "RET" #'eww-toggle-checkbox + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-text-map + :full t :parent text-mode-map + "RET" #'eww-submit + "C-a" #'eww-beginning-of-text + "C-c C-c" #'eww-submit + "C-e" #'eww-end-of-text + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-textarea-map + :full t :parent text-mode-map + "RET" #'forward-line + "C-c C-c" #'eww-submit + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-select-map + :doc "Map for select buttons" + "RET" #'eww-change-select + "<follow-link>" 'mouse-face + "<mouse-2>" #'eww-change-select + "C-c C-c" #'eww-submit) (defun eww-beginning-of-text () "Move to the start of the input field." @@ -1784,6 +1842,17 @@ The browser to used is specified by the (funcall browse-url-secondary-browser-function (or url (plist-get eww-data :url)))) +(defun eww-remove-tracking (url) + "Remove the commong utm_ tracking cookies from URLs." + (replace-regexp-in-string ".utm_.*" "" url)) + +(defun eww--transform-url (url) + "Appy `eww-url-transformers'." + (when url + (dolist (func eww-url-transformers) + (setq url (funcall func url))) + url)) + (defun eww-follow-link (&optional external mouse-event) "Browse the URL under point. If EXTERNAL is single prefix, browse the URL using @@ -1794,7 +1863,8 @@ If EXTERNAL is double prefix, browse in new buffer." (list current-prefix-arg last-nonmenu-event) eww-mode) (mouse-set-point mouse-event) - (let ((url (get-text-property (point) 'shr-url))) + (let* ((orig-url (get-text-property (point) 'shr-url)) + (url (eww--transform-url orig-url))) (cond ((not url) (message "No link under point")) @@ -1813,7 +1883,7 @@ If EXTERNAL is double prefix, browse in new buffer." (plist-put eww-data :url url) (eww-display-html 'utf-8 url dom nil (current-buffer)))) (t - (eww-browse-url url external))))) + (eww-browse-url orig-url external))))) (defun eww-same-page-p (url1 url2) "Return non-nil if URL1 and URL2 represent the same page. @@ -2100,23 +2170,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." 'eww-bookmark))) (eww-browse-url (plist-get bookmark :url)))) -(defvar eww-bookmark-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-bookmark-kill) - (define-key map [(control y)] 'eww-bookmark-yank) - (define-key map "\r" 'eww-bookmark-browse) - - (easy-menu-define nil map - "Menu for `eww-bookmark-mode-map'." - '("Eww Bookmark" - ["Exit" quit-window t] - ["Browse" eww-bookmark-browse - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Kill" eww-bookmark-kill - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Yank" eww-bookmark-yank - :active eww-bookmark-kill-ring])) - map)) +(defvar-keymap eww-bookmark-mode-map + "C-k" #'eww-bookmark-kill + "C-y" #'eww-bookmark-yank + "RET" #'eww-bookmark-browse + :menu '("Eww Bookmark" + ["Exit" quit-window t] + ["Browse" eww-bookmark-browse + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Kill" eww-bookmark-kill + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Yank" eww-bookmark-yank + :active eww-bookmark-kill-ring])) (define-derived-mode eww-bookmark-mode special-mode "eww bookmarks" "Mode for listing bookmarks. @@ -2181,19 +2246,15 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (pop-to-buffer-same-window buffer))) (eww-restore-history history))) -(defvar eww-history-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-history-browse) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - - (easy-menu-define nil map - "Menu for `eww-history-mode-map'." - '("Eww History" - ["Exit" quit-window t] - ["Browse" eww-history-browse - :active (get-text-property (line-beginning-position) 'eww-history)])) - map)) +(defvar-keymap eww-history-mode-map + "RET" #'eww-history-browse + "n" #'next-line + "p" #'previous-line + :menu '("Eww History" + ["Exit" quit-window t] + ["Browse" eww-history-browse + :active (get-text-property (line-beginning-position) + 'eww-history)])) (define-derived-mode eww-history-mode special-mode "eww history" "Mode for listing eww-histories. @@ -2304,22 +2365,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (forward-line -1)) (eww-buffer-show)) -(defvar eww-buffers-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-buffer-kill) - (define-key map "\r" 'eww-buffer-select) - (define-key map "n" 'eww-buffer-show-next) - (define-key map "p" 'eww-buffer-show-previous) - - (easy-menu-define nil map - "Menu for `eww-buffers-mode-map'." - '("Eww Buffers" - ["Exit" quit-window t] - ["Select" eww-buffer-select - :active (get-text-property (line-beginning-position) 'eww-buffer)] - ["Kill" eww-buffer-kill - :active (get-text-property (line-beginning-position) 'eww-buffer)])) - map)) +(defvar-keymap eww-buffers-mode-map + "C-k" #'eww-buffer-kill + "RET" #'eww-buffer-select + "n" #'eww-buffer-show-next + "p" #'eww-buffer-show-previous + :menu '("Eww Buffers" + ["Exit" quit-window t] + ["Select" eww-buffer-select + :active (get-text-property (line-beginning-position) 'eww-buffer)] + ["Kill" eww-buffer-kill + :active (get-text-property (line-beginning-position) + 'eww-buffer)])) (define-derived-mode eww-buffers-mode special-mode "eww buffers" "Mode for listing buffers. diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index 13af2c123f8..0c8a29cc392 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -37,6 +37,7 @@ a string and return a digest of it (in binary form). B is a byte length of a block size of H. (B=64 for both SHA1 and MD5.) L is a byte length of hash outputs. (L=16 for MD5, L=20 for SHA1.) If BIT is non-nil, truncate output to specified bits." + (declare (indent defun)) `(defun ,name (text key) ,(concat "Compute " (upcase (symbol-name name)) diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index a59220c1be8..bf3c8edd1e3 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -55,7 +55,7 @@ you have an entry for \"image/*\" in your ~/.mailcap file." "A syntax table for parsing SGML attributes.") (defvar mailcap-print-command - (mapconcat 'identity + (mapconcat #'identity (cons (if (boundp 'lpr-command) lpr-command "lpr") @@ -116,8 +116,7 @@ is consulted." (regexp :tag "MIME Type") (sexp :tag "Test (optional)"))) :get #'mailcap--get-user-mime-data - :set #'mailcap--set-user-mime-data - :group 'mailcap) + :set #'mailcap--set-user-mime-data) ;; Postpone using defcustom for this as it's so big and we essentially ;; have to have two copies of the data around then. Perhaps just @@ -344,8 +343,7 @@ Same format as `mailcap-mime-data'.") "Directory to which `mailcap-save-binary-file' downloads files by default. nil means your home directory." :type '(choice (const :tag "Home directory" nil) - directory) - :group 'mailcap) + directory)) (defvar mailcap-poor-system-types '(ms-dos windows-nt) @@ -423,14 +421,6 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus (interactive (list nil t)) (when (or (not mailcap-parsed-p) force) - ;; Clear out all old data. - (setq mailcap--computed-mime-data nil) - ;; Add the Emacs-distributed defaults (which will be used as - ;; fallbacks). Do it this way instead of just copying the list, - ;; since entries are destructively modified. - (cl-loop for (major . minors) in mailcap-mime-data - do (cl-loop for (minor . entry) in minors - do (mailcap-add-mailcap-entry major minor entry))) (cond (path nil) ((getenv "MAILCAPS") @@ -447,18 +437,26 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ("/etc/mailcap" system) ("/usr/etc/mailcap" system) ("/usr/local/etc/mailcap" system))))) - ;; The ~/.mailcap entries will end up first in the resulting data. - (dolist (spec (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (let ((source (and (consp spec) (cadr spec))) - (file-name (if (stringp spec) - spec - (car spec)))) - (when (and (file-readable-p file-name) - (file-regular-p file-name)) - (mailcap-parse-mailcap file-name source)))) + (when (stringp path) + (setq path (mapcar #'list (split-string path path-separator t)))) + (when (seq-some (lambda (f) + (file-has-changed-p (car f) 'mail-parse-mailcaps)) + path) + ;; Clear out all old data. + (setq mailcap--computed-mime-data nil) + ;; Add the Emacs-distributed defaults (which will be used as + ;; fallbacks). Do it this way instead of just copying the list, + ;; since entries are destructively modified. + (cl-loop for (major . minors) in mailcap-mime-data + do (cl-loop for (minor . entry) in minors + do (mailcap-add-mailcap-entry major minor entry))) + ;; The ~/.mailcap entries will end up first in the resulting data. + (dolist (spec (reverse path)) + (let ((source (cadr spec)) + (file-name (car spec))) + (when (and (file-readable-p file-name) + (file-regular-p file-name)) + (mailcap-parse-mailcap file-name source))))) (setq mailcap-parsed-p t))) (defun mailcap-parse-mailcap (fname &optional source) @@ -636,7 +634,7 @@ the test clause will be unchanged." ((and (listp test) (symbolp (car test))) test) ((or (stringp test) (and (listp test) (stringp (car test)) - (setq test (mapconcat 'identity test " ")))) + (setq test (mapconcat #'identity test " ")))) (with-temp-buffer (insert test) (goto-char (point-min)) @@ -707,12 +705,12 @@ to supply to the test." (symbol-value test)) ((and (listp test) ; List to be eval'd (symbolp (car test))) - (eval test)) + (eval test t)) (t (setq test (mailcap-unescape-mime-test test type-info) test (list shell-file-name nil nil nil shell-command-switch test) - status (apply 'call-process test)) + status (apply #'call-process test)) (eq 0 status)))) (push (list otest result) mailcap-viewer-test-cache) result)))) @@ -837,7 +835,7 @@ If NO-DECODE is non-nil, don't decode STRING." (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp)) + (setq passed (sort (nreverse passed) #'mailcap-viewer-lessp)) ;; When we want to prefer entries from the user's ;; ~/.mailcap file, then we filter out the system entries ;; and see whether we have anything left. @@ -1065,12 +1063,21 @@ For instance, \"foo.png\" will result in \"image/png\"." (match-string 1 file-name) ""))) +;;;###autoload +(defun mailcap-mime-type-to-extension (mime-type) + "Return a file name extension based on a MIME-TYPE. +For instance, `image/png' will result in `png'." + (intern (cadr (split-string (if (symbolp mime-type) + (symbol-name mime-type) + mime-type) + "/")))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) (delete-dups (nconc - (mapcar 'cdr mailcap-mime-extensions) + (mapcar #'cdr mailcap-mime-extensions) (let (res type) (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 01cbbbbe011..a62a7bd8b7d 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -402,13 +402,6 @@ headline after it has been retrieved for the first time." "Miscellaneous newsticker settings." :group 'newsticker) -(defcustom newsticker-cache-filename - "~/.newsticker-cache" - "Name of the newsticker cache file." - :type 'string - :group 'newsticker-miscellaneous) -(make-obsolete-variable 'newsticker-cache-filename 'newsticker-dir "23.1") - (defcustom newsticker-dir (locate-user-emacs-file "newsticker/" ".newsticker/") "Directory where newsticker saves data." @@ -2114,28 +2107,6 @@ well." (throw 'result t))))) (< (or (newsticker--pos item1) 0) (or (newsticker--pos item2) 0)))) -(defun newsticker--cache-save-version1 () - "Update and save newsticker cache file." - (interactive) - (newsticker--cache-update t)) - -(defun newsticker--cache-update (&optional save) - "Update newsticker cache file. -If optional argument SAVE is not nil the cache file is saved to disk." - (save-excursion - (unless (file-directory-p newsticker-dir) - (make-directory newsticker-dir t)) - (let ((coding-system-for-write 'utf-8) - (buf (find-file-noselect newsticker-cache-filename))) - (when buf - (set-buffer buf) - (setq buffer-undo-list t) - (erase-buffer) - (insert ";; -*- coding: utf-8 -*-\n") - (insert (prin1-to-string newsticker--cache)) - (when save - (save-buffer)))))) - (defun newsticker--cache-get-feed (feed) "Return the cached data for the feed FEED. FEED is a symbol!" @@ -2162,30 +2133,11 @@ FEED is a symbol!" (insert ";; -*- coding: utf-8 -*-\n") (insert (prin1-to-string (cdr feed))))))) -(defun newsticker--cache-read-version1 () - "Read version1 cache data." - (let ((coding-system-for-read 'utf-8)) - (when (file-exists-p newsticker-cache-filename) - (with-temp-buffer - (insert-file-contents newsticker-cache-filename) - (goto-char (point-min)) - (condition-case nil - (setq newsticker--cache (read (current-buffer))) - (error - (message "Error while reading newsticker cache file!") - (setq newsticker--cache nil))))))) - (defun newsticker--cache-read () "Read cache data." (setq newsticker--cache nil) - (if (file-exists-p newsticker-cache-filename) - (progn - (when (y-or-n-p "Old newsticker cache file exists. Read it? ") - (newsticker--cache-read-version1)) - (when (y-or-n-p "Delete old newsticker cache file? ") - (delete-file newsticker-cache-filename))) - (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) - (newsticker--cache-read-feed (car f))))) + (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker--cache-read-feed (car f)))) (defun newsticker--cache-read-feed (feed-name) "Read cache data for feed named FEED-NAME." diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index f026948251d..df574dfa2f4 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -589,7 +589,7 @@ calls `w3m-toggle-inline-image'. It works only if (defun newsticker-close-buffer () "Close the newsticker buffer." (interactive) - (newsticker--cache-update t) + (newsticker--cache-save) (bury-buffer)) (defun newsticker-next-new-item (&optional do-not-wrap-at-eob) @@ -748,7 +748,7 @@ Return new buffer position." (newsticker--cache-replace-age newsticker--cache feed 'new 'old) (newsticker--cache-replace-age newsticker--cache feed 'obsolete 'old) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) (newsticker-buffer-update) @@ -879,7 +879,7 @@ not get changed." (newsticker--cache-replace-age newsticker--cache 'any 'new 'old) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker-buffer-update))) (defun newsticker-hide-extra () diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index d95593da3bc..3146189be63 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -79,8 +79,7 @@ option." (const :tag "Off" nil) (function :tag "Custom function"))) -(defcustom nsm-settings-file (expand-file-name "network-security.data" - user-emacs-directory) +(defcustom nsm-settings-file (locate-user-emacs-file "network-security.data") "The file the security manager settings will be stored in." :version "25.1" :type 'file) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index 1589770f203..b58f0abb56b 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -102,9 +102,7 @@ is not given." (let ((request-ident (concat "NTLMSSP" (make-string 1 0))) (request-msgType (concat (make-string 1 1) (make-string 3 0))) ;0x01 0x00 0x00 0x00 - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) ) (when (and user (string-match "@" user)) (unless domain @@ -245,9 +243,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes ;; match default setting in `ntlm-build-auth-request' - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes ;; Extract domain string from challenge string. diff --git a/lisp/net/puny.el b/lisp/net/puny.el index d22cc88b7bd..3a276791ab2 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -43,6 +43,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." "Encode STRING according to the IDNA/punycode algorithm. This is used to encode non-ASCII domain names. For instance, \"bücher\" => \"xn--bcher-kva\"." + (setq string (downcase (string-glyph-compose string))) (let ((ascii (seq-filter (lambda (char) (< char 128)) string))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 8feef6beebe..62e6281e035 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -262,6 +262,7 @@ The ARGUMENTS for each METHOD symbol are: `bitlbee': NICK PASSWORD `quakenet': ACCOUNT PASSWORD `sasl': NICK PASSWORD + `certfp': KEY CERT Examples: ((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\") @@ -291,7 +292,11 @@ Examples: (list :tag "SASL" (const sasl) (string :tag "Nick") - (string :tag "Password"))))) + (string :tag "Password")) + (list :tag "CertFP" + (const certfp) + (string :tag "Key") + (string :tag "Certificate"))))) (defcustom rcirc-auto-authenticate-flag t "Non-nil means automatically send authentication string to server. @@ -547,6 +552,9 @@ If ARG is non-nil, instead prompt for connection parameters." (password (plist-get (cdr c) :password)) (encryption (plist-get (cdr c) :encryption)) (server-alias (plist-get (cdr c) :server-alias)) + (client-cert (when (eq (rcirc-get-server-method (car c)) + 'certfp) + (rcirc-get-server-cert (car c)))) contact) (when-let (((not password)) (auth (auth-source-search :host server @@ -563,7 +571,7 @@ If ARG is non-nil, instead prompt for connection parameters." (condition-case nil (let ((process (rcirc-connect server port nick user-name full-name channels password encryption - server-alias))) + client-cert server-alias))) (when rcirc-display-server-buffer (pop-to-buffer-same-window (process-buffer process)))) (quit (message "Quit connecting to %s" @@ -646,29 +654,23 @@ See `rcirc-connect' for more details on these variables.") (defun rcirc-get-server-method (server) "Return authentication method for SERVER." - (catch 'method - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (method (cadr i))) - (when (string-match server-i server) - (throw 'method method)))))) + (cadr (assoc server rcirc-authinfo #'string-match))) (defun rcirc-get-server-password (server) "Return password for SERVER." - (catch 'pass - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (args (cdddr i))) - (when (string-match server-i server) - (throw 'pass (car args))))))) + (cadddr (assoc server rcirc-authinfo #'string-match))) + +(defun rcirc-get-server-cert (server) + "Return a list of key and certificate for SERVER." + (cddr (assoc server rcirc-authinfo #'string-match))) ;;;###autoload (defun rcirc-connect (server &optional port nick user-name full-name startup-channels password encryption - server-alias) + certfp server-alias) "Connect to SERVER. The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, -ENCRYPTION, SERVER-ALIAS are interpreted as in +ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in `rcirc-server-alist'. STARTUP-CHANNELS is a list of channels that are joined after authentication." (save-excursion @@ -695,6 +697,7 @@ that are joined after authentication." (setq process (open-network-stream (or server-alias server) nil server port-number :type (or encryption 'plain) + :client-certificate certfp :nowait t)) (set-process-coding-system process 'raw-text 'raw-text) (with-current-buffer (get-buffer-create (rcirc-generate-new-buffer-name process nil)) @@ -713,8 +716,8 @@ that are joined after authentication." (setq rcirc-nick-table (make-hash-table :test 'equal)) (setq rcirc-nick nick) (setq rcirc-startup-channels startup-channels) - (setq rcirc-last-server-message-time (current-time)) (setq rcirc-last-connect-time (current-time)) + (setq rcirc-last-server-message-time rcirc-last-connect-time) ;; Check if the immediate process state (sit-for .1) diff --git a/lisp/net/sasl-scram-rfc.el b/lisp/net/sasl-scram-rfc.el index b8d83627963..ee52ed6e071 100644 --- a/lisp/net/sasl-scram-rfc.el +++ b/lisp/net/sasl-scram-rfc.el @@ -90,6 +90,8 @@ (sasl-mechanism-name (sasl-client-mechanism client)) (sasl-client-name client)))) (salt (base64-decode-string salt-base64)) + (string-xor (lambda (a b) + (apply #'unibyte-string (cl-mapcar #'logxor a b)))) (salted-password ;; Hi(str, salt, i): (let ((digest (concat salt (string 0 0 0 1))) @@ -98,7 +100,7 @@ (setq digest (funcall hmac-fun digest password)) (setq xored (if (null xored) digest - (cl-map 'string 'logxor xored digest)))))) + (funcall string-xor xored digest)))))) (client-key (funcall hmac-fun "Client Key" salted-password)) (stored-key (decode-hex-string (funcall hash-fun client-key))) @@ -108,7 +110,7 @@ step-data "," client-final-message-without-proof)) (client-signature (funcall hmac-fun (encode-coding-string auth-message 'utf-8) stored-key)) - (client-proof (cl-map 'string 'logxor client-key client-signature)) + (client-proof (funcall string-xor client-key client-signature)) (client-final-message (concat client-final-message-without-proof "," "p=" (base64-encode-string client-proof)))) diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index c4ba99f47c8..e0def55ad9f 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -174,21 +174,24 @@ It contain at least 64 bits of entropy." ;; stolen (and renamed) from message.el (defun sasl-unique-id-function () - ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Don't use fractional seconds from timestamp; they may be unsupported. ;; Instead we use this randomly inited counter. (setq sasl-unique-id-char - (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20))))) - ;; (current-time) returns 16-bit ints, - ;; and 2^16*25 just fits into 4 digits i base 36. - (* 25 25))) - (let ((tm (current-time))) + ;; 2^16 * 25 just fits into 4 digits i base 36. + (let ((base (* 25 25))) + (if sasl-unique-id-char + (% (1+ sasl-unique-id-char) base) + (random base)))) + (let ((tm (time-convert nil 'integer))) (concat (sasl-unique-id-number-base36 - (+ (car tm) - (ash (% sasl-unique-id-char 25) 16)) 4) + (+ (ash tm -16) + (ash (% sasl-unique-id-char 25) 16)) + 4) (sasl-unique-id-number-base36 - (+ (nth 1 tm) - (ash (/ sasl-unique-id-char 25) 16)) 4)))) + (+ (logand tm #xffff) + (ash (/ sasl-unique-id-char 25) 16)) + 4)))) (defun sasl-unique-id-number-base36 (num len) (if (if (< len 0) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index faadcb94b11..d8341774e47 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -77,15 +77,17 @@ ;; (secrets-delete-collection "my collection") ;; (secrets-create-collection "my collection") -;; There exists a special collection called "session", which has the -;; lifetime of the corresponding client session (aka Emacs's -;; lifetime). It is created automatically when Emacs uses the Secret -;; Service interface, and it is deleted when Emacs is killed. +;; With GNOME Keyring, there exists a special collection called +;; "session", which has the lifetime of the user being logged in. Its +;; data are not stored on disk and go away when the user logs out. ;; Therefore, it can be used to store and retrieve secret items -;; temporarily. This shall be preferred over creation of a persistent -;; collection, when the information shall not live longer than Emacs. -;; The session collection can be addressed either by the string -;; "session", or by nil, whenever a collection parameter is needed. +;; temporarily. The "session" collection can be addressed either by +;; the string "session", or by nil, whenever a collection parameter is +;; needed. + +;; However, other Secret Service provider don't create this temporary +;; "session" collection. You shall check first that this collection +;; exists, before you use it. ;; As already said, a collection is a group of secret items. A secret ;; item has a label, the "secret" (which is a string), and a set of @@ -98,8 +100,7 @@ ;; => ("this item" "another item") ;; Secret items can be added or deleted to a collection. In the -;; following examples, we use the special collection "session", which -;; is bound to Emacs's lifetime. +;; following examples, we use the special collection "session". ;; ;; (secrets-delete-item "session" "my item") ;; (secrets-create-item "session" "my item" "geheim" @@ -137,7 +138,7 @@ ;; It has been tested with GNOME Keyring 2.29.92. An implementation ;; for KWallet will be available at ;; svn://anonsvn.kde.org/home/kde/trunk/playground/base/ksecretservice; -;; not tested yet. +;; not tested yet. This package has also been tested with KeePassXC 2.6.6. ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used @@ -263,6 +264,7 @@ It returns t if not." ;; </signal> ;; </interface> +;; This exist only for GNOME Keyring. (defconst secrets-session-collection-path "/org/freedesktop/secrets/collection/session" "The D-Bus temporary session collection object path.") @@ -311,43 +313,8 @@ It returns t if not." (defconst secrets-interface-item-type-generic "org.freedesktop.Secret.Generic" "The default item type we are using.") -;; We cannot use introspection, because some servers, like -;; mate-keyring-daemon, don't provide relevant data. Once the dust -;; has settled, we shall assume the new interface, and get rid of the test. -(defconst secrets-struct-secret-content-type - (ignore-errors - (let ((content-type "text/plain") - (path (cadr - (dbus-call-method - :session secrets-service secrets-path - secrets-interface-service - "OpenSession" "plain" '(:variant "")))) - result) - ;; Create a dummy item. - (setq result - (dbus-call-method - :session secrets-service secrets-session-collection-path - secrets-interface-collection "CreateItem" - ;; Properties. - `(:array - (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant " "))) - ;; Secret. - `(:struct :object-path ,path - (:array :signature "y") - ,(dbus-string-to-byte-array " ") - :string ,content-type) - ;; Don't replace. - nil)) - ;; Remove it. - (dbus-call-method - :session secrets-service (car result) - secrets-interface-item "Delete") - ;; Result. - `(,content-type))) - "The content_type of a secret struct. -It must be wrapped as list, because we add it via `append'. This -is an interface introduced in 2011.") +(defconst secrets-struct-secret-content-type "text/plain" + "The content_type of a secret struct.") (defconst secrets-interface-session "org.freedesktop.Secret.Session" "A session tracks state between the service and a client application.") @@ -696,13 +663,10 @@ The object path of the created item is returned." `((:dict-entry ,(concat secrets-interface-item ".Attributes") (:variant ,(append '(:array) props)))))) ;; Secret. - (append - `(:struct :object-path ,secrets-session-path - (:array :signature "y") ;; No parameters. - ,(dbus-string-to-byte-array password)) - ;; We add the content_type. In backward compatibility - ;; mode, nil is appended, which means nothing. - secrets-struct-secret-content-type) + `(:struct :object-path ,secrets-session-path + (:array :signature "y") ;; No parameters. + ,(dbus-string-to-byte-array password) + ,secrets-struct-secret-content-type) ;; Do not replace. Replace does not seem to work. nil)) (secrets-prompt (cadr result)) @@ -943,7 +907,7 @@ to their attributes." secrets-interface-service "CollectionDeleted" 'secrets-collection-handler) - ;; We shall inform, whether the secret service is enabled on this + ;; We shall inform, that the secret service is enabled on this ;; machine. (setq secrets-enabled t)) @@ -954,6 +918,7 @@ to their attributes." ;; * secrets-debug should be structured like auth-source-debug to ;; prevent leaking sensitive information. Right now I don't see ;; anything sensitive though. + ;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be ;; used for the transfer of the secrets. Currently, we use the ;; plain algorithm. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index e8b0fbc18c4..7363874cf3c 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -40,6 +40,7 @@ (require 'image) (require 'puny) (require 'url-cookie) +(require 'pixel-fill) (require 'text-property-search) (defgroup shr nil @@ -56,8 +57,15 @@ fit these criteria." :version "24.1" :type 'float) +(defcustom shr-allowed-images nil + "If non-nil, only images that match this regexp are displayed. +If nil, all URLs are allowed. Also see `shr-blocked-images'." + :version "29.1" + :type '(choice (const nil) regexp)) + (defcustom shr-blocked-images nil - "Images that have URLs matching this regexp will be blocked." + "Images that have URLs matching this regexp will be blocked. +If nil, no images are blocked. Also see `shr-allowed-images'." :version "24.1" :type '(choice (const nil) regexp)) @@ -162,6 +170,10 @@ cid: URL as the argument.") (defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") +(defface shr-text '((t :inherit variable-pitch-text)) + "Face used for rendering text." + :version "29.1") + (defface shr-strike-through '((t :strike-through t)) "Face for <s> elements." :version "24.1") @@ -183,6 +195,11 @@ temporarily blinks with this face." "Face for <abbr> elements." :version "27.1") +(defface shr-sup + '((t :height 0.8)) + "Face for <sup> and <sub> elements." + :version "29.1") + (defface shr-h1 '((t :height 1.3 :weight bold)) "Face for <h1> elements." @@ -231,7 +248,6 @@ and other things: (defvar shr-internal-width nil) (defvar shr-list-mode nil) (defvar shr-content-cache nil) -(defvar shr-kinsoku-shorten nil) (defvar shr-table-depth 0) (defvar shr-stylesheet nil) (defvar shr-base nil) @@ -246,24 +262,23 @@ and other things: (defvar shr-target-id nil "Target fragment identifier anchor.") - -(defvar shr-map - (let ((map (make-sparse-keymap))) - (define-key map "a" #'shr-show-alt-text) - (define-key map "i" #'shr-browse-image) - (define-key map "z" #'shr-zoom-image) - (define-key map [?\t] #'shr-next-link) - (define-key map [?\M-\t] #'shr-previous-link) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] #'shr-browse-url) - (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window) - (define-key map "I" #'shr-insert-image) - (define-key map "w" #'shr-maybe-probe-and-copy-url) - (define-key map "u" #'shr-maybe-probe-and-copy-url) - (define-key map "v" #'shr-browse-url) - (define-key map "O" #'shr-save-contents) - (define-key map "\r" #'shr-browse-url) - map)) +(defvar shr--link-targets nil) + +(defvar-keymap shr-map + "a" #'shr-show-alt-text + "i" #'shr-browse-image + "z" #'shr-zoom-image + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<follow-link>" 'mouse-face + "<mouse-2>" #'shr-browse-url + "C-<down-mouse-1>" #'shr-mouse-browse-url-new-window + "I" #'shr-insert-image + "w" #'shr-maybe-probe-and-copy-url + "u" #'shr-maybe-probe-and-copy-url + "v" #'shr-browse-url + "O" #'shr-save-contents + "RET" #'shr-browse-url) (defvar shr-image-map (let ((map (copy-keymap shr-map))) @@ -305,6 +320,18 @@ and other things: (or (not (zerop (fringe-columns 'right))) (not (zerop (fringe-columns 'left)))))) +(defun shr--window-width () + ;; Compute the width based on the window width. We need to + ;; adjust the available width for when the user disables + ;; the fringes, which will cause the display engine usurp + ;; one column for the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (shr--have-one-fringe-p) + 1 + 0)) + (pixel-fill-width))) + ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -326,22 +353,9 @@ DOM should be a parse tree as generated by (if (not shr-use-fonts) shr-width (* shr-width (frame-char-width))) - ;; Compute the width based on the window width. We need to - ;; adjust the available width for when the user disables - ;; the fringes, which will cause the display engine usurp - ;; one column for the continuation glyph. - (if (not shr-use-fonts) - (- (window-body-width) 1 - (if (shr--have-one-fringe-p) - 1 - 0)) - (- (window-body-width nil t) - (* 2 (frame-char-width)) - (if (shr--have-one-fringe-p) - 0 - (* (frame-char-width) 2)) - 1)))) + (shr--window-width))) (max-specpdl-size max-specpdl-size) + (shr--link-targets nil) ;; `bidi-display-reordering' is supposed to be only used for ;; debugging purposes, but Shr's naïve filling algorithm ;; cannot cope with the complexity of RTL text in an LTR @@ -365,9 +379,22 @@ DOM should be a parse tree as generated by (shr-descend dom) (shr-fill-lines start (point)) (shr--remove-blank-lines-at-the-end start (point)) + (shr--set-target-ids shr--link-targets) (when shr-warning (message "%s" shr-warning)))) +(defun shr--set-target-ids (ids) + ;; If the buffer is empty, there's no point in setting targets. + (unless (zerop (buffer-size)) + ;; We may have several targets in the same place (if you have + ;; several <span id='foo'> things after one another). So group + ;; them by position. + (dolist (group (seq-group-by #'cdr ids)) + (let ((point (min (1- (point-max)) (car group)))) + (put-text-property point (1+ point) + 'shr-target-id + (mapcar #'car (cdr group))))))) + (defun shr--remove-blank-lines-at-the-end (start end) (save-restriction (save-excursion @@ -547,6 +574,12 @@ size, and full-buffer size." (shr-insert sub) (shr-descend sub)))) +(defun shr-image-blocked-p (url) + (or (and shr-blocked-images + (string-match shr-blocked-images url)) + (and shr-allowed-images + (not (string-match shr-allowed-images url))))) + (defun shr-indirect-call (tag-name dom &rest args) (let ((function (intern (concat "shr-tag-" (symbol-name tag-name)) obarray)) ;; Allow other packages to override (or provide) rendering @@ -577,7 +610,7 @@ size, and full-buffer size." (setq shr-warning "Not rendering the complete page because of too-deep nesting") (when style - (if (string-match "color\\|display\\|border-collapse" style) + (if (string-match-p "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) @@ -596,16 +629,8 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when-let* ((id (dom-attr dom 'id))) - ;; If the element was empty, we don't have anything to put the - ;; anchor on. So just insert a dummy character. - (when (= start (point)) - (if (not (bolp)) - (insert ? ) - (insert ? ) - (shr-mark-fill start)) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property (1- (point)) (point) 'shr-target-id id)) + (when-let ((id (dom-attr dom 'id))) + (push (cons id (point)) shr--link-targets)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -619,43 +644,11 @@ size, and full-buffer size." (with-temp-buffer (let ((shr-indentation 0) (shr-start nil) - (shr-internal-width (- (window-body-width nil t) - (* 2 (frame-char-width)) - ;; Adjust the window width for when - ;; the user disables the fringes, - ;; which causes the display engine - ;; to usurp one column for the - ;; continuation glyph. - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0)))) + (shr-internal-width (shr--window-width))) (shr-insert text) (shr-fill-lines (point-min) (point-max)) (buffer-string))))) -(define-inline shr-char-breakable-p (char) - "Return non-nil if a line can be broken before and after CHAR." - (inline-quote (aref fill-find-break-point-function-table ,char))) -(define-inline shr-char-nospace-p (char) - "Return non-nil if no space is required before and after CHAR." - (inline-quote (aref fill-nospace-between-words-table ,char))) - -;; KINSOKU is a Japanese word meaning a rule that should not be violated. -;; In Emacs, it is a term used for characters, e.g. punctuation marks, -;; parentheses, and so on, that should not be placed in the beginning -;; of a line or the end of a line. -(define-inline shr-char-kinsoku-bol-p (char) - "Return non-nil if a line ought not to begin with CHAR." - (inline-letevals (char) - (inline-quote (and (not (eq ,char ?')) - (aref (char-category-set ,char) ?>))))) -(define-inline shr-char-kinsoku-eol-p (char) - "Return non-nil if a line ought not to end with CHAR." - (inline-quote (aref (char-category-set ,char) ?<))) -(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) - (load "kinsoku" nil t)) - (defun shr-pixel-column () (if (not shr-use-fonts) (current-column) @@ -669,6 +662,7 @@ size, and full-buffer size." (car (window-text-pixel-size nil (line-beginning-position) (point)))))) (defun shr-pixel-region () + (declare (obsolete nil "29.1")) (- (shr-pixel-column) (save-excursion (goto-char (mark)) @@ -711,7 +705,7 @@ size, and full-buffer size." (goto-char (point-max))))) (t (let ((font-start (point))) - (when (and (string-match "\\`[ \t\n\r]" text) + (when (and (string-match-p "\\`[ \t\n\r]" text) (not (bolp)) (not (eq (char-after (1- (point))) ? ))) (insert " ")) @@ -739,7 +733,7 @@ size, and full-buffer size." (when shr-use-fonts (put-text-property font-start (point) 'face - (or shr-current-font 'variable-pitch))))))))) + (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) (if (<= shr-internal-width 0) @@ -788,7 +782,7 @@ size, and full-buffer size." (while (not (eolp)) ;; We have to do some folding. First find the first ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) + (if (or (not (pixel-fill-find-fill-point (line-beginning-position))) (= (point) start)) ;; We had unbreakable text (for this width), so just go to ;; the first space and carry on. @@ -829,84 +823,6 @@ size, and full-buffer size." (when (looking-at " $") (delete-region (point) (line-end-position))))))) -(defun shr-find-fill-point (start) - (let ((bp (point)) - (end (point)) - failed) - (while (not (or (setq failed (<= (point) start)) - (eq (preceding-char) ? ) - (eq (following-char) ? ) - (shr-char-breakable-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char)))) - (shr-char-kinsoku-eol-p (following-char)) - (bolp))) - (backward-char 1)) - (if failed - ;; There's no breakable point, so we give it up. - (let (found) - (goto-char bp) - ;; Don't overflow the window edge, even if - ;; shr-kinsoku-shorten is nil. - (unless (or shr-kinsoku-shorten (null shr-width)) - (while (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move))) - (if (and found - (not (match-beginning 1))) - (goto-char (match-beginning 0))))) - (or - (eolp) - ;; Don't put kinsoku-bol characters at the beginning of a line, - ;; or kinsoku-eol characters at the end of a line. - (cond - ;; Don't overflow the window edge, even if shr-kinsoku-shorten - ;; is nil. - ((or shr-kinsoku-shorten (null shr-width)) - (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char)))) - (backward-char 1)) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we look for the second best position. - (while (and (progn - (forward-char 1) - (<= (point) end)) - (progn - (setq bp (point)) - (shr-char-kinsoku-eol-p (following-char))))) - (goto-char bp))) - ((shr-char-kinsoku-eol-p (preceding-char)) - ;; Find backward the point where kinsoku-eol characters begin. - (let ((count 4)) - (while - (progn - (backward-char 1) - (and (> (setq count (1- count)) 0) - (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char))))))) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1)))) - ((shr-char-kinsoku-bol-p (following-char)) - ;; Find forward the point where kinsoku-bol characters end. - (let ((count 4)) - (while (progn - (forward-char 1) - (and (>= (setq count (1- count)) 0) - (shr-char-kinsoku-bol-p (following-char)) - (shr-char-breakable-p (following-char)))))))) - (when (eq (following-char) ? ) - (forward-char 1)))) - (not failed))) - (defun shr-parse-base (url) ;; Always chop off anchors. (when (string-match "#.*" url) @@ -941,15 +857,13 @@ size, and full-buffer size." shr-base)) (when (zerop (length url)) (setq url nil)) - ;; Strip leading/trailing whitespace - (and url (string-match "\\`\\s-+" url) - (setq url (substring url (match-end 0)))) - (and url (string-match "\\s-+\\'" url) - (setq url (substring url 0 (match-beginning 0)))) + ;; Strip leading/trailing whitespace. + (when url + (setq url (string-trim url))) (cond ((zerop (length url)) (nth 3 base)) ((or (not base) - (string-match "\\`[a-z]*:" url)) + (string-match-p "\\`[a-z]*:" url)) ;; Absolute or empty URI url) ((eq (aref url 0) ?/) @@ -986,22 +900,6 @@ size, and full-buffer size." (looking-at " *$"))) ;; We're already at a new paragraph; do nothing. ) - ((and (not (bolp)) - (save-excursion - (beginning-of-line) - (looking-at " *$")) - (save-excursion - (forward-line -1) - (looking-at " *$")) - ;; Check all chars on the current line and see whether - ;; they're all placeholders. - (cl-loop for pos from (line-beginning-position) upto (1- (point)) - unless (get-text-property pos 'shr-target-id) - return nil - finally return t)) - ;; We have some invisible markers from <div id="foo"></div>; - ;; do nothing. - ) ((and prefix (= prefix (- (point) (line-beginning-position)))) ;; Do nothing; we're at the start of a <li>. @@ -1134,14 +1032,14 @@ the mouse click event." (let ((param (match-string 4 data)) (payload (url-unhex-string (match-string 5 data)))) (when (and param - (string-match "^.*\\(;[ \t]*base64\\)$" param)) + (string-match-p "^.*\\(;[ \t]*base64\\)$" param)) (setq payload (ignore-errors (base64-decode-string payload)))) payload))) ;; Behind display-graphic-p test. (declare-function image-size "image.c" (spec &optional pixels frame)) -(declare-function image-animate "image" (image &optional index limit)) +(declare-function image-animate "image" (image &optional index limit position)) (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. @@ -1178,13 +1076,14 @@ element is the data blob and the second element is the content-type." (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (if (eq size 'original) - (insert-sliced-image image (or alt "*") nil 20 1) - (insert-image image (or alt "*"))) - (put-text-property start (point) 'image-size size) - (when (and shr-image-animate - (cdr (image-multi-frame-p image))) - (image-animate image nil 60))) + (let ((image-pos (point))) + (if (eq size 'original) + (insert-sliced-image image (or alt "*") nil 20 1) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) + (when (and shr-image-animate + (cdr (image-multi-frame-p image))) + (image-animate image nil 60 image-pos)))) image) (insert (or alt "")))) @@ -1270,7 +1169,7 @@ Return a string with image data." ;; SVG images may contain references to further images that we may ;; want to block. So special-case these by parsing the XML data ;; and remove anything that looks like a blocked bit. - (when (and shr-blocked-images + (when (and (or shr-allowed-images shr-blocked-images) (eq content-type 'image/svg+xml)) (setq data ;; Note that libxml2 doesn't parse everything perfectly, @@ -1449,8 +1348,7 @@ ones, in case fg and bg are nil." ((or (not (eq (dom-tag elem) 'image)) ;; Filter out blocked elements inside the SVG image. (not (setq url (dom-attr elem ':xlink:href))) - (not shr-blocked-images) - (not (string-match shr-blocked-images url))) + (not (shr-image-blocked-p url))) (insert " ") (shr-dom-print elem))))) (insert (format "</%s>" (dom-tag dom)))) @@ -1467,12 +1365,14 @@ ones, in case fg and bg are nil." (defun shr-tag-sup (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise 0.2)))) + (put-text-property start (point) 'display '(raise 0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-sub (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise -0.2)))) + (put-text-property start (point) 'display '(raise -0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-p (dom) (shr-ensure-paragraph) @@ -1534,9 +1434,7 @@ ones, in case fg and bg are nil." (defun shr-parse-style (style) (when style - (save-match-data - (when (string-match "\n" style) - (setq style (replace-match " " t t style)))) + (setq style (replace-regexp-in-string "\n" " " style)) (let ((plist nil)) (dolist (elem (split-string style ";")) (when elem @@ -1565,13 +1463,9 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'. - (dom-attr dom 'name)))) ; Obsolete since HTML5. - ;; We have an empty element, so just insert... something. - (when (= start (point)) - (insert ?\s) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property start (1+ start) 'shr-target-id id)) + (when-let* ((id (and (not (dom-attr dom 'id)) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + (push (cons id (point)) shr--link-targets)) (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) @@ -1594,7 +1488,7 @@ ones, in case fg and bg are nil." (let ((start (point)) url multimedia image) (when-let* ((type (dom-attr dom 'type))) - (when (string-match "\\`image/svg" type) + (when (string-match-p "\\`image/svg" type) (setq url (dom-attr dom 'data) image t))) (dolist (child (dom-non-text-children dom)) @@ -1630,6 +1524,14 @@ url if no type is specified. The value should be a float in the range 0.0 to :version "24.4" :type '(alist :key-type regexp :value-type float)) +(defcustom shr-use-xwidgets-for-media nil + "If non-nil, use xwidgets to display video and audio elements. +This also depends on Emacs being built with xwidgets capability. +Note that this is experimental, and may lead to instability on +some platforms." + :type 'boolean + :version "29.1") + (defun shr--get-media-pref (elem) "Determine the preference for ELEM. The preference is a float determined from `shr-prefer-media-type'." @@ -1666,16 +1568,39 @@ The preference is a float determined from `shr-prefer-media-type'." pref (cdr ret))))))))) (cons url pref)) +(declare-function xwidget-webkit-execute-script "xwidget.c" + (xwidget script &optional callback)) + (defun shr-tag-video (dom) (let ((image (dom-attr dom 'poster)) (url (dom-attr dom 'src)) (start (point))) (unless url (setq url (car (shr--extract-best-source dom)))) - (if (> (length image) 0) - (shr-indirect-call 'img nil image) - (shr-insert " [video] ")) - (shr-urlify start (shr-expand-url url)))) + (if (and shr-use-xwidgets-for-media + (fboundp 'make-xwidget)) + ;; Play the video. + (progn + (require 'xwidget) + (let ((widget (make-xwidget + 'webkit + "Video" + (truncate (* (window-pixel-width) 0.8)) + (truncate (* (window-pixel-width) 0.8 0.75))))) + (insert + (propertize + " [video] " + 'display (list 'xwidget :xwidget widget))) + (xwidget-webkit-execute-script + widget (format "document.body.innerHTML = %S;" + (format + "<style>body { margin: 0px; }</style><div style='background: black; height: 100%%; display: flex; align-items: center; justify-content: center;'><video autoplay loop muted controls style='max-width: 100%%; max-height: 100%%;'><source src=%S type='video/mp4'></source></video></div>" + url))))) + ;; No xwidgets. + (if (> (length image) 0) + (shr-indirect-call 'img nil image) + (shr-insert " [video] ")) + (shr-urlify start (shr-expand-url url))))) (defun shr-tag-audio (dom) (let ((url (dom-attr dom 'src)) @@ -1725,8 +1650,7 @@ The preference is a float determined from `shr-prefer-media-type'." (funcall shr-put-image-function image alt (list :width width :height height))))) ((or shr-inhibit-images - (and shr-blocked-images - (string-match shr-blocked-images url))) + (shr-image-blocked-p url)) (setq shr-start (point)) (shr-insert alt)) ((and (not shr-ignore-cache) @@ -2038,7 +1962,8 @@ BASE is the URL of the HTML being rendered." (setq dom (or (dom-child-by-tag dom 'tbody) dom)) (let* ((shr-inhibit-images t) (shr-table-depth (1+ shr-table-depth)) - (shr-kinsoku-shorten t) + ;; Fill hard in CJK languages. + (pixel-fill-respect-kinsoku nil) ;; Find all suggested widths. (columns (shr-column-specs dom)) ;; Compute how many pixels wide each TD should be. @@ -2532,9 +2457,10 @@ flags that control whether to collect or render objects." (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) (max-width 0) + (shr--link-targets nil) natural-width) (when style - (setq style (and (string-match "color" style) + (setq style (and (string-search "color" style) (shr-parse-style style)))) (when bgcolor (setq style (nconc (list (cons 'background-color bgcolor)) @@ -2573,6 +2499,7 @@ flags that control whether to collect or render objects." (end-of-line) (point))) (goto-char (point-min)) + (shr--set-target-ids shr--link-targets) (list max-width natural-width (count-lines (point-min) (point-max)) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 27acc8a4f32..d2092633d89 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -718,10 +718,9 @@ representing leap seconds." second) minute hour day month year second-fraction datatype time-zone) (let ((time - (apply - #'encode-time (list - (if new-decode-time new-decode-time-second second) - minute hour day month year nil nil time-zone)))) + (encode-time (list + (if new-decode-time new-decode-time-second second) + minute hour day month year nil nil time-zone)))) (if new-decode-time (with-no-warnings (decode-time time nil t)) (decode-time time)))))) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 3c1b032baf6..ed73a86ef03 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -107,7 +107,8 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -191,11 +192,10 @@ It is used for TCP/IP devices." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-adb-file-name-p (filename) - "Check if it's a FILENAME for ADB." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-adb-method))) +(defsubst tramp-adb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for ADB." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) @@ -306,7 +306,7 @@ arguments to pass to the OPERATION." (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (with-parsed-tramp-file-name (expand-file-name directory) nil (copy-tree @@ -415,6 +415,8 @@ Emacs dired can't find files." (defun tramp-adb-ls-output-time-less-p (a b) "Sort \"ls\" output by time, descending." (let (time-a time-b) + ;; Once we can assume Emacs 27 or later, the two calls + ;; (apply #'encode-time X) can be replaced by (encode-time X). (string-match tramp-adb-ls-date-regexp a) (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) @@ -499,7 +501,7 @@ Emacs dired can't find files." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -591,8 +593,7 @@ Emacs dired can't find files." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. @@ -660,7 +661,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -720,8 +721,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file @@ -742,7 +742,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1349,22 +1349,18 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-adb-connection-local-default-shell-variables '((shell-file-name . "/system/bin/sh") (shell-command-switch . "-c")) "Default connection-local shell variables for remote adb connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) 'tramp-adb-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 1b5f42a9912..8a88057d38a 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -54,6 +54,7 @@ ;; * ".ar" - UNIX archiver formats ;; * ".cab", ".CAB" - Microsoft Windows cabinets ;; * ".cpio" - CPIO archives +;; * ".crate" - Cargo (Rust) packages ;; * ".deb" - Debian packages ;; * ".depot" - HP-UX SD depots ;; * ".exe" - Self extracting Microsoft Windows EXE files @@ -141,6 +142,7 @@ "ar" ;; UNIX archiver formats. "cab" "CAB" ;; Microsoft Windows cabinets. "cpio" ;; CPIO archives. + "crate" ;; Cargo (Rust) packages. Not in libarchive testsuite. "deb" ;; Debian packages. Not in libarchive testsuite. "depot" ;; HP-UX SD depot. Not in libarchive testsuite. "exe" ;; Self extracting Microsoft Windows EXE files. @@ -211,7 +213,8 @@ It must be supported by libarchive(3).") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-archive-file-name-handler-alist - '((access-file . tramp-archive-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-archive-handle-access-file) (add-name-to-file . tramp-archive-handle-not-implemented) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. @@ -572,9 +575,8 @@ offered." preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for file archives." (when (tramp-archive-file-name-p newname) - (tramp-error - (tramp-archive-dissect-file-name newname) 'file-error - "Permission denied: %s" newname)) + (tramp-compat-permission-denied + (tramp-archive-dissect-file-name newname) newname)) (copy-file (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)) @@ -618,7 +620,7 @@ offered." (defun tramp-archive-handle-file-system-info (filename) "Like `file-system-info' for file archives." (with-parsed-tramp-archive-file-name filename nil - (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + (list (file-attribute-size (file-attributes archive)) 0 0))) (defun tramp-archive-handle-file-truename (filename) "Like `file-truename' for file archives." @@ -658,7 +660,7 @@ offered." ;; mounted directory, it is returned as it. Not what we want. (with-parsed-tramp-archive-file-name default-directory nil (let ((default-directory (file-name-directory archive))) - (tramp-compat-temporary-file-directory-function)))) + (temporary-file-directory)))) (defun tramp-archive-handle-not-implemented (operation &rest args) "Generic handler for operations not implemented for file archives." diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index fc8f04f5273..715b537247f 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -49,8 +49,6 @@ ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. -;; "lock-pid" is the timestamp a (network) process is created, it is -;; used instead of the pid in file locks. ;; ;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep @@ -101,8 +99,7 @@ details see the info pages." (choice :tag " Value" sexp)))) ;;;###tramp-autoload -(defcustom tramp-persistency-file-name - (expand-file-name (locate-user-emacs-file "tramp")) +(defcustom tramp-persistency-file-name (locate-user-emacs-file "tramp") "File which keeps connection history for Tramp connections." :group 'tramp :type 'file) @@ -225,7 +222,9 @@ Return VALUE." (defun tramp-flush-file-upper-properties (key file) "Remove some properties of FILE's upper directory." (when (file-name-absolute-p file) - (let ((file (directory-file-name (file-name-directory file)))) + ;; `file-name-directory' can return nil, for example for "~". + (when-let ((file (file-name-directory file)) + (file (directory-file-name file))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 43aed625550..c18ab4972d2 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -67,7 +67,7 @@ SYNTAX can be one of the symbols `default' (default), nil (mapcar (lambda (x) - (with-current-buffer x (when (tramp-tramp-file-p default-directory) x))) + (when (tramp-tramp-file-p (tramp-get-default-directory x)) x)) (buffer-list)))) ;;;###tramp-autoload @@ -593,9 +593,8 @@ buffer in your bug report. (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." - (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer)) - (val (with-current-buffer reporter-eval-buffer - (symbol-value varsym)))) + (when-let ((reporter-eval-buffer reporter-eval-buffer) + (val (buffer-local-value varsym reporter-eval-buffer))) (if (hash-table-p val) ;; Pretty print the cache. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index aead1dedd24..0a45b12a04a 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,17 +23,12 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 28. This -;; package provides compatibility functions for Emacs 25, Emacs 26 and -;; Emacs 27. +;; Tramp's main Emacs version for development is Emacs 29. This +;; package provides compatibility functions for Emacs 26, Emacs 27 and +;; Emacs 28. ;;; Code: -;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. -;; So we declare it here in order to avoid recursive load. This will -;; be overwritten in tramp.el. -(defun tramp-unload-file-name-handlers () ".") - (require 'auth-source) (require 'format-spec) (require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. @@ -42,8 +37,6 @@ (require 'subr-x) (declare-function tramp-error "tramp") -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(declare-function tramp-handle-temporary-file-directory "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -83,133 +76,19 @@ Add the extension of F, if existing." tramp-temp-name-prefix tramp-compat-temporary-file-directory) dir-flag (file-name-extension f t))) -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(defalias 'tramp-compat-temporary-file-directory-function - (if (fboundp 'temporary-file-directory) - #'temporary-file-directory - #'tramp-handle-temporary-file-directory)) - -;; `file-attribute-*' are introduced in Emacs 26.1. - -(defalias 'tramp-compat-file-attribute-type - (if (fboundp 'file-attribute-type) - #'file-attribute-type - (lambda (attributes) - "The type field in ATTRIBUTES returned by `file-attributes'. -The value is either t for directory, string (name linked to) for -symbolic link, or nil." - (nth 0 attributes)))) - -(defalias 'tramp-compat-file-attribute-link-number - (if (fboundp 'file-attribute-link-number) - #'file-attribute-link-number - (lambda (attributes) - "Return the number of links in ATTRIBUTES returned by `file-attributes'." - (nth 1 attributes)))) - -(defalias 'tramp-compat-file-attribute-user-id - (if (fboundp 'file-attribute-user-id) - #'file-attribute-user-id - (lambda (attributes) - "The UID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 2 attributes)))) - -(defalias 'tramp-compat-file-attribute-group-id - (if (fboundp 'file-attribute-group-id) - #'file-attribute-group-id - (lambda (attributes) - "The GID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 3 attributes)))) - -(defalias 'tramp-compat-file-attribute-access-time - (if (fboundp 'file-attribute-access-time) - #'file-attribute-access-time - (lambda (attributes) - "The last access time in ATTRIBUTES returned by `file-attributes'. -This a Lisp timestamp in the style of `current-time'." - (nth 4 attributes)))) - -(defalias 'tramp-compat-file-attribute-modification-time - (if (fboundp 'file-attribute-modification-time) - #'file-attribute-modification-time - (lambda (attributes) - "The modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of the last change to the file's contents, and -is a Lisp timestamp in the style of `current-time'." - (nth 5 attributes)))) - -(defalias 'tramp-compat-file-attribute-status-change-time - (if (fboundp 'file-attribute-status-change-time) - #'file-attribute-status-change-time - (lambda (attributes) - "The status modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of last change to the file's attributes: owner -and group, access mode bits, etc., and is a Lisp timestamp in the -style of `current-time'." - (nth 6 attributes)))) - -(defalias 'tramp-compat-file-attribute-size - (if (fboundp 'file-attribute-size) - #'file-attribute-size - (lambda (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -If the size is too large for a fixnum, this is a bignum in Emacs 27 -and later, and is a float in Emacs 26 and earlier." - (nth 7 attributes)))) - -(defalias 'tramp-compat-file-attribute-modes - (if (fboundp 'file-attribute-modes) - #'file-attribute-modes - (lambda (attributes) - "The file modes in ATTRIBUTES returned by `file-attributes'. -This is a string of ten letters or dashes as in ls -l." - (nth 8 attributes)))) - -;; `file-missing' is introduced in Emacs 26.1. -(defconst tramp-file-missing - (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) - "The error symbol for the `file-missing' error.") - -(defsubst tramp-compat-file-missing (vec file) - "Emit the `file-missing' error." - (if (get 'file-missing 'error-conditions) - (tramp-error vec tramp-file-missing file) - (tramp-error vec tramp-file-missing "No such file or directory: %s" file))) - -;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26.1. -(defalias 'tramp-compat-file-local-name - (if (fboundp 'file-local-name) - #'file-local-name - (lambda (name) - "Return the local name component of NAME. -It returns a file name which can be used directly as argument of -`process-file', `start-file-process', or `shell-command'." - (or (file-remote-p name 'localname) name)))) - ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got ;; a second argument in Emacs 27.1. (defalias 'tramp-compat-file-name-quoted-p - (if (and - (fboundp 'file-name-quoted-p) - (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2))) + (if (equal (func-arity #'file-name-quoted-p) '(1 . 2)) #'file-name-quoted-p (lambda (name &optional top) "Whether NAME is quoted with prefix \"/:\". If NAME is a remote file name and TOP is nil, check the local part of NAME." (let ((file-name-handler-alist (unless top file-name-handler-alist))) - (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) + (string-prefix-p "/:" (file-local-name name)))))) (defalias 'tramp-compat-file-name-quote - (if (and - (fboundp 'file-name-quote) - (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2))) + (if (equal (func-arity #'file-name-quote) '(1 . 2)) #'file-name-quote (lambda (name &optional top) "Add the quotation prefix \"/:\" to file NAME. @@ -217,20 +96,17 @@ If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." (let ((file-name-handler-alist (unless top file-name-handler-alist))) (if (tramp-compat-file-name-quoted-p name top) name - (concat - (file-remote-p name) "/:" (tramp-compat-file-local-name name))))))) + (concat (file-remote-p name) "/:" (file-local-name name))))))) (defalias 'tramp-compat-file-name-unquote - (if (and - (fboundp 'file-name-unquote) - (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2))) + (if (equal (func-arity #'file-name-unquote) '(1 . 2)) #'file-name-unquote (lambda (name &optional top) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name and TOP is nil, the local part of NAME is unquoted." (let* ((file-name-handler-alist (unless top file-name-handler-alist)) - (localname (tramp-compat-file-local-name name))) + (localname (file-local-name name))) (when (tramp-compat-file-name-quoted-p localname top) (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) @@ -288,8 +164,7 @@ A nil value for either argument stands for the current time." ;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. (defalias 'tramp-compat-progress-reporter-update - (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update) - '(1 . 3)) + (if (equal (func-arity #'progress-reporter-update) '(1 . 3)) #'progress-reporter-update (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) @@ -306,19 +181,19 @@ CONDITION can also be a list of error conditions." ;; `file-modes', `set-file-modes' and `set-file-times' got argument ;; FLAG in Emacs 28.1. (defalias 'tramp-compat-file-modes - (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) + (if (equal (func-arity #'file-modes) '(1 . 2)) #'file-modes (lambda (filename &optional _flag) (file-modes filename)))) (defalias 'tramp-compat-set-file-modes - (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) + (if (equal (func-arity #'set-file-modes) '(2 . 3)) #'set-file-modes (lambda (filename mode &optional _flag) (set-file-modes filename mode)))) (defalias 'tramp-compat-set-file-times - (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) + (if (equal (func-arity #'set-file-times) '(1 . 3)) #'set-file-times (lambda (filename &optional timestamp _flag) (set-file-times filename timestamp)))) @@ -326,14 +201,13 @@ CONDITION can also be a list of error conditions." ;; `directory-files' and `directory-files-and-attributes' got argument ;; COUNT in Emacs 28.1. (defalias 'tramp-compat-directory-files - (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5)) + (if (equal (func-arity #'directory-files) '(1 . 5)) #'directory-files (lambda (directory &optional full match nosort _count) (directory-files directory full match nosort)))) (defalias 'tramp-compat-directory-files-and-attributes - (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes) - '(1 . 6)) + (if (equal (func-arity #'directory-files-and-attributes) '(1 . 6)) #'directory-files-and-attributes (lambda (directory &optional full match nosort id-format _count) (directory-files-and-attributes directory full match nosort id-format)))) @@ -398,6 +272,17 @@ CONDITION can also be a list of error conditions." (car components)) (cdr components))))))) +;; `permission-denied' is introduced in Emacs 29.1. +(defconst tramp-permission-denied + (if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error) + "The error symbol for the `permission-denied' error.") + +(defsubst tramp-compat-permission-denied (vec file) + "Emit the `permission-denied' error." + (if (get 'permission-denied 'error-conditions) + (tramp-error vec tramp-permission-denied file) + (tramp-error vec tramp-permission-denied "Permission denied: %s" file))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) @@ -410,8 +295,6 @@ CONDITION can also be a list of error conditions." ;;; TODO: ;; -;; * `func-arity' exists since Emacs 26.1. -;; ;; * Starting with Emacs 27.1, there's no need to escape open ;; parentheses with a backslash in docstrings anymore. ;; diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 23b668473f9..36443e09830 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -157,7 +157,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-crypt-file-name-handler-alist - '((access-file . tramp-crypt-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-crypt-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -294,8 +295,8 @@ arguments to pass to the OPERATION." (defun tramp-crypt-config-file-name (vec) "Return the encfs config file name for VEC." (expand-file-name - (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config) - user-emacs-directory)) + (locate-user-emacs-file + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config)))) (defun tramp-crypt-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -322,7 +323,7 @@ connection if a previous connection has died for some reason." tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) (local-config (tramp-crypt-config-file-name vec))) ;; There is no local encfs6 config file. - (when (not (file-exists-p local-config)) + (unless (file-exists-p local-config) (if (and tramp-crypt-save-encfs-config-remote (file-exists-p remote-config)) ;; Copy remote encfs6 config file if possible. @@ -485,6 +486,7 @@ See `tramp-crypt-do-encrypt-or-decrypt-file'." Files in that directory and all subdirectories will be encrypted before copying to, and decrypted after copying from that directory. File names will be also encrypted." + ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) @@ -596,7 +598,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -698,7 +700,7 @@ absolute file names." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let* (tramp-crypt-enabled diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 650e839f823..ff8caa570ca 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -175,11 +175,10 @@ pass to the OPERATION." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-ftp-file-name-p (filename) - "Check if it's a FILENAME that should be forwarded to Ange-FTP." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method))) +(defsubst tramp-ftp-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-ftp-method))) ;;;###tramp-autoload (tramp--with-startup diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 17d419f853b..2a73d5aa02b 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -48,7 +48,7 @@ (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (with-parsed-tramp-file-name directory nil @@ -107,12 +107,6 @@ (unless (string-match-p elt item) (throw 'match nil))) (setq result (cons (concat item "/") result)))))))))) -(defun tramp-fuse-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-readable-p" - (file-readable-p (tramp-fuse-local-file-name filename))))) - ;; This function isn't used. (defun tramp-fuse-handle-insert-directory (filename switches &optional wildcard full-directory-p) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 0bba894cdbb..221ee547a2b 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -122,10 +122,7 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (or ;; Until Emacs 25, `process-attributes' could crash Emacs - ;; for some processes. Better we don't check. - (<= emacs-major-version 25) - (tramp-process-running-p "gvfs-fuse-daemon") + (or (tramp-process-running-p "gvfs-fuse-daemon") (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") @@ -471,8 +468,7 @@ It has been changed in GVFS 1.14.") ;; </method> ;; </interface> -;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for GNOME Online Accounts. (cl-defstruct (tramp-goa-account (:type list) :named) method user host port) ;;;###tramp-autoload @@ -672,8 +668,7 @@ It has been changed in GVFS 1.14.") ;; STRING key (always-call-mount, is-removable, ...) ;; VARIANT value (boolean?) -;; The basic structure for media devices. We use a list :type, in -;; order to be compatible with Emacs 25. +;; The basic structure for media devices. (cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We @@ -749,7 +744,8 @@ It has been changed in GVFS 1.14.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -834,12 +830,11 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-gvfs-file-name-p (filename) - "Check if it's a FILENAME handled by the GVFS daemon." - (and (tramp-tramp-file-p filename) - (let ((method - (tramp-file-name-method (tramp-dissect-file-name filename)))) - (and (stringp method) (member method tramp-gvfs-methods))))) +(defsubst tramp-gvfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (let ((method (tramp-file-name-method vec))) + (and (stringp method) (member method tramp-gvfs-methods))))) ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) @@ -1002,7 +997,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1102,8 +1097,7 @@ file names." (tramp-skeleton-delete-directory directory recursive trash (if (and recursive (not (file-symlink-p directory))) (mapc (lambda (file) - (if (eq t (tramp-compat-file-attribute-type - (file-attributes file))) + (if (eq t (file-attribute-type (file-attributes file))) (delete-directory file recursive) (delete-file file))) (directory-files @@ -1155,15 +1149,12 @@ file names." (make-tramp-file-name :method method :user user :domain domain :host host :port port :localname "/" :hop hop))) - (setq localname - (replace-match - (tramp-get-connection-property v "default-location" "~") - nil t localname 1))) - ;; Tilde expansion is not possible. - (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (tramp-error - v 'file-error - "Cannot expand tilde in file `%s'" name)) + (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)))) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". @@ -1178,10 +1169,12 @@ file names." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (tramp-run-real-handler #'expand-file-name (list localname)))))) + v (if (string-match-p "\\`~" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." @@ -1463,7 +1456,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." `file-notify' events." (let* ((events (process-get proc 'events)) (rest-string (process-get proc 'rest-string)) - (dd (with-current-buffer (process-buffer proc) default-directory)) + (dd (tramp-get-default-directory (process-buffer proc))) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) @@ -1528,11 +1521,13 @@ If FILE-SYSTEM is non-nil, return file system attributes." (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) - (when (or size used free) - (list (string-to-number (or size "0")) - (string-to-number (or free "0")) - (- (string-to-number (or size "0")) - (string-to-number (or used "0")))))))) + (when (or size free) + (list (and size (string-to-number size)) + (and free (string-to-number free)) + ;; "mtp" connections do not return "filesystem::used". + (or (and size used + (- (string-to-number size) (string-to-number used))) + (and free (string-to-number free)))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1602,7 +1597,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." "%s" (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) - (current-time) + nil time))))) (defun tramp-gvfs-handle-get-remote-uid (vec id-format) @@ -1614,9 +1609,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (tramp-get-connection-property vec "default-location" nil)))) - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))))) + (file-attribute-user-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) (defun tramp-gvfs-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. @@ -1625,9 +1619,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (tramp-get-connection-property vec "default-location" nil)))) - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format)))) + (file-attribute-group-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1865,9 +1858,9 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and host (tramp-file-name-host v) port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) - (let ((v (make-tramp-file-name - :method method :user user :domain domain - :host host :port port))) + (let ((v (make-tramp-file-name + :method method :user user :domain domain + :host host :port port))) (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) @@ -2134,9 +2127,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index b5df9804ab4..03a2c2457a2 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -85,13 +85,6 @@ special handling of `substitute-in-file-name'." "An overlay covering the shadowed part of the filename." (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) -;; Package rfn-eshadow is preloaded in Emacs, but for some reason, -;; it only did (defvar rfn-eshadow-overlay) without giving it a global -;; value, so it was only declared as dynamically-scoped within the -;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need -;; this defvar here for older releases. -(defvar rfn-eshadow-overlay) - (defun tramp-rfn-eshadow-update-overlay () "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. This is intended to be used as a minibuffer `post-command-hook' for @@ -281,22 +274,18 @@ NAME must be equal to `tramp-current-connection'." (remove-hook 'compilation-start-hook #'tramp-compile-disable-ssh-controlmaster-options)))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-connection-local-default-system-variables '((path-separator . ":") (null-device . "/dev/null")) "Default connection-local system variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-system-profile tramp-connection-local-default-system-variables) -(tramp-compat-funcall - 'connection-local-set-profiles +(connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-system-profile) @@ -305,14 +294,12 @@ NAME must be equal to `tramp-current-connection'." (shell-command-switch . "-c")) "Default connection-local shell variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-shell-profile tramp-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 20e983c77d1..259e85a04a3 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-rclone-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -110,7 +111,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fuse-handle-file-readable-p) + (file-readable-p . tramp-rclone-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) @@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-rclone-file-name-p (filename) - "Check if it's a FILENAME for rclone." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-rclone-method))) +(defsubst tramp-rclone-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for rclone." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-rclone-method))) ;;;###tramp-autoload (defun tramp-rclone-file-name-handler (operation &rest args) @@ -223,7 +223,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -280,6 +280,12 @@ file names." (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) +(defun tramp-rclone-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-readable-p" + (file-readable-p (tramp-fuse-local-file-name filename))))) + (defun tramp-rclone-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors @@ -362,10 +368,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property - p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index b3694a6a8d8..72b1ebb3e06 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -34,6 +34,8 @@ (eval-when-compile (require 'cl-lib)) (require 'tramp) +;; `dired-*' declarations can be removed, starting with Emacs 29.1. +(declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) (defvar process-file-return-signal-string) @@ -940,7 +942,8 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) @@ -952,6 +955,8 @@ Format specifiers \"%s\" are replaced before the script is used.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-sh-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' performed by + ;; default handler. (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sh-handle-exec-path) @@ -1334,7 +1339,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (or (tramp-compat-file-attribute-modification-time attr) + (modtime (or (file-attribute-modification-time attr) tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) @@ -1372,7 +1377,7 @@ of." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -1424,7 +1429,7 @@ of." (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) - (current-time) + nil time))) (tramp-send-command-and-check v (format @@ -1620,14 +1625,14 @@ ID-FORMAT valid values are `string' and `integer'." ;; information would be lost by an (attempted) delete and create. (or (null attributes) (and - (= (tramp-compat-file-attribute-user-id attributes) + (= (file-attribute-user-id attributes) (tramp-get-remote-uid v 'integer)) (or (not group) ;; On BSD-derived systems files always inherit the ;; parent directory's group, so skip the group-gid ;; test. (tramp-check-remote-uname v "BSD\\|DragonFly\\|Darwin") - (= (tramp-compat-file-attribute-group-id attributes) + (= (file-attribute-group-id attributes) (tramp-get-remote-gid v 'integer))))))))) ;; Directory listings. @@ -1637,8 +1642,7 @@ ID-FORMAT valid values are `string' and `integer'." "Like `directory-files-and-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) (unless (file-exists-p directory) - (tramp-compat-file-missing - (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (expand-file-name directory)) (let* ((temp @@ -1858,7 +1862,7 @@ ID-FORMAT valid values are `string' and `integer'." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -1952,7 +1956,7 @@ file names." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (length (tramp-compat-file-attribute-size + (length (file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes (file-extended-attributes filename))) @@ -1960,7 +1964,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -2052,7 +2056,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." ;; Check, whether file is too large. Emacs checks in `insert-file-1' ;; and `find-file-noselect', but that's not called here. (abort-if-file-too-large - (tramp-compat-file-attribute-size (file-attributes (file-truename filename))) + (file-attribute-size (file-attributes (file-truename filename))) (symbol-name op) filename) ;; We must disable multibyte, because binary data shall not be ;; converted. We don't want the target file to be compressed, so we @@ -2074,8 +2078,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) @@ -2094,7 +2097,7 @@ as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep the uid and gid from FILENAME." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename))) (with-parsed-tramp-file-name (if t1 filename newname) nil @@ -2419,8 +2422,7 @@ The method used must be an out-of-band method." (when (and keep-date (not copy-keep-date)) (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -2476,42 +2478,58 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-dired-compress-file (file) "Like `dired-compress-file' for Tramp files." - ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil - (tramp-flush-file-properties v localname) - (let ((suffixes dired-compress-file-suffixes) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match-p (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-tramp-progress-reporter - v 0 (format "Uncompressing %s" file) - (when (tramp-send-command-and-check - v (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-tramp-progress-reporter v 0 (format "Compressing %s" file) - (when (tramp-send-command-and-check - v (concat "gzip -f " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil))))))))) + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. + (if (>= emacs-major-version 29) + (tramp-run-real-handler #'dired-compress-file (list file)) + ;; Code stolen mainly from dired-aux.el. + (with-parsed-tramp-file-name file nil + (tramp-flush-file-properties v localname) + (let ((suffixes dired-compress-file-suffixes) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match-p (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-tramp-progress-reporter + v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (if (string-match-p "%[io]" (nth 2 suffix)) + (replace-regexp-in-string + "%i" (tramp-shell-quote-argument localname) + (nth 2 suffix)) + (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname)))) + (unless (string-match-p "\\.tar\\.gz" file) + (dired-remove-file file)) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so + ;; compress it. Try gzip. + (with-tramp-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (if (file-directory-p file) + (format "tar -cf - %s | gzip -c9 > %s.tar.gz" + (tramp-shell-quote-argument + (file-name-nondirectory localname)) + (tramp-shell-quote-argument localname)) + (concat "gzip -f " + (tramp-shell-quote-argument localname)))) + (unless (file-directory-p file) + (dired-remove-file file)) + (catch 'found nil + (dolist (target (mapcar (lambda (suffix) + (concat file suffix)) + '(".tar.gz" ".gz" ".z"))) + (when (file-exists-p target) + (throw 'found target)))))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -2583,7 +2601,7 @@ The method used must be an out-of-band method." ;; We cannot use `insert-buffer-substring' because the Tramp ;; buffer changes its contents before insertion due to calling ;; `expand-file-name' and alike. - (insert (with-current-buffer (tramp-get-buffer v) (buffer-string))) + (insert (tramp-get-buffer-string (tramp-get-buffer v))) ;; We must enable unibyte strings, because the "--dired" ;; output counts in bytes. @@ -2693,11 +2711,11 @@ the result will be a local, non-Tramp, file name." ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) - ;; If connection is not established yet, run the real handler. - (if (not (tramp-connectable-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + ;; If connection is not established yet, run the real handler. + (if (not (tramp-connectable-p v)) + (tramp-run-real-handler #'expand-file-name (list name nil)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "~/" localname))) ;; Tilde expansion if necessary. This needs a shell which @@ -3142,8 +3160,7 @@ implementation will be used." (when outbuf (with-current-buffer outbuf (insert - (with-current-buffer (tramp-get-connection-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-connection-buffer v)))) (when (and display (get-buffer-window outbuf t)) (redisplay)))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. @@ -3187,9 +3204,9 @@ implementation will be used." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) - (let* ((size (tramp-compat-file-attribute-size + (let* ((size (file-attribute-size (file-attributes (file-truename filename)))) (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) (loc-dec (tramp-get-inline-coding v "local-decoding" size)) @@ -3276,11 +3293,9 @@ implementation will be used." (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -3359,8 +3374,7 @@ implementation will be used." ;; specified. However, if the method _also_ specifies an ;; encoding function, then that is used for encoding the ;; contents of the tmp file. - (let* ((size (tramp-compat-file-attribute-size - (file-attributes tmpfile))) + (let* ((size (file-attribute-size (file-attributes tmpfile))) (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) (loc-enc (tramp-get-inline-coding v "local-encoding" size))) (cond @@ -3460,8 +3474,7 @@ implementation will be used." (not (string-equal (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-buffer v)))) (tramp-error v 'file-error (concat "Couldn't write region to `%s'," @@ -3495,10 +3508,10 @@ implementation will be used." ;; We must pass modtime explicitly, because FILENAME can ;; be different from (buffer-file-name), f.e. if ;; `file-precious-flag' is set. - (or (tramp-compat-file-attribute-modification-time file-attr) + (or (file-attribute-modification-time file-attr) (current-time))) - (when (and (= (tramp-compat-file-attribute-user-id file-attr) uid) - (= (tramp-compat-file-attribute-group-id file-attr) gid)) + (when (and (= (file-attribute-user-id file-attr) uid) + (= (file-attribute-group-id file-attr) gid)) (setq need-chown nil)))) ;; Set the ownership. @@ -3755,8 +3768,7 @@ Fall back to normal file name handler if no Tramp handler exists." "Read output from \"gio monitor\" and add corresponding `file-notify' events." (let ((events (process-get proc 'events)) (remote-prefix - (with-current-buffer (process-buffer proc) - (file-remote-p default-directory))) + (file-remote-p (tramp-get-default-directory (process-buffer proc)))) (rest-string (process-get proc 'rest-string)) pos) (when rest-string @@ -6011,5 +6023,8 @@ function cell is returned to be applied on a buffer." ;; be to stipulate, as a directory or connection-local variable, an ;; additional rc file on the remote machine that is sourced every ;; time Tramp connects. <https://emacs.stackexchange.com/questions/62306> +;; +;; * Support hostname canonicalization in ~/.ssh/config. +;; <https://stackoverflow.com/questions/70205232/> ;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 3960554605d..c5f423fa3f0 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -222,7 +222,8 @@ See `tramp-actions-before-shell' for more info.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) @@ -330,11 +331,10 @@ This can be used to disable echo etc." ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-smb-file-name-p (filename) - "Check if it's a FILENAME for SMB servers." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method))) +(defsubst tramp-smb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SMB servers." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -419,7 +419,7 @@ arguments to pass to the OPERATION." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -442,7 +442,7 @@ arguments to pass to the OPERATION." (with-tramp-progress-reporter v 0 (format "Copying %s to %s" dirname newname) (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) (when (and (file-directory-p newname) (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) @@ -567,8 +567,7 @@ arguments to pass to the OPERATION." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes dirname)) + (file-attribute-modification-time (file-attributes dirname)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -602,10 +601,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (copy-directory filename newname keep-date 'parents 'copy-contents) (unless (file-exists-p filename) - (tramp-compat-file-missing + (tramp-error (tramp-dissect-file-name (if (tramp-tramp-file-p filename) filename newname)) - filename)) + 'file-missing filename)) (if-let ((tmpfile (file-local-copy filename))) ;; Remote filename. @@ -645,8 +644,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive trash) @@ -706,7 +704,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (let ((result (mapcar #'directory-file-name (file-name-all-completions "" directory)))) ;; Discriminate with regexp. @@ -976,7 +974,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -1041,8 +1039,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) (tramp-compat-string-search - "w" - (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) + "w" (or (file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) (and (file-exists-p dir) (file-writable-p dir))))) @@ -1145,11 +1142,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (insert (format "%10s %3d %-8s %-8s %8s %s " - (or (tramp-compat-file-attribute-modes attr) (nth 1 x)) - (or (tramp-compat-file-attribute-link-number attr) 1) - (or (tramp-compat-file-attribute-user-id attr) "nobody") - (or (tramp-compat-file-attribute-group-id attr) "nogroup") - (or (tramp-compat-file-attribute-size attr) (nth 2 x)) + (or (file-attribute-modes attr) (nth 1 x)) + (or (file-attribute-link-number attr) 1) + (or (file-attribute-user-id attr) "nobody") + (or (file-attribute-group-id attr) "nogroup") + (or (file-attribute-size attr) (nth 2 x)) (format-time-string (if (time-less-p ;; Half a year. @@ -1171,8 +1168,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Insert symlink. (when (and (tramp-compat-string-search "l" switches) - (stringp (tramp-compat-file-attribute-type attr))) - (insert " -> " (tramp-compat-file-attribute-type attr)))) + (stringp (file-attribute-type attr))) + (insert " -> " (file-attribute-type attr)))) (insert "\n") (beginning-of-line))) @@ -1394,7 +1391,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (if (tramp-tramp-file-p filename) filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -1439,9 +1436,9 @@ component is used as the target of the symlink." (unless (process-live-p proc) ;; Accept pending output. (while (tramp-accept-process-output proc)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 10 "\n%s" (buffer-string)) - (throw 'tramp-action 'ok)))) + (tramp-message + vec 10 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) + (throw 'tramp-action 'ok))) (defun tramp-smb-handle-set-file-acl (filename acl-string) "Like `set-file-acl' for Tramp files." @@ -1647,8 +1644,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 7be26bd23df..0a5bf2f43b3 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sshfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) @@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-sshfs-file-name-p (filename) - "Check if it's a FILENAME for sshfs." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sshfs-method))) +(defsubst tramp-sshfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for sshfs." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sshfs-method))) ;;;###tramp-autoload (defun tramp-sshfs-file-name-handler (operation &rest args) @@ -345,9 +345,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index c4222b28a20..a68d4b3e365 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -63,7 +63,8 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defconst tramp-sudoedit-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) (byte-compiler-base-file-name . ignore) (copy-directory . tramp-handle-copy-directory) @@ -148,11 +149,10 @@ See `tramp-actions-before-shell' for more info.") ;; It must be a `defsubst' in order to push the whole code into ;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. ;;;###tramp-autoload -(defsubst tramp-sudoedit-file-name-p (filename) - "Check if it's a FILENAME for SUDOEDIT." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sudoedit-method))) +(defsubst tramp-sudoedit-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SUDOEDIT." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sudoedit-method))) ;;;###tramp-autoload (defun tramp-sudoedit-file-name-handler (operation &rest args) @@ -233,7 +233,7 @@ absolute file names." (let ((t1 (tramp-sudoedit-file-name-p filename)) (t2 (tramp-sudoedit-file-name-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename)) (attributes (and preserve-extended-attributes @@ -247,7 +247,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) @@ -336,7 +336,7 @@ absolute file names." (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) (unless (tramp-sudoedit-send-command - v "rm" (tramp-compat-file-name-unquote localname)) + v "rm" "-f" (tramp-compat-file-name-unquote localname)) ;; Propagate the error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -453,12 +453,13 @@ the result will be a local, non-Tramp, file name." (if (file-directory-p (expand-file-name f directory)) (file-name-as-directory f) f)) - (with-current-buffer (tramp-get-connection-buffer v) - (delq - nil - (mapcar - (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n" 'omit))))))))) + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string + (tramp-get-buffer-string (tramp-get-connection-buffer v)) + "\n" 'omit)))))))) (defun tramp-sudoedit-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -534,7 +535,7 @@ the result will be a local, non-Tramp, file name." (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) - (current-time) + nil time))) (tramp-sudoedit-send-command v "env" "TZ=UTC" "touch" "-t" @@ -721,11 +722,9 @@ ID-FORMAT valid values are `string' and `integer'." "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (let* ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (let* ((uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer))) (flag (and (eq mustbenew 'excl) 'nofollow)) (modes (tramp-default-file-modes filename flag)) @@ -736,10 +735,10 @@ ID-FORMAT valid values are `string' and `integer'." ;; Set the ownership, modes and extended attributes. This is ;; not performed in `tramp-handle-write-region'. - (unless (and (= (tramp-compat-file-attribute-user-id + (unless (and (= (file-attribute-user-id (file-attributes filename 'integer)) uid) - (= (tramp-compat-file-attribute-group-id + (= (file-attribute-group-id (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) @@ -789,9 +788,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index ee6e0e6c088..adde443fdd6 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -751,11 +751,11 @@ The answer will be provided by `tramp-action-process-alive', (defconst tramp-temp-name-prefix "tramp." "Prefix to use for temporary files. -If this is a relative file name (such as \"tramp.\"), it is considered -relative to the directory name returned by the function -`tramp-compat-temporary-file-directory' (which see). It may also be an -absolute file name; don't forget to include a prefix for the filename -part, though.") +If this is a relative file name (such as \"tramp.\"), it is +considered relative to the directory name returned by the +function `temporary-file-directory' (which see). It may also be +an absolute file name; don't forget to include a prefix for the +filename part, though.") (defconst tramp-temp-buffer-name " *tramp temp*" "Buffer name for a temporary buffer. @@ -822,11 +822,10 @@ to be set, depending on VALUE." (tramp-register-file-name-handlers)) ;; Initialize the Tramp syntax variables. We want to override initial -;; value of `tramp-file-name-regexp'. Other Tramp syntax variables -;; must be initialized as well to proper values. We do not call +;; value of `tramp-file-name-regexp'. We do not call ;; `custom-set-variable', this would load Tramp via custom.el. (tramp--with-startup - (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) + (tramp-set-syntax 'tramp-syntax tramp-syntax)) (defun tramp-syntax-values () "Return possible values of `tramp-syntax', a list." @@ -836,9 +835,9 @@ to be set, depending on VALUE." values)) (defun tramp-lookup-syntax (alist) - "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax'. -Raise an error if `tramp-syntax' is invalid." - (or (cdr (assq (tramp-compat-tramp-syntax) alist)) + "Look up a syntax string in ALIST according to `tramp-syntax'. +Raise an error if it is invalid." + (or (cdr (assq tramp-syntax alist)) (error "Wrong `tramp-syntax' %s" tramp-syntax))) (defconst tramp-prefix-format-alist @@ -1409,8 +1408,7 @@ calling HANDLER.") ;; internal data structure. Convenience functions for internal ;; data structure. -;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for remote file names. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1522,7 +1520,7 @@ of `process-file', `start-file-process', or `shell-command'." (or (and (tramp-tramp-file-p name) (string-match (nth 0 tramp-file-name-structure) name) (match-string (nth 4 tramp-file-name-structure) name)) - (tramp-compat-file-local-name name))) + (file-local-name name))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-unquote-file-local-name (name) @@ -1669,6 +1667,18 @@ default values are used." (put #'tramp-dissect-file-name 'tramp-suppress-trace t) +(defun tramp-ensure-dissected-file-name (vec-or-filename) + "Return a `tramp-file-name' structure for VEC-OR-FILENAME. + +VEC-OR-FILENAME may be either a string or a `tramp-file-name'. +If it's not a Tramp filename, return nil." + (cond + ((tramp-file-name-p vec-or-filename) vec-or-filename) + ((tramp-tramp-file-p vec-or-filename) + (tramp-dissect-file-name vec-or-filename)))) + +(put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t) + (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." @@ -1839,9 +1849,7 @@ from the default one." If connection-local variables are not supported by this Emacs version, the function does nothing." (with-current-buffer (tramp-get-connection-buffer vec) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(tramp-file-name-method vec) :user ,(tramp-file-name-user-domain vec) @@ -1852,14 +1860,27 @@ version, the function does nothing." If connection-local variables are not supported by this Emacs version, the function does nothing." (when (tramp-tramp-file-p default-directory) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(file-remote-p default-directory 'method) :user ,(file-remote-p default-directory 'user) :machine ,(file-remote-p default-directory 'host))))) +(defsubst tramp-get-default-directory (buffer) + "Return `default-directory' of BUFFER." + (buffer-local-value 'default-directory buffer)) + +(put #'tramp-get-default-directory 'tramp-suppress-trace t) + +(defsubst tramp-get-buffer-string (&optional buffer) + "Return contents of BUFFER. +If BUFFER is not a buffer or a buffer name, return the contents +of `current-buffer'." + (with-current-buffer (or buffer (current-buffer)) + (substring-no-properties (buffer-string)))) + +(put #'tramp-get-buffer-string 'tramp-suppress-trace t) + (defun tramp-debug-buffer-name (vec) "A name for the debug buffer for VEC." (let ((method (tramp-file-name-method vec)) @@ -1898,29 +1919,55 @@ The outline level is equal to the verbosity of the Tramp message." (put #'tramp-debug-outline-level 'tramp-suppress-trace t) +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-debug-buffer-command-completion-p (_symbol buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only in Tramp debug buffers." + (with-current-buffer buffer + (string-equal (buffer-substring 1 10) ";; Emacs:"))) + +(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) + +(defun tramp-setup-debug-buffer () + "Function to setup debug buffers." + ;; (declare (completion tramp-debug-buffer-command-completion-p)) + (interactive) + (set-buffer-file-coding-system 'utf-8) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes die. + ;; Yes: I've seen `flyspell-mode', which starts "ispell". + ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises + ;; on error in `(outline-mode)', we don't want to see it in the + ;; traces. + (let ((default-directory tramp-compat-temporary-file-directory)) + (outline-mode)) + (setq-local outline-level 'tramp-debug-outline-level) + (setq-local font-lock-keywords + ;; FIXME: This `(t FOO . BAR)' representation in + ;; `font-lock-keywords' is supposed to be an internal + ;; implementation "detail". Don't abuse it here! + `(t (eval ,tramp-debug-font-lock-keywords t) + ,(eval tramp-debug-font-lock-keywords t))) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map) + ;; For debugging purposes. + (local-set-key "\M-n" 'clone-buffer) + (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) + +(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) + +(function-put + #'tramp-setup-debug-buffer 'completion-predicate + #'tramp-debug-buffer-command-completion-p) + (defun tramp-get-debug-buffer (vec) "Get the debug buffer for VEC." (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) - (set-buffer-file-coding-system 'utf-8) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes - ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". - ;; `(custom-declare-variable outline-minor-mode-prefix ...)' - ;; raises on error in `(outline-mode)', we don't want to see it - ;; in the traces. - (let ((default-directory tramp-compat-temporary-file-directory)) - (outline-mode)) - (setq-local outline-level 'tramp-debug-outline-level) - (setq-local font-lock-keywords - ;; FIXME: This `(t FOO . BAR)' representation in - ;; `font-lock-keywords' is supposed to be an - ;; internal implementation "detail". Don't abuse it here! - `(t (eval ,tramp-debug-font-lock-keywords t) - ,(eval tramp-debug-font-lock-keywords t))) - ;; Do not edit the debug buffer. - (use-local-map special-mode-map)) + (tramp-setup-debug-buffer)) (current-buffer))) (put #'tramp-get-debug-buffer 'tramp-suppress-trace t) @@ -1982,9 +2029,7 @@ ARGUMENTS to actually emit the message (if applicable)." (unless (bolp) (insert "\n")) ;; Timestamp. - (let ((now (current-time))) - (insert (format-time-string "%T." now)) - (insert (format "%06d " (nth 2 now)))) + (insert (format-time-string "%T.%6N ")) ;; Calling Tramp function. We suppress compat and trace ;; functions from being displayed. (let ((btn 1) btf fn) @@ -2054,12 +2099,15 @@ applicable)." ;; Append connection buffer for error messages, if exists. (when (= level 1) (ignore-errors - (with-current-buffer - (if (processp vec-or-proc) - (process-buffer vec-or-proc) - (tramp-get-connection-buffer vec-or-proc 'dont-create)) - (setq fmt-string (concat fmt-string "\n%s") - arguments (append arguments (list (buffer-string))))))) + (setq fmt-string (concat fmt-string "\n%s") + arguments + (append + arguments + `(,(tramp-get-buffer-string + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer + vec-or-proc 'dont-create)))))))) ;; Translate proc to vec. (when (processp vec-or-proc) (setq vec-or-proc (process-get vec-or-proc 'vector)))) @@ -2121,8 +2169,8 @@ an input event arrives. The other arguments are passed to `tramp-error'." (and (tramp-file-name-p vec-or-proc) (tramp-get-connection-buffer vec-or-proc)))) (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc) - (and buf (with-current-buffer buf - (tramp-dissect-file-name default-directory)))))) + (and buf (tramp-dissect-file-name + (tramp-get-default-directory buf)))))) (unwind-protect (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. @@ -2186,10 +2234,14 @@ the resulting error message." (defun tramp-test-message (fmt-string &rest arguments) "Emit a Tramp message according `default-directory'." - (if (tramp-tramp-file-p default-directory) - (apply #'tramp-message - (tramp-dissect-file-name default-directory) 0 fmt-string arguments) - (apply #'message fmt-string arguments))) + (cond + ((tramp-tramp-file-p default-directory) + (apply #'tramp-message + (tramp-dissect-file-name default-directory) 0 fmt-string arguments)) + ((tramp-file-name-p (car tramp-current-connection)) + (apply #'tramp-message + (car tramp-current-connection) 0 fmt-string arguments)) + (t (apply #'message fmt-string arguments)))) (put #'tramp-test-message 'tramp-suppress-trace t) @@ -2476,19 +2528,17 @@ Must be handled by the callers." file-accessible-directory-p file-attributes file-directory-p file-executable-p file-exists-p file-local-copy file-modes file-name-as-directory - file-name-directory file-name-nondirectory - file-name-sans-versions file-notify-add-watch - file-ownership-preserved-p file-readable-p - file-regular-p file-remote-p file-selinux-context - file-symlink-p file-truename file-writable-p - find-backup-file-name get-file-buffer + file-name-case-insensitive-p file-name-directory + file-name-nondirectory file-name-sans-versions + file-notify-add-watch file-ownership-preserved-p + file-readable-p file-regular-p file-remote-p + file-selinux-context file-symlink-p file-truename + file-writable-p find-backup-file-name get-file-buffer insert-directory insert-file-contents load make-directory make-directory-internal set-file-acl set-file-modes set-file-selinux-context set-file-times substitute-in-file-name unhandled-file-name-directory vc-registered - ;; Emacs 26+ only. - file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. @@ -2501,8 +2551,6 @@ Must be handled by the callers." (nth 0 args) default-directory)) ;; STRING FILE. - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. ((eq operation 'make-symbolic-link) (nth 1 args)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation @@ -2533,17 +2581,15 @@ Must be handled by the callers." (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) ;; COMMAND. ((member operation - '(process-file shell-command start-file-process - ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory + '(make-nearby-temp-file process-file shell-command + start-file-process temporary-file-directory ;; Emacs 27+ only. exec-path make-process)) default-directory) ;; PROC. ((member operation '(file-notify-rm-watch file-notify-valid-p)) (when (processp (nth 0 args)) - (with-current-buffer (process-buffer (nth 0 args)) - default-directory))) + (tramp-get-default-directory (process-buffer (nth 0 args))))) ;; VEC. ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) (tramp-make-tramp-file-name (nth 0 args))) @@ -2554,11 +2600,21 @@ Must be handled by the callers." "Return foreign file name handler if exists." (when (tramp-tramp-file-p filename) (let ((handler tramp-foreign-file-name-handler-alist) - elt res) + (vec (tramp-dissect-file-name filename)) + elt func res) (while handler (setq elt (car handler) handler (cdr handler)) - (when (funcall (car elt) filename) + ;; Previously, this function was called with FILENAME, but now + ;; it's called with the VEC. + (when (condition-case nil + (funcall (setq func (car elt)) vec) + (error + (setcar elt #'ignore) + (unless (member 'remote-file-error debug-ignored-errors) + (tramp-error + vec 'remote-file-error + "Not a valid Tramp file name function `%s'" func)))) (setq handler nil res (cdr elt)))) res))) @@ -2757,8 +2813,9 @@ remote file names." (defun tramp-register-foreign-file-name-handler (func handler &optional append) "Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'. -FUNC is the function, which determines whether HANDLER is to be called. -Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." +FUNC is the function, which takes a dissected filename and determines +whether HANDLER is to be called. Add operations defined in +`HANDLER-alist' to `tramp-file-name-handler'." (add-to-list 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) ;; Mark `operations' the handler is responsible for. @@ -2809,18 +2866,14 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (defun tramp-command-completion-p (_symbol buffer) "A predicate for Tramp interactive commands. They are completed by \"M-x TAB\" only if the current buffer is remote." - (with-current-buffer buffer (tramp-tramp-file-p default-directory))) + (tramp-tramp-file-p (tramp-get-default-directory buffer))) (defun tramp-connectable-p (vec-or-filename) "Check, whether it is possible to connect the remote host w/o side-effects. This is true, if either the remote host is already connected, or if we are not in completion mode." (let ((tramp-verbose 0) - (vec - (cond - ((tramp-file-name-p vec-or-filename) vec-or-filename) - ((tramp-tramp-file-p vec-or-filename) - (tramp-dissect-file-name vec-or-filename))))) + (vec (tramp-ensure-dissected-file-name vec-or-filename))) (or ;; We check this for the process related to ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. @@ -3278,6 +3331,28 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +;; `directory-abbrev-apply' and `directory-abbrev-make-regexp' exists +;; since Emacs 29.1. Since this handler isn't called for older +;; Emacsen, it is save to invoke them via `tramp-compat-funcall'. +(defun tramp-handle-abbreviate-file-name (filename) + "Like `abbreviate-file-name' for Tramp files." + (let* ((case-fold-search (file-name-case-insensitive-p filename)) + (vec (tramp-dissect-file-name filename)) + (home-dir + (with-tramp-connection-property vec "home-directory" + (tramp-compat-funcall + 'directory-abbrev-apply + (expand-file-name (tramp-make-tramp-file-name vec "~")))))) + ;; 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) + (tramp-make-tramp-file-name + vec (concat "~" (substring filename (match-beginning 1)))) + filename))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) @@ -3288,10 +3363,11 @@ User is always nil." (if (file-directory-p filename) #'file-accessible-directory-p #'file-readable-p) filename) - (tramp-error - v 'file-error (format "%s: Permission denied, %s" string filename))) - (tramp-compat-file-missing - v (format "%s: No such file or directory, %s" string filename))))) + (tramp-compat-permission-denied + v (format "%s: Permission denied, %s" string filename))) + (tramp-error + v 'file-missing + (format "%s: No such file or directory, %s" string filename))))) (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) @@ -3325,7 +3401,7 @@ User is always nil." ;; `copy-directory' creates NEWNAME before running this check. So ;; we do it ourselves. (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) ;; We must do it file-wise. (tramp-run-real-handler #'copy-directory @@ -3346,7 +3422,7 @@ User is always nil." (defun tramp-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let ((temp (nreverse (file-name-all-completions "" directory))) @@ -3397,13 +3473,16 @@ User is always nil." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; 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))))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." @@ -3412,9 +3491,7 @@ User is always nil." (defun tramp-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + (eq (file-attribute-type (file-attributes (file-truename filename))) t)) (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." @@ -3446,7 +3523,7 @@ User is always nil." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) @@ -3454,7 +3531,7 @@ User is always nil." (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." (when-let ((attrs (file-attributes filename)) - (mode-string (tramp-compat-file-attribute-modes attrs))) + (mode-string (file-attribute-modes attrs))) (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) (file-modes (file-truename filename)) (tramp-mode-string-to-int mode-string)))) @@ -3486,7 +3563,7 @@ User is always nil." (tramp-get-method-parameter v 'tramp-case-insensitive) ;; There isn't. So we must check, in case there's a connection already. - (and (file-remote-p filename nil 'connected) + (and (let ((non-essential t)) (tramp-connectable-p v)) (with-tramp-connection-property v "case-insensitive" (ignore-errors (with-tramp-progress-reporter v 5 "Checking case-insensitive" @@ -3507,16 +3584,13 @@ User is always nil." (directory-file-name (file-name-directory candidate)))) ;; Nothing found, so we must use a temporary file - ;; for comparison. `make-nearby-temp-file' is added - ;; to Emacs 26+ like `file-name-case-insensitive-p', - ;; so there is no compatibility problem calling it. + ;; for comparison. (unless (string-match-p "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory - (file-name-directory filename))) - (tramp-compat-funcall - 'make-nearby-temp-file "tramp.")) + (file-name-directory filename))) + (make-nearby-temp-file "tramp.")) candidate tmpfile)) ;; Check for the existence of the same file with ;; upper case letters. @@ -3577,9 +3651,8 @@ User is always nil." ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) (t (time-less-p - (tramp-compat-file-attribute-modification-time (file-attributes file2)) - (tramp-compat-file-attribute-modification-time - (file-attributes file1)))))) + (file-attribute-modification-time (file-attributes file2)) + (file-attribute-modification-time (file-attributes file1)))))) (defun tramp-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -3598,7 +3671,7 @@ User is always nil." ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. (when-let ((attr (file-attributes filename))) - (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) + (eq ?- (aref (file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3630,7 +3703,7 @@ User is always nil." (defun tramp-handle-file-symlink-p (filename) "Like `file-symlink-p' for Tramp files." - (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) + (let ((x (file-attribute-type (file-attributes filename)))) (and (stringp x) x))) (defun tramp-handle-file-truename (filename) @@ -3719,7 +3792,7 @@ User is always nil." (when (and (not tramp-allow-unsafe-temporary-files) (not backup-inhibited) (file-in-directory-p (car result) temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3776,7 +3849,7 @@ User is always nil." (unwind-protect (if (not (file-exists-p filename)) (let ((tramp-verbose (if visit 0 tramp-verbose))) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (with-tramp-progress-reporter v 3 (format-message "Inserting `%s'" filename) @@ -3890,16 +3963,19 @@ Return nil when there is no lockfile." (insert-file-contents-literally lockname) (buffer-string)))))) +(defvar tramp-lock-pid nil + "A random nunber local for every connection. +Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") + (defun tramp-get-lock-pid (file) "Determine pid for lockfile of FILE." - ;; Some Tramp methods do not offer a connection process, but just a - ;; network process as a place holder. Those processes use the - ;; "lock-pid" connection property as fake pid, in fact it is the - ;; time stamp the process is created. - (let ((p (tramp-get-process (tramp-dissect-file-name file)))) - (number-to-string - (or (process-id p) - (tramp-get-connection-property p "lock-pid" (emacs-pid)))))) + ;; Not all Tramp methods use an own process. So we use a random + ;; number, which is as good as a process id. + (with-current-buffer + (tramp-get-connection-buffer (tramp-dissect-file-name file)) + (or tramp-lock-pid + (setq-local + tramp-lock-pid (number-to-string (random most-positive-fixnum)))))) (defconst tramp-lock-file-info-regexp ;; USER@HOST.PID[:BOOT_TIME] @@ -3910,9 +3986,11 @@ Return nil when there is no lockfile." "Like `file-locked-p' for Tramp files." (when-let ((info (tramp-get-lock-file file)) (match (string-match tramp-lock-file-info-regexp info))) - (or (and (string-equal (match-string 1 info) (user-login-name)) + (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 3 info) (tramp-get-lock-pid file))) + ; User name. (match-string 1 info)))) (defun tramp-handle-lock-file (file) @@ -3941,7 +4019,7 @@ Return nil when there is no lockfile." (when (and (not tramp-allow-unsafe-temporary-files) create-lockfiles (file-in-directory-p lockname temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes file 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3993,7 +4071,7 @@ Return nil when there is no lockfile." v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) (unless (or noerror (file-exists-p file)) - (tramp-compat-file-missing v file)) + (tramp-error v 'file-missing file)) (if (not (file-exists-p file)) nil (let ((signal-hook-function (unless noerror signal-hook-function)) @@ -4255,18 +4333,13 @@ substitution. SPEC-LIST is a list of char/value pairs used for p)))))) (defun tramp-handle-make-symbolic-link - (target linkname &optional ok-if-already-exists) + (_target linkname &optional _ok-if-already-exists) "Like `make-symbolic-link' for Tramp files. This is the fallback implementation for backends which do not support symbolic links." - (if (tramp-tramp-file-p (expand-file-name linkname)) - (tramp-error - (tramp-dissect-file-name (expand-file-name linkname)) 'file-error - "make-symbolic-link not supported") - ;; This is needed prior Emacs 26.1, where TARGET has also be - ;; checked for a file name handler. - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)))) + (tramp-error + (tramp-dissect-file-name (expand-file-name linkname)) 'file-error + "make-symbolic-link not supported")) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." @@ -4484,7 +4557,7 @@ BUFFER might be a list, in this case STDERR is separated." (unless time-list (let ((remote-file-name-inhibit-cache t)) (setq time-list - (or (tramp-compat-file-attribute-modification-time + (or (file-attribute-modification-time (file-attributes (buffer-file-name))) tramp-time-doesnt-exist)))) (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) @@ -4508,7 +4581,7 @@ of." t (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -4539,11 +4612,9 @@ of." (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -4579,8 +4650,7 @@ of." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Set the ownership. @@ -4661,8 +4731,8 @@ of." (save-window-excursion (pop-to-buffer (tramp-get-connection-buffer vec)) (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-message vec 3 "Sending login name `%s'" user) (tramp-send-string vec (concat user tramp-local-end-of-line))) t) @@ -4705,8 +4775,8 @@ See also `tramp-action-yn'." (unless (yes-or-no-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "yes" tramp-local-end-of-line))) t) @@ -4719,8 +4789,8 @@ See also `tramp-action-yesno'." (unless (y-or-n-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "y" tramp-local-end-of-line))) t) @@ -4728,15 +4798,15 @@ See also `tramp-action-yesno'." "Tell the remote host which terminal type to use. The terminal type can be configured with `tramp-terminal-type'." (tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)) t) (defun tramp-action-confirm-message (_proc vec) "Return RET in order to confirm the message." - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec tramp-local-end-of-line) t) @@ -5024,8 +5094,8 @@ nil." ;; The process could have timed out, for example due to session ;; timeout of sudo. The process buffer does not exist any longer then. (ignore-errors - (with-current-buffer (process-buffer proc) - (tramp-message proc 6 "\n%s" (buffer-string)))) + (tramp-message + proc 6 "\n%s" (tramp-get-buffer-string (process-buffer proc)))) (unless found (if timeout (tramp-error @@ -5247,7 +5317,7 @@ If FILENAME is remote, a file name handler is called." (let* ((dir (file-name-directory filename)) (modes (file-modes dir))) (when (and modes (not (zerop (logand modes #o2000)))) - (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) + (setq gid (file-attribute-group-id (file-attributes dir))))) (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) (funcall handler #'tramp-set-file-uid-gid filename uid gid) @@ -5276,8 +5346,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; `group-name' has been introduced with Emacs 27.1. ((and (fboundp 'group-name) (equal id-format 'string)) (tramp-compat-funcall 'group-name (group-gid))) - ((tramp-compat-file-attribute-group-id - (file-attributes "~/" id-format)))))) + ((file-attribute-group-id (file-attributes "~/" id-format)))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -5332,31 +5401,22 @@ be granted." file-attr (or ;; Not a symlink. - (eq t (tramp-compat-file-attribute-type file-attr)) - (null (tramp-compat-file-attribute-type file-attr))) + (eq t (file-attribute-type file-attr)) + (null (file-attribute-type file-attr))) (or ;; World accessible. - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 6))) + (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) ;; User accessible and owned by user. (and - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) offset)) - (or (equal remote-uid - (tramp-compat-file-attribute-user-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-user-id file-attr)))) + (eq access (aref (file-attribute-modes file-attr) offset)) + (or (equal remote-uid (file-attribute-user-id file-attr)) + (equal unknown-id (file-attribute-user-id file-attr)))) ;; Group accessible and owned by user's principal group. (and (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 3))) - (or (equal remote-gid - (tramp-compat-file-attribute-group-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-group-id - file-attr)))))))))))) + (aref (file-attribute-modes file-attr) (+ offset 3))) + (or (equal remote-gid (file-attribute-group-id file-attr)) + (equal unknown-id (file-attribute-group-id file-attr)))))))))))) (defun tramp-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. @@ -5497,7 +5557,7 @@ this file, if that variable is non-nil." (when (and (not tramp-allow-unsafe-temporary-files) auto-save-default (file-in-directory-p result temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -5533,8 +5593,7 @@ ALIST is of the form ((FROM . TO) ...)." (defun tramp-handle-make-nearby-temp-file (prefix &optional dir-flag suffix) "Like `make-nearby-temp-file' for Tramp files." - (let ((temporary-file-directory - (tramp-compat-temporary-file-directory-function))) + (let ((temporary-file-directory (temporary-file-directory))) (make-temp-file prefix dir-flag suffix))) ;;; Compatibility functions section: @@ -5557,14 +5616,12 @@ are written with verbosity of 6." (with-temp-buffer (setq result (apply - #'call-process program infile (or destination t) display args)) + #'call-process program infile (or destination t) display args) + output (tramp-get-buffer-string destination)) ;; `result' could also be an error string. (when (stringp result) (setq error result - result 1)) - (with-current-buffer - (if (bufferp destination) destination (current-buffer)) - (setq output (buffer-string)))) + result 1))) (error (setq error (error-message-string err) result 1))) @@ -5595,10 +5652,10 @@ are written with verbosity of 6." ;; `result' could also be an error string. (when (stringp result) (signal 'file-error (list result))) - (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) - (if (zerop result) - (tramp-message vec 6 "%d" result) - (tramp-message vec 6 "%d\n%s" result (buffer-string))))) + (if (zerop result) + (tramp-message vec 6 "%d" result) + (tramp-message + vec 6 "%d\n%s" result (tramp-get-buffer-string buffer)))) (error (setq result 1) (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) @@ -5663,7 +5720,7 @@ Invokes `password-read' if available, `read-passwd' else." (format "%s for %s " (capitalize (match-string 1)) key)))) (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; Use connection-local value. - (auth-sources (with-current-buffer (process-buffer proc) auth-sources)) + (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) ;; We suspend the timers while reading the password. (stimers (with-timeout-suspend)) auth-info auth-passwd) @@ -5704,15 +5761,12 @@ Invokes `password-read' if available, `read-passwd' else." (setq auth-passwd (funcall auth-passwd))) auth-passwd) - ;; Try the password cache. Exists since Emacs 26.1. + ;; 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) - - ;; Else, get the password interactively w/o cache. - (read-passwd pw-prompt)) + auth-passwd)) ;; Workaround. Prior Emacs 28.1, auth-source has saved ;; empty passwords. See discussion in Bug#50399. @@ -5824,13 +5878,11 @@ name of a process or buffer, or nil to default to the current buffer." (while (tramp-accept-process-output proc 0)) (not (process-live-p proc)))))) -;; `interrupt-process-functions' exists since Emacs 26.1. -(when (boundp 'interrupt-process-functions) - (add-hook 'interrupt-process-functions #'tramp-interrupt-process) - (add-hook - 'tramp-unload-hook - (lambda () - (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(add-hook 'interrupt-process-functions #'tramp-interrupt-process) +(add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. @@ -5894,5 +5946,11 @@ BODY is the backend specific code." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. +;; +;; * Implement file name abbreviation for a different user. That is, +;; (abbreviate-file-name "/ssh:user1@host:/home/user2") => +;; "/ssh:user1@host:~user2". +;; +;; * Implement file name abbreviation for user and host names. ;;; tramp.el ends here diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 1f41a926763..e3bcd568d72 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.2.28.1 -;; Package-Requires: ((emacs "25.1")) +;; Version: 2.6.0-pre +;; Package-Requires: ((emacs "26.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.5.2.28.1" +(defconst tramp-version "2.6.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -74,9 +74,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "25.1")) +(let ((x (if (not (string-version-lessp emacs-version "26.1")) "ok" - (format "Tramp 2.5.2.28.1 is not fit for %s" + (format "Tramp 2.6.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 21c6f5dd9d0..b2ef47898cd 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -61,6 +61,13 @@ ;;; Code: +;; TODO: +;; - Add a menu bar and tool bar for this library. +;; - Add commands to create/delete link from the hotlist. +;; - Add something like a bookmark folder in modern browsers. +;; - Add a command that can open/follow all links in a folder. +;; - Add tags for Web sites in the hotlist. + ;;-------------------------------------------------------- Package Dependencies (require 'browse-url) |