diff options
Diffstat (limited to 'lisp/net')
62 files changed, 4206 insertions, 2625 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index fa13dd57d1d..e302aa89f30 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -949,7 +949,11 @@ Some AT&T folks claim to use something called `pftp' here." :type 'string) (defcustom ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v") - "A list of arguments passed to the FTP program when started." + ;; Clients that use the BSD editline instead of the GNU readline + ;; library may need to disable command line editing. (Bug#48494) + "A list of arguments passed to the FTP program when started. +Some FTP clients may also require the \"-e\" argument, which disables +command line editing." :group 'ange-ftp :type '(repeat string)) @@ -2292,7 +2296,7 @@ and NOWAIT." ;; If the dir name contains a space, some ftp servers will ;; refuse to list it. We instead change directory to the ;; directory in question and ls ".". - (when (string-match " " cmd1) + (when (string-search " " cmd1) ;; Keep the result. In case of failure, we will (see below) ;; short-circuit CMD and return this result directly. (setq result (ange-ftp-cd host user (nth 1 cmd) 'noerror)) @@ -2877,13 +2881,13 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." (or ;; No dots in dir names in vms. (and (eq host-type 'vms) - (string-match "\\." efile)) + (string-search "." efile)) ;; No subdirs in mts of cms. (and (memq host-type '(mts cms)) (not (string-equal "/" (nth 2 parsed)))) ;; No dots in pseudo-dir names in bs2000. (and (eq host-type 'bs2000) - (string-match "\\." efile)))))) + (string-search "." efile)))))) (defun ange-ftp-file-entry-p (name) "Given NAME, return whether there is a file entry for it." @@ -3716,7 +3720,7 @@ so return the size on the remote host exactly. See RFC 3659." (binary (or (ange-ftp-binary-file filename) (ange-ftp-binary-file newname))) temp1 - temp2) + ) ;; temp2 ;; check to see if we can overwrite (if (or (not ok-if-already-exists) @@ -3750,7 +3754,7 @@ so return the size on the remote host exactly. See RFC 3659." filename newname binary msg f-parsed f-host f-user f-name f-abbr t-parsed t-host t-user t-name t-abbr - temp1 temp2 cont nowait) + temp1 nil cont nowait) ;; temp2 nowait)) ;; filename wasn't remote. newname must be remote. call the @@ -6111,8 +6115,7 @@ Other orders of $ and _ seem to all work just fine.") (1- (match-end 2))))) (filename (if (match-beginning 3) (substring name (match-beginning 3))))) - (if (and (boundp 'filename) - (stringp filename) + (if (and (stringp filename) (string-match "[#@].+" filename)) (setq filename (concat ange-ftp-bs2000-special-prefix (substring filename 1)))) @@ -6259,10 +6262,6 @@ be recognized automatically (they are all valid BS2000 hosts too)." ;; ange-ftp-bs2000-file-name-as-directory ;; ange-ftp-bs2000-make-compressed-filename ;; ange-ftp-bs2000-file-name-sans-versions - -;;;; ------------------------------------------------------------ -;;;; Finally provide package. -;;;; ------------------------------------------------------------ (provide 'ange-ftp) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 58f01d5bf98..f739cd72cc3 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -47,6 +47,7 @@ ;; browse-url-xdg-open freedesktop.org xdg-open ;; browse-url-kde KDE konqueror (kfm) ;; browse-url-elinks Elinks Don't know (tried with 0.12.GIT) +;; eww-browse-url Emacs Web Wowser ;; Browsers can cache Web pages so it may be necessary to tell them to ;; reload the current page if it has changed (e.g., if you have edited @@ -758,7 +759,7 @@ for use in `interactive'." ;;;###autoload (defun browse-url-of-file (&optional file) - "Ask a WWW browser to display FILE. + "Use a web browser to display FILE. Display the current buffer's file if FILE is nil or if called interactively. Turn the filename into a URL with function `browse-url-file-url'. Pass the URL to a browser using the @@ -773,6 +774,8 @@ 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))) (browse-url (browse-url-file-url file)) (run-hooks 'browse-url-of-file-hook)) @@ -793,7 +796,9 @@ Use variable `browse-url-filename-alist' to map filenames to URLs." ;;;###autoload (defun browse-url-of-buffer (&optional buffer) - "Ask a WWW browser to display BUFFER. + "Use a web browser to display BUFFER. +See `browse-url' for details. + Display the current buffer if BUFFER is nil. Display only the currently visible part of BUFFER (from a temporary file) if buffer is narrowed." @@ -826,7 +831,7 @@ If optional arg TEMP-FILE-NAME is non-nil, delete it instead." (if (and file-name (file-exists-p file-name)) (delete-file file-name)))) -(add-hook 'kill-buffer-hook 'browse-url-delete-temp-file) +(add-hook 'kill-buffer-hook #'browse-url-delete-temp-file) (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) @@ -842,7 +847,8 @@ If optional arg TEMP-FILE-NAME is non-nil, delete it instead." ;;;###autoload (defun browse-url-of-region (min max) - "Ask a WWW browser to display the current region." + "Use a web browser to display the current region. +See `browse-url' for details." (interactive "r") (save-excursion (save-restriction @@ -856,14 +862,18 @@ If optional arg TEMP-FILE-NAME is non-nil, delete it instead." ;;;###autoload (defun browse-url (url &rest args) - "Ask a WWW browser to load URL. -Prompt for a URL, defaulting to the URL at or before point. -Invokes a suitable browser function which does the actual job. + "Open URL using a configurable method. +This will typically (by default) open URL with an external web +browser, but a wide variety of different methods can be used, +depending on the URL type. The variables `browse-url-browser-function', `browse-url-handlers', and `browse-url-default-handlers' determine which browser function to use. +This command prompts for a URL, defaulting to the URL at or +before point. + The additional ARGS are passed to the browser function. See the doc strings of the actual functions, starting with `browse-url-browser-function', for information about the @@ -895,8 +905,8 @@ If ARGS are omitted, the default is to pass ;;;###autoload (defun browse-url-at-point (&optional arg) - "Ask a WWW browser to load the URL at or before point. -Variable `browse-url-browser-function' says which browser to use. + "Open URL at point using a configurable method. +See `browse-url' for details. Optional prefix argument ARG non-nil inverts the value of the option `browse-url-new-window-flag'." (interactive "P") @@ -937,10 +947,11 @@ opposite of the browser kind of `browse-url-browser-function'." ;;;###autoload (defun browse-url-at-mouse (event) - "Ask a WWW browser to load a URL clicked with the mouse. -The URL is the one around or before the position of the mouse click -but point is not changed. Variable `browse-url-browser-function' -says which browser to use." + "Use a web browser to load a URL clicked with the mouse. +See `browse-url' for details. + +The URL is the one around or before the position of the mouse +click but point is not changed." (interactive "e") (save-excursion (mouse-set-point event) @@ -1064,7 +1075,7 @@ xdg-open is a desktop utility that calls your preferred web browser." (executable-find "xdg-open"))) ;;;###autoload -(defun browse-url-xdg-open (url &optional ignored) +(defun browse-url-xdg-open (url &optional _ignored) "Pass the specified URL to the \"xdg-open\" command. xdg-open is a desktop utility that calls your preferred web browser. The optional argument IGNORED is not used." @@ -1095,7 +1106,7 @@ used instead of `browse-url-new-window-flag'." (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process - (apply 'start-process + (apply #'start-process (concat "netscape " url) nil browse-url-netscape-program (append @@ -1113,8 +1124,8 @@ used instead of `browse-url-new-window-flag'." ",new-window")) ")")))))))) (set-process-sentinel process - `(lambda (process change) - (browse-url-netscape-sentinel process ,url))))) + (lambda (process _change) + (browse-url-netscape-sentinel process url))))) (function-put 'browse-url-netscape 'browse-url-browser-kind 'external) @@ -1125,7 +1136,7 @@ used instead of `browse-url-new-window-flag'." (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 + (apply #'start-process (concat "netscape" url) nil browse-url-netscape-program (append browse-url-netscape-startup-arguments (list url)))))) @@ -1144,7 +1155,7 @@ How depends on `browse-url-netscape-version'." "Send a remote control command to Netscape." (declare (obsolete nil "25.1")) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process "netscape" nil + (apply #'start-process "netscape" nil browse-url-netscape-program (append browse-url-netscape-arguments (list "-remote" command))))) @@ -1170,7 +1181,7 @@ used instead of `browse-url-new-window-flag'." (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process - (apply 'start-process + (apply #'start-process (concat "mozilla " url) nil browse-url-mozilla-program (append @@ -1185,8 +1196,8 @@ used instead of `browse-url-new-window-flag'." ",new-window")) ")")))))) (set-process-sentinel process - `(lambda (process change) - (browse-url-mozilla-sentinel process ,url))))) + (lambda (process _change) + (browse-url-mozilla-sentinel process url))))) (function-put 'browse-url-mozilla 'browse-url-browser-kind 'external) @@ -1196,7 +1207,7 @@ used instead of `browse-url-new-window-flag'." (let* ((process-environment (browse-url-process-environment))) ;; Mozilla is not running - start it (message "Starting %s..." browse-url-mozilla-program) - (apply 'start-process (concat "mozilla " url) nil + (apply #'start-process (concat "mozilla " url) nil browse-url-mozilla-program (append browse-url-mozilla-startup-arguments (list url)))))) @@ -1219,7 +1230,7 @@ instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process + (apply #'start-process (concat "firefox " url) nil browse-url-firefox-program (append @@ -1242,7 +1253,7 @@ 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))) - (apply 'start-process + (apply #'start-process (concat "chromium " url) nil browse-url-chromium-program (append @@ -1260,7 +1271,7 @@ 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))) - (apply 'start-process + (apply #'start-process (concat "google-chrome " url) nil browse-url-chrome-program (append @@ -1290,7 +1301,7 @@ used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) - (process (apply 'start-process + (process (apply #'start-process (concat "galeon " url) nil browse-url-galeon-program @@ -1303,8 +1314,8 @@ used instead of `browse-url-new-window-flag'." '("--existing")) (list url))))) (set-process-sentinel process - `(lambda (process change) - (browse-url-galeon-sentinel process ,url))))) + (lambda (process _change) + (browse-url-galeon-sentinel process url))))) (function-put 'browse-url-galeon 'browse-url-browser-kind 'external) @@ -1315,7 +1326,7 @@ used instead of `browse-url-new-window-flag'." (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 + (apply #'start-process (concat "galeon " url) nil browse-url-galeon-program (append browse-url-galeon-startup-arguments (list url)))))) @@ -1338,7 +1349,7 @@ used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) - (process (apply 'start-process + (process (apply #'start-process (concat "epiphany " url) nil browse-url-epiphany-program @@ -1351,8 +1362,8 @@ used instead of `browse-url-new-window-flag'." '("--existing")) (list url))))) (set-process-sentinel process - `(lambda (process change) - (browse-url-epiphany-sentinel process ,url))))) + (lambda (process _change) + (browse-url-epiphany-sentinel process url))))) (function-put 'browse-url-epiphany 'browse-url-browser-kind 'external) @@ -1362,7 +1373,7 @@ used instead of `browse-url-new-window-flag'." (let* ((process-environment (browse-url-process-environment))) ;; Epiphany is not running - start it (message "Starting %s..." browse-url-epiphany-program) - (apply 'start-process (concat "epiphany " url) nil + (apply #'start-process (concat "epiphany " url) nil browse-url-epiphany-program (append browse-url-epiphany-startup-arguments (list url)))))) @@ -1403,7 +1414,7 @@ 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: ")) - (apply 'start-process (concat "gnome-moz-remote " url) + (apply #'start-process (concat "gnome-moz-remote " url) nil browse-url-gnome-moz-program (append @@ -1437,7 +1448,7 @@ NEW-WINDOW instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process (format "conkeror %s" url) + (apply #'start-process (format "conkeror %s" url) nil browse-url-conkeror-program (append @@ -1487,7 +1498,7 @@ The `browse-url-gnudoit-program' program is used with options given by `browse-url-gnudoit-args'. Default to the URL around or before point." (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "W3 URL: ")) - (apply 'start-process (concat "gnudoit:" url) nil + (apply #'start-process (concat "gnudoit:" url) nil browse-url-gnudoit-program (append browse-url-gnudoit-args (list (concat "(w3-fetch \"" url "\")") @@ -1633,7 +1644,7 @@ used instead of `browse-url-new-window-flag'." (insert "\n")) (goto-char (prog1 (point) - (insert (replace-regexp-in-string "\r\n" "\n" body)) + (insert (string-replace "\r\n" "\n" body)) (unless (bolp) (insert "\n")))))))) @@ -1667,7 +1678,7 @@ don't offer a form of remote control." (interactive (browse-url-interactive-arg "URL: ")) (if (not browse-url-generic-program) (error "No browser defined (`browse-url-generic-program')")) - (apply 'call-process browse-url-generic-program nil + (apply #'call-process browse-url-generic-program nil 0 nil (append browse-url-generic-args (list url)))) @@ -1715,8 +1726,8 @@ from `browse-url-elinks-wrapper'." (elinks-ping-process (start-process "elinks-ping" nil "elinks" "-remote" "ping()"))) (set-process-sentinel elinks-ping-process - `(lambda (process change) - (browse-url-elinks-sentinel process ,url)))))) + (lambda (process _change) + (browse-url-elinks-sentinel process url)))))) (function-put 'browse-url-elinks 'browse-url-browser-kind 'external) @@ -1742,9 +1753,9 @@ from `browse-url-elinks-wrapper'." (defvar browse-url-button-map (let ((map (make-sparse-keymap))) - (define-key map "\r" 'browse-url-button-open) - (define-key map [mouse-2] 'browse-url-button-open) - (define-key map "w" 'browse-url-button-copy) + (define-key map "\r" #'browse-url-button-open) + (define-key map [mouse-2] #'browse-url-button-open) + (define-key map "w" #'browse-url-button-copy) map) "The keymap used for browse-url buttons.") @@ -1782,6 +1793,7 @@ external browser instead of the default one." (funcall browse-url-secondary-browser-function url) (browse-url url)))) +;;;###autoload (defun browse-url-button-open-url (url) "Open URL using `browse-url'. If `current-prefix-arg' is non-nil, use diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index a9de35c814f..4116d293e1b 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -1144,6 +1144,7 @@ compound type arguments (TYPE VALUE) will be kept as is." EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being part of the event, is called with arguments ARGS (without type information). If the HANDLER returns a `dbus-error', it is propagated as return message." + (declare (completion ignore)) (interactive "e") (condition-case err (let (monitor args result) @@ -2028,8 +2029,9 @@ either a method name, a signal name, or an error name." ",") rule (or rule "")) - (unless (ignore-errors (dbus-get-unique-name bus-private)) - (dbus-init-bus bus 'private)) + (when (fboundp 'dbus-get-unique-name) + (unless (ignore-errors (dbus-get-unique-name bus-private)) + (dbus-init-bus bus 'private))) (dbus-call-method bus-private dbus-service-dbus dbus-path-dbus dbus-interface-monitoring "BecomeMonitor" `(:array :string ,rule) :uint32 0) diff --git a/lisp/net/dictionary-connection.el b/lisp/net/dictionary-connection.el index 8ad4fe4e637..b874c488a82 100644 --- a/lisp/net/dictionary-connection.el +++ b/lisp/net/dictionary-connection.el @@ -22,10 +22,10 @@ ;;; Commentary: -;; dictionary-connection allows to handle TCP-based connections in -;; client mode where text-based information are exchanged. There is +;; dictionary-connection allows handling TCP-based connections in +;; client mode where text-based information is exchanged. There is ;; special support for handling CR LF (and the usual CR LF . CR LF -;; terminater). +;; terminator). ;;; Code: @@ -68,7 +68,7 @@ (defun dictionary-connection-open (server port) "Open a connection to SERVER at PORT. -A data structure identifing the connection is returned" +Return a data structure identifying the connection." (let ((process-buffer (generate-new-buffer (format " connection to %s:%s" server @@ -82,11 +82,11 @@ A data structure identifing the connection is returned" (defun dictionary-connection-status (connection) "Return the status of the CONNECTION. Possible return values are the symbols: -nil: argument is no connection object -'none: argument has no connection -'up: connection is open and buffer is existing -'down: connection is closed -'alone: connection is not associated with a buffer" + nil: argument is not a connection object + 'none: argument is not connected + 'up: connection is open and buffer is existing + 'down: connection is closed + 'alone: connection is not associated with a buffer" (when (dictionary-connection-p connection) (let ((process (dictionary-connection-process connection)) (buffer (dictionary-connection-buffer connection))) diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index ccc24cbf303..f33cbaf1126 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -35,7 +35,6 @@ ;;; Code: (require 'cl-lib) -(require 'easymenu) (require 'custom) (require 'dictionary-connection) (require 'button) @@ -77,7 +76,7 @@ You can specify here: - dict.org: Only use dict.org - User-defined: You can specify your own server here" :group 'dictionary - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type '(choice (const :tag "Automatic" nil) (const :tag "localhost" "localhost") (const :tag "dict.org" "dict.org") @@ -89,7 +88,7 @@ You can specify here: "The port of the dictionary server. This port is propably always 2628 so there should be no need to modify it." :group 'dictionary - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'number :version "28.1") @@ -127,9 +126,9 @@ by the choice value: The found word exactly matches the searched word. -- Similiar sounding +- Similar sounding - The found word sounds similiar to the searched word. For this match type + The found word sounds similar to the searched word. For this match type the soundex algorithm defined by Donald E. Knuth is used. It will only works with english words and the algorithm is not very reliable (i.e., the soundex algorithm is quite simple). @@ -148,7 +147,7 @@ by the choice value: dictionary server." :group 'dictionary :type '(choice (const :tag "Exact match" "exact") - (const :tag "Similiar sounding" "soundex") + (const :tag "Similar sounding" "soundex") (const :tag "Levenshtein distance one" "lev") (string :tag "User choice")) :version "28.1") @@ -160,6 +159,18 @@ by the choice value: :type 'boolean :version "28.1") +(defcustom dictionary-link-dictionary + "*" + "The dictionary which is used in links. +* means to create links that search all dictionaries, +nil means to create links that search only in the same dictionary +where the current word was found." + :group 'dictionary + :type '(choice (const :tag "Link to all dictionaries" "*") + (const :tag "Link only to the same dictionary" nil) + (string :tag "User choice")) + :version "28.1") + (defcustom dictionary-mode-hook nil "Hook run in dictionary mode buffers." @@ -167,11 +178,18 @@ by the choice value: :type 'hook :version "28.1") +(defcustom dictionary-post-buffer-hook + nil + "Hook run at the end of every update of the dictionary buffer." + :group 'dictionary + :type 'hook + :version "28.1") + (defcustom dictionary-use-http-proxy nil "Connects via a HTTP proxy using the CONNECT command when not nil." :group 'dictionary-proxy - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'boolean :version "28.1") @@ -179,7 +197,7 @@ by the choice value: "proxy" "The name of the HTTP proxy to use when `dictionary-use-http-proxy' is set." :group 'dictionary-proxy - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'string :version "28.1") @@ -187,7 +205,7 @@ by the choice value: 3128 "The port of the proxy server, used only when `dictionary-use-http-proxy' is set." :group 'dictionary-proxy - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'number :version "28.1") @@ -313,18 +331,19 @@ is utf-8" (suppress-keymap map) (set-keymap-parent map button-buffer-map) - (define-key map "q" 'dictionary-close) - (define-key map "h" 'dictionary-help) - (define-key map "s" 'dictionary-search) - (define-key map "d" 'dictionary-lookup-definition) - (define-key map "D" 'dictionary-select-dictionary) - (define-key map "M" 'dictionary-select-strategy) - (define-key map "m" 'dictionary-match-words) - (define-key map "l" 'dictionary-previous) - (define-key map "n" 'forward-button) - (define-key map "p" 'backward-button) - (define-key map " " 'scroll-up) - (define-key map (read-kbd-macro "M-SPC") 'scroll-down) + (define-key map "q" #'dictionary-close) + (define-key map "h" #'dictionary-help) + (define-key map "s" #'dictionary-search) + (define-key map "d" #'dictionary-lookup-definition) + (define-key map "D" #'dictionary-select-dictionary) + (define-key map "M" #'dictionary-select-strategy) + (define-key map "m" #'dictionary-match-words) + (define-key map "l" #'dictionary-previous) + (define-key map "n" #'forward-button) + (define-key map "p" #'backward-button) + (define-key map " " #'scroll-up-command) + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map (read-kbd-macro "M-SPC") #'scroll-down-command) map) "Keymap for the dictionary mode.") @@ -394,12 +413,12 @@ This is a quick reference to this mode describing the default key bindings: (make-local-variable 'dictionary-default-dictionary) (make-local-variable 'dictionary-default-strategy) - (add-hook 'kill-buffer-hook 'dictionary-close t t) + (add-hook 'kill-buffer-hook #'dictionary-close t t) (run-hooks 'dictionary-mode-hook)) ;;;###autoload (defun dictionary () - "Create a new dictonary buffer and install `dictionary-mode'." + "Create a new dictionary buffer and install `dictionary-mode'." (interactive) (let ((buffer (or (and dictionary-use-single-buffer (get-buffer "*Dictionary*")) @@ -516,7 +535,7 @@ The connection takes the proxy setting in customization group ;; Dealing with closing the buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun dictionary-close (&rest ignored) +(defun dictionary-close (&rest _ignored) "Close the current dictionary buffer and its connection." (interactive) (if (eq major-mode 'dictionary-mode) @@ -548,7 +567,7 @@ The connection takes the proxy setting in customization group answer))) (defun dictionary-split-string (string) - "Split STRING constiting of space-separated words into elements. + "Split STRING consisting of space-separated words into elements. This function knows about the special meaning of quotes (\")" (let ((list)) (while (and string (> (length string) 0)) @@ -650,7 +669,7 @@ previous state." (setq dictionary-positions (cons (point) (window-start)))) ;; Restore the previous state -(defun dictionary-restore-state (&rest ignored) +(defun dictionary-restore-state (&rest _ignored) "Restore the state just before the last operation." (let ((position (pop dictionary-position-stack)) (data (pop dictionary-data-stack))) @@ -702,13 +721,14 @@ of matching words." (if (dictionary-check-reply reply 552) (progn (unless nomatching - (beep) - (insert "Word not found, maybe you are looking " - "for one of these words\n\n") - (dictionary-do-matching word - dictionary - "." - 'dictionary-display-only-match-result) + (insert "Word not found") + (dictionary-do-matching + word + dictionary + "." + (lambda (reply) + (insert ", maybe you are looking for one of these words\n\n") + (dictionary-display-only-match-result reply))) (dictionary-post-buffer))) (if (dictionary-check-reply reply 550) (error "Dictionary \"%s\" is unknown, please select an existing one" @@ -772,7 +792,8 @@ of matching words." (goto-char dictionary-marker) (set-buffer-modified-p nil) - (setq buffer-read-only t)) + (setq buffer-read-only t) + (run-hooks 'dictionary-post-buffer-hook)) (defun dictionary-display-search-result (reply) "Start displaying the result in REPLY." @@ -809,7 +830,7 @@ The DICTIONARY is only used for decoding the bytes to display the DESCRIPTION." (defun dictionary-display-word-definition (reply word dictionary) "Insert the definition in REPLY for the current WORD from DICTIONARY. It will replace links which are found in the REPLY and replace -them with buttons to perform a a new search." +them with buttons to perform a new search." (let ((start (point))) (insert (dictionary-decode-charset reply dictionary)) (insert "\n\n") @@ -842,6 +863,8 @@ The word is taken from the buffer, the DICTIONARY is given as argument." (setq word (replace-match " " t t word))) (while (string-match "[*\"]" word) (setq word (replace-match "" t t word))) + (when dictionary-link-dictionary + (setq dictionary dictionary-link-dictionary)) (unless (equal word displayed-word) (make-button start end :type 'dictionary-link @@ -850,7 +873,7 @@ The word is taken from the buffer, the DICTIONARY is given as argument." 'help-echo (concat "Press Mouse-2 to lookup \"" word "\" in \"" dictionary "\""))))) -(defun dictionary-select-dictionary (&rest ignored) +(defun dictionary-select-dictionary (&rest _ignored) "Save the current state and start a dictionary selection." (interactive) (dictionary-ensure-buffer) @@ -858,7 +881,7 @@ The word is taken from the buffer, the DICTIONARY is given as argument." (dictionary-do-select-dictionary) (dictionary-store-state 'dictionary-do-select-dictionary nil)) -(defun dictionary-do-select-dictionary (&rest ignored) +(defun dictionary-do-select-dictionary (&rest _ignored) "The workhorse for doing the dictionary selection." (message "Looking up databases and descriptions") @@ -871,7 +894,7 @@ The word is taken from the buffer, the DICTIONARY is given as argument." (unless (dictionary-check-reply reply 110) (error "Unknown server answer: %s" (dictionary-reply reply))) - (dictionary-display-dictionarys)))) + (dictionary-display-dictionaries)))) (defun dictionary-simple-split-string (string &optional pattern) "Return a list of substrings of STRING which are separated by PATTERN. @@ -886,7 +909,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." start (match-end 0))) (nreverse (cons (substring string start) parts)))) -(defun dictionary-display-dictionarys () +(defun dictionary-display-dictionaries () "Handle the display of all dictionaries existing on the server." (dictionary-pre-buffer) (insert "Please select your default dictionary:\n\n") @@ -894,7 +917,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (dictionary-display-dictionary-line "! \"The first matching dictionary\"") (let* ((reply (dictionary-read-answer)) (list (dictionary-simple-split-string reply "\n+"))) - (mapc 'dictionary-display-dictionary-line list)) + (mapc #'dictionary-display-dictionary-line list)) (dictionary-post-buffer)) (defun dictionary-display-dictionary-line (string) @@ -962,7 +985,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (dictionary-store-state 'dictionary-display-more-info dictionary)))) -(defun dictionary-select-strategy (&rest ignored) +(defun dictionary-select-strategy (&rest _ignored) "Save the current state and start a strategy selection." (interactive) (dictionary-ensure-buffer) @@ -992,7 +1015,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (dictionary-display-strategy-line ". \"The servers default\"") (let* ((reply (dictionary-read-answer)) (list (dictionary-simple-split-string reply "\n+"))) - (mapc 'dictionary-display-strategy-line list)) + (mapc #'dictionary-display-strategy-line list)) (dictionary-post-buffer)) (defun dictionary-display-strategy-line (string) @@ -1008,7 +1031,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." 'help-echo (purecopy "Mouse-2 to select this matching algorithm")) (insert "\n"))))) -(defun dictionary-set-strategy (strategy &rest ignored) +(defun dictionary-set-strategy (strategy &rest _ignored) "Select this STRATEGY as new default." (setq dictionary-default-strategy strategy) (dictionary-restore-state) @@ -1052,7 +1075,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (defun dictionary-display-only-match-result (reply) "Display the results from the current matches in REPLY without the headers." - (let ((number (nth 1 (dictionary-reply-list reply))) (list (dictionary-simple-split-string (dictionary-read-answer) "\n+"))) (insert number " matching word" (if (equal number "1") "" "s") @@ -1117,9 +1139,11 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." ;; - if region is active returns its contents ;; - otherwise return the word near the point (defun dictionary-search-default () - (if (use-region-p) - (buffer-substring-no-properties (region-beginning) (region-end)) - (current-word t))) + (cond + ((use-region-p) + (buffer-substring-no-properties (region-beginning) (region-end))) + ((car (get-char-property (point) 'data))) + (t (current-word t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User callable commands @@ -1146,7 +1170,7 @@ allows editing it." ;; if called by pressing the button (unless word (setq word (read-string "Search word: " nil 'dictionary-word-history))) - ;; just in case non-interactivly called + ;; just in case non-interactively called (unless dictionary (setq dictionary dictionary-default-dictionary)) (dictionary-new-search (cons word dictionary))) @@ -1170,7 +1194,7 @@ allows editing it." (describe-function 'dictionary-mode)) ;;;###autoload -(defun dictionary-match-words (&optional pattern &rest ignored) +(defun dictionary-match-words (&optional pattern &rest _ignored) "Search PATTERN in current default dictionary using default strategy." (interactive) ;; can't use interactive because of mouse events @@ -1224,10 +1248,10 @@ allows editing it." ;;; Tooltip support -;; Add a mode indicater named "Dict" +;; Add a mode indicator named "Dict" (defvar dictionary-tooltip-mode nil - "Indicates wheather the dictionary tooltip mode is active.") + "Indicates whether the dictionary tooltip mode is active.") (nconc minor-mode-alist '((dictionary-tooltip-mode " Dict"))) (defcustom dictionary-tooltip-dictionary @@ -1246,7 +1270,7 @@ allows editing it." (defun dictionary-read-definition (&ignore) (let ((list (dictionary-simple-split-string (dictionary-read-answer) "\n+"))) - (mapconcat 'identity (cdr list) "\n"))) + (mapconcat #'identity (cdr list) "\n"))) ;;; Tooltip support for GNU Emacs (defvar global-dictionary-tooltip-mode @@ -1298,8 +1322,8 @@ will be set to nil." (interactive) (tooltip-mode on) (if on - (add-hook 'tooltip-functions 'dictionary-display-tooltip) - (remove-hook 'tooltip-functions 'dictionary-display-tooltip))) + (add-hook 'tooltip-functions #'dictionary-display-tooltip) + (remove-hook 'tooltip-functions #'dictionary-display-tooltip))) ;;;###autoload (defun dictionary-tooltip-mode (&optional arg) @@ -1340,9 +1364,8 @@ any buffer where (dictionary-tooltip-mode 1) has been called." (make-local-variable 'dictionary-tooltip-mouse-event) (setq-default track-mouse on) (dictionary-switch-tooltip-mode 1) - (if on - (global-set-key [mouse-movement] 'dictionary-tooltip-track-mouse) - (global-set-key [mouse-movement] 'ignore)) + (global-set-key [mouse-movement] + (if on #'dictionary-tooltip-track-mouse #'ignore)) on)) (provide 'dictionary) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index 92dcf73250b..4f0b0df2b73 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -79,7 +79,7 @@ and is a commonly available debugging tool." (push domain cmdline) (if server (push (concat "@" server) cmdline) (if dig-dns-server (push (concat "@" dig-dns-server) cmdline))) - (apply 'call-process dig-program nil buf nil cmdline) + (apply #'call-process dig-program nil buf nil cmdline) buf)) (defun dig-extract-rr (domain &optional type class) @@ -120,7 +120,7 @@ Buffer should contain output generated by `dig-invoke'." (defvar dig-mode-map (let ((map (make-sparse-keymap))) (define-key map "g" nil) - (define-key map "q" 'dig-exit) + (define-key map "q" #'dig-exit) map)) (define-derived-mode dig-mode special-mode "Dig" @@ -138,9 +138,14 @@ Buffer should contain output generated by `dig-invoke'." ;;;###autoload (defun dig (domain &optional query-type query-class query-option dig-option server) - "Query addresses of a DOMAIN using dig, by calling `dig-invoke'. -Optional arguments are passed to `dig-invoke'." - (interactive "sHost: ") + "Query addresses of a DOMAIN using dig. +See `dig-invoke' for an explanation for the parameters. +When called interactively, DOMAIN is prompted for. If given a prefix, +also prompt for the QUERY-TYPE parameter." + (interactive + (list (read-string "Host: ") + (and current-prefix-arg + (read-string "Query type: ")))) (pop-to-buffer-same-window (dig-invoke domain query-type query-class query-option dig-option server)) (goto-char (point-min)) diff --git a/lisp/net/dns.el b/lisp/net/dns.el index 2045d4dfca1..1086bab9466 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -135,8 +135,8 @@ updated. Set this variable to t to disable the check.") (if (stringp ended) (if (null name) ended - (concat (mapconcat 'identity (nreverse name) ".") "." ended)) - (mapconcat 'identity (nreverse name) ".")))) + (concat (mapconcat #'identity (nreverse name) ".") "." ended)) + (mapconcat #'identity (nreverse name) ".")))) (defun dns-write (spec &optional tcp-p) "Write a DNS packet according to SPEC. @@ -283,7 +283,7 @@ If TCP-P, the first two bytes of the packet will be the length field." (let ((bytes nil)) (dotimes (_ 4) (push (dns-read-bytes 1) bytes)) - (mapconcat 'number-to-string (nreverse bytes) "."))) + (mapconcat #'number-to-string (nreverse bytes) "."))) ((eq type 'AAAA) (let (hextets) (dotimes (_ 8) @@ -332,7 +332,7 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (setq dns-servers (nreverse dns-servers)))) (when (executable-find "nslookup") (with-temp-buffer - (call-process "nslookup" nil t nil "localhost") + (call-process "nslookup" nil t nil "-retry=0" "-timeout=2" "localhost") (goto-char (point-min)) (when (re-search-forward "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\|[[:xdigit:]:]*\\)" nil t) @@ -386,7 +386,7 @@ If REVERSE, look up an IP address." (when reverse (setq name (concat - (mapconcat 'identity (nreverse (split-string name "\\.")) ".") + (mapconcat #'identity (nreverse (split-string name "\\.")) ".") ".in-addr.arpa") type 'PTR)) @@ -492,19 +492,22 @@ If REVERSE, look up an IP address." (dns-get-txt-answer (dns-get 'answers result)) (dns-get 'data answer)))))))))) +;;;###autoload (defun dns-query (name &optional type full reverse) "Query a DNS server for NAME of TYPE. If FULL, return the entire record returned. If REVERSE, look up an IP address." - (let ((result nil)) - (dns-query-asynchronous - name - (lambda (response) - (setq result (list response))) - type full reverse) - ;; Loop until we get the callback. - (while (not result) - (sleep-for 0.01)) + (let* ((result nil) + (query-started + (dns-query-asynchronous + name + (lambda (response) + (setq result (list response))) + type full reverse))) + (if query-started + ;; Loop until we get the callback. + (while (not result) + (sleep-for 0.01))) (car result))) (provide 'dns) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 456d70ee0fe..1d7af7f5b5f 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -41,38 +41,38 @@ (defvar eudc-bob-generic-keymap (let ((map (make-sparse-keymap))) - (define-key map "s" 'eudc-bob-save-object) - (define-key map "!" 'eudc-bob-pipe-object-to-external-program) - (define-key map [down-mouse-3] 'eudc-bob-popup-menu) + (define-key map "s" #'eudc-bob-save-object) + (define-key map "!" #'eudc-bob-pipe-object-to-external-program) + (define-key map [down-mouse-3] #'eudc-bob-popup-menu) map) "Keymap for multimedia objects.") (defvar eudc-bob-image-keymap (let ((map (make-sparse-keymap))) (set-keymap-parent map eudc-bob-generic-keymap) - (define-key map "t" 'eudc-bob-toggle-inline-display) + (define-key map "t" #'eudc-bob-toggle-inline-display) map) "Keymap for inline images.") (defvar eudc-bob-sound-keymap (let ((map (make-sparse-keymap))) (set-keymap-parent map eudc-bob-generic-keymap) - (define-key map (kbd "RET") 'eudc-bob-play-sound-at-point) - (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) + (define-key map (kbd "RET") #'eudc-bob-play-sound-at-point) + (define-key map [down-mouse-2] #'eudc-bob-play-sound-at-mouse) map) "Keymap for inline sounds.") (defvar eudc-bob-url-keymap (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'browse-url-at-point) - (define-key map [down-mouse-2] 'browse-url-at-mouse) + (define-key map (kbd "RET") #'browse-url-at-point) + (define-key map [down-mouse-2] #'browse-url-at-mouse) map) "Keymap for inline urls.") (defvar eudc-bob-mail-keymap (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'goto-address-at-point) - (define-key map [down-mouse-2] 'goto-address-at-point) + (define-key map (kbd "RET") #'goto-address-at-point) + (define-key map [down-mouse-2] #'goto-address-at-point) map) "Keymap for inline e-mail addresses.") diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el index bac75e6555d..66db7814ad8 100644 --- a/lisp/net/eudc-export.el +++ b/lisp/net/eudc-export.el @@ -1,4 +1,4 @@ -;;; eudc-export.el --- functions to export EUDC query results +;;; eudc-export.el --- functions to export EUDC query results -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -35,6 +35,7 @@ ;; NOERROR is so we can compile it. (require 'bbdb nil t) (require 'bbdb-com nil t) +(require 'cl-lib) (defun eudc-create-bbdb-record (record &optional silent) "Create a BBDB record using the RECORD alist. @@ -42,24 +43,22 @@ RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name symbol and VALUE is the corresponding value for the record. If SILENT is non-nil then the created BBDB record is not displayed." (require 'bbdb) + (declare-function bbdb-create-internal "bbdb-com" (&rest spec)) + (declare-function bbdb-display-records "bbdb" + (records &optional layout append)) ;; This function runs in a special context where lisp symbols corresponding ;; to field names in record are bound to the corresponding values - (eval - `(let* (,@(mapcar (lambda (c) - (list (car c) (if (listp (cdr c)) - (list 'quote (cdr c)) - (cdr c)))) - record) - bbdb-name - bbdb-company - bbdb-net - bbdb-address - bbdb-phones - bbdb-notes - spec - bbdb-record - value - (conversion-alist (symbol-value eudc-bbdb-conversion-alist))) + (cl-progv (mapcar #'car record) (mapcar #'cdr record) + (let* (bbdb-name + bbdb-company + bbdb-net + bbdb-address + bbdb-phones + bbdb-notes + spec + bbdb-record + value + (conversion-alist (symbol-value eudc-bbdb-conversion-alist))) ;; BBDB standard fields (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil) @@ -68,14 +67,14 @@ If SILENT is non-nil then the created BBDB record is not displayed." bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil)) (setq spec (cdr (assq 'address conversion-alist))) (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec)) - spec - (list spec)) - record t))) + spec + (list spec)) + record t))) (setq spec (cdr (assq 'phone conversion-alist))) (setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec)) - spec - (list spec)) - record t))) + spec + (list spec)) + record t))) ;; BBDB custom fields (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes))) (mapcar (lambda (mapping) @@ -85,19 +84,20 @@ If SILENT is non-nil then the created BBDB record is not displayed." (cons (car mapping) value))) conversion-alist))) (setq bbdb-notes (delq nil bbdb-notes)) - (setq bbdb-record (bbdb-create-internal - bbdb-name - ,@(when (eudc--using-bbdb-3-or-newer-p) - '(nil - nil)) - bbdb-company - bbdb-net - ,@(if (eudc--using-bbdb-3-or-newer-p) - '(bbdb-phones - bbdb-address) - '(bbdb-address - bbdb-phones)) - bbdb-notes)) + (setq bbdb-record + (apply #'bbdb-create-internal + `(,bbdb-name + ,@(when (eudc--using-bbdb-3-or-newer-p) + '(nil + nil)) + ,bbdb-company + ,bbdb-net + ,@(if (eudc--using-bbdb-3-or-newer-p) + (list bbdb-phones + bbdb-address) + (list bbdb-address + bbdb-phones)) + ,bbdb-notes))) (or silent (bbdb-display-records (list bbdb-record)))))) @@ -111,7 +111,7 @@ If RECURSE is non-nil then SPEC may be a list of atomic specs." (symbolp (car spec)) (fboundp (car spec)))) (condition-case nil - (eval spec) + (eval spec t) (void-variable nil))) ((and recurse (listp spec)) @@ -194,9 +194,9 @@ LOCATION is used as the phone location for BBDB." (signal (car err) (cdr err))))) (if (= 3 (length phone-list)) (setq phone-list (append phone-list '(nil)))) - (apply 'vector location phone-list))) + (apply #'vector location phone-list))) ((listp phone) - (vector location (mapconcat 'identity phone ", "))) + (vector location (mapconcat #'identity phone ", "))) (t (error "Invalid phone specification")))) diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index e4b7e8ae71b..a737a99ce95 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -1,4 +1,4 @@ -;;; eudc-hotlist.el --- hotlist management for EUDC +;;; eudc-hotlist.el --- hotlist management for EUDC -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -37,12 +37,12 @@ (defvar eudc-hotlist-mode-map (let ((map (make-sparse-keymap))) - (define-key map "a" 'eudc-hotlist-add-server) - (define-key map "d" 'eudc-hotlist-delete-server) - (define-key map "s" 'eudc-hotlist-select-server) - (define-key map "t" 'eudc-hotlist-transpose-servers) - (define-key map "q" 'eudc-hotlist-quit-edit) - (define-key map "x" 'kill-current-buffer) + (define-key map "a" #'eudc-hotlist-add-server) + (define-key map "d" #'eudc-hotlist-delete-server) + (define-key map "s" #'eudc-hotlist-select-server) + (define-key map "t" #'eudc-hotlist-transpose-servers) + (define-key map "q" #'eudc-hotlist-quit-edit) + (define-key map "x" #'kill-current-buffer) map)) (define-derived-mode eudc-hotlist-mode fundamental-mode "EUDC-Servers" diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index f61929c9ef8..6459c52afee 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -49,10 +49,6 @@ (require 'cl-lib) -(eval-and-compile - (if (not (fboundp 'make-overlay)) - (require 'overlay))) - (unless (fboundp 'custom-menu-create) (autoload 'custom-menu-create "cus-edit")) @@ -69,12 +65,12 @@ (defvar eudc-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map widget-keymap) - (define-key map "q" 'kill-current-buffer) - (define-key map "x" 'kill-current-buffer) - (define-key map "f" 'eudc-query-form) - (define-key map "b" 'eudc-try-bbdb-insert) - (define-key map "n" 'eudc-move-to-next-record) - (define-key map "p" 'eudc-move-to-previous-record) + (define-key map "q" #'kill-current-buffer) + (define-key map "x" #'kill-current-buffer) + (define-key map "f" #'eudc-query-form) + (define-key map "b" #'eudc-try-bbdb-insert) + (define-key map "n" #'eudc-move-to-next-record) + (define-key map "p" #'eudc-move-to-previous-record) map)) (defvar mode-popup-menu) @@ -411,7 +407,7 @@ if any, is called to print the value in cdr of FIELD." (val (cdr field))) (if match (progn - (eval (list (cdr match) val)) + (funcall (cdr match) val) (insert "\n")) (mapc (lambda (val-elem) @@ -1056,8 +1052,6 @@ queries the server for the existing fields and displays a corresponding form." ;;{{{ Menus and keymaps -(require 'easymenu) - (defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc))) (defconst eudc-tail-menu @@ -1114,12 +1108,12 @@ queries the server for the existing fields and displays a corresponding form." proto-name))) (if (not (fboundp command)) (fset command - `(lambda () - (interactive) - (eudc-set-server ,server (quote ,protocol)) - (message "Selected directory server is now %s (%s)" - ,server - ,proto-name)))) + (lambda () + (interactive) + (eudc-set-server server protocol) + (message "Selected directory server is now %s (%s)" + server + proto-name)))) (vector (format "%s (%s)" server proto-name) command :style 'radio @@ -1135,7 +1129,9 @@ queries the server for the existing fields and displays a corresponding form." (cons "Directory Servers" (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) -;;; Load time initializations : +;;}}} + +;;{{{ Load time initializations ;; Load the options file (if (and (not noninteractive) diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index e11458b29cb..e241a1c2fac 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -1,4 +1,4 @@ -;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend +;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -34,6 +34,7 @@ ;; Make it loadable on systems without bbdb. (require 'bbdb nil t) (require 'bbdb-com nil t) +(require 'seq) ;;{{{ Internal cooking @@ -87,33 +88,30 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise." (require 'bbdb) (catch 'unmatch - (progn - (dolist (condition eudc-bbdb-current-query) - (let ((attr (car condition)) - (val (cdr condition)) - (case-fold-search t) - bbdb-val) - (or (and (memq attr '(firstname lastname aka company phones - addresses net)) - (progn - (setq bbdb-val - (eval (list (intern (concat "bbdb-record-" - (symbol-name - (eudc-bbdb-field - attr)))) - 'record))) - (if (listp bbdb-val) - (if eudc-bbdb-enable-substring-matches - (eval `(or ,@(mapcar (lambda (subval) - (string-match val subval)) - bbdb-val))) - (member (downcase val) - (mapcar 'downcase bbdb-val))) + (dolist (condition eudc-bbdb-current-query) + (let ((attr (car condition)) + (val (cdr condition)) + (case-fold-search t)) + (or (and (memq attr '(firstname lastname aka company phones + addresses net)) + (let ((bbdb-val + (funcall (intern (concat "bbdb-record-" + (symbol-name + (eudc-bbdb-field + attr)))) + record))) + (if (listp bbdb-val) (if eudc-bbdb-enable-substring-matches - (string-match val bbdb-val) - (string-equal (downcase val) (downcase bbdb-val)))))) - (throw 'unmatch nil)))) - record))) + (seq-some (lambda (subval) + (string-match val subval)) + bbdb-val) + (member (downcase val) + (mapcar #'downcase bbdb-val))) + (if eudc-bbdb-enable-substring-matches + (string-match val bbdb-val) + (string-equal (downcase val) (downcase bbdb-val)))))) + (throw 'unmatch nil)))) + record)) ;; External. (declare-function bbdb-phone-location "ext:bbdb" t) ; via bbdb-defstruct @@ -182,40 +180,34 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'." (require 'bbdb) (let ((attrs (or eudc-bbdb-current-return-attributes '(firstname lastname aka company phones addresses net notes))) - attr - eudc-rec - val) - (while (prog1 - (setq attr (car attrs)) - (setq attrs (cdr attrs))) - (cond - ((eq attr 'phones) - (setq val (eudc-bbdb-extract-phones record))) - ((eq attr 'addresses) - (setq val (eudc-bbdb-extract-addresses record))) - ((eq attr 'notes) - (if (eudc--using-bbdb-3-or-newer-p) - (setq val (bbdb-record-xfield record 'notes)) - (setq val (bbdb-record-notes record)))) - ((memq attr '(firstname lastname aka company net)) - (setq val (eval - (list (intern - (concat "bbdb-record-" - (symbol-name (eudc-bbdb-field attr)))) - 'record)))) - (t - (error "Unknown BBDB attribute"))) - (cond - ((or (not val) (equal val ""))) ; do nothing - ((memq attr '(phones addresses)) - (setq eudc-rec (append val eudc-rec))) - ((and (listp val) - (= 1 (length val))) - (setq eudc-rec (cons (cons attr (car val)) eudc-rec))) - ((> (length val) 0) - (setq eudc-rec (cons (cons attr val) eudc-rec))) - (t - (error "Unexpected attribute value")))) + eudc-rec) + (dolist (attr attrs) + (let ((val + (pcase attr + ('phones (eudc-bbdb-extract-phones record)) + ('addresses (eudc-bbdb-extract-addresses record)) + ('notes + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-xfield record 'notes) + (bbdb-record-notes record))) + ((or 'firstname 'lastname 'aka 'company 'net) + (funcall (intern + (concat "bbdb-record-" + (symbol-name (eudc-bbdb-field attr)))) + record)) + (_ + (error "Unknown BBDB attribute"))))) + (cond + ((or (not val) (equal val ""))) ; do nothing + ((memq attr '(phones addresses)) + (setq eudc-rec (append val eudc-rec))) + ((and (listp val) + (= 1 (length val))) + (push (cons attr (car val)) eudc-rec)) + ((> (length val) 0) + (push (cons attr val) eudc-rec)) + (t + (error "Unexpected attribute value"))))) (nreverse eudc-rec))) @@ -240,21 +232,20 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (while (and records (> (length query-attrs) 0)) (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs)))) (if (car query-attrs) - (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs)))) + ;; BEWARE: `bbdb-search' is a macro! + (setq records (eval `(bbdb-search records ,@bbdb-attrs) t))) (setq query-attrs (cdr query-attrs))) (mapc (lambda (record) (setq filtered (eudc-filter-duplicate-attributes record)) ;; If there were duplicate attributes reverse the order of the ;; record so the unique attributes appear first (if (> (length filtered) 1) - (setq filtered (mapcar (lambda (rec) - (reverse rec)) - filtered))) + (setq filtered (mapcar #'reverse filtered))) (setq result (append result filtered))) (delq nil - (mapcar 'eudc-bbdb-format-record-as-result + (mapcar #'eudc-bbdb-format-record-as-result (delq nil - (mapcar 'eudc-bbdb-filter-non-matching-record + (mapcar #'eudc-bbdb-filter-non-matching-record records))))) result)) diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 4623079ea9f..0aff276475e 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -1,4 +1,4 @@ -;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend +;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -38,10 +38,10 @@ ;;{{{ Internal cooking -(eval-and-compile +(defalias 'eudc-ldap-get-host-parameter (if (fboundp 'ldap-get-host-parameter) - (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter) - (defun eudc-ldap-get-host-parameter (host parameter) + #'ldap-get-host-parameter + (lambda (host parameter) "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'." (plist-get (cdr (assoc host ldap-host-parameters-alist)) parameter)))) @@ -84,7 +84,7 @@ record)) (defun eudc-filter-$ (string) - (mapconcat 'identity (split-string string "\\$") "\n")) + (mapconcat #'identity (split-string string "\\$") "\n")) (defun eudc-ldap-cleanup-record-filtering-addresses (record) "Clean up RECORD to make it suitable for EUDC. @@ -104,7 +104,7 @@ multiple addresses." (value (cdr field))) (when (and clean-up-addresses (memq name '(postaladdress registeredaddress))) - (setq value (mapcar 'eudc-filter-$ value))) + (setq value (mapcar #'eudc-filter-$ value))) (if (eq name 'mail) (setq mail-addresses (append mail-addresses value)) (push (cons name (if (cdr value) @@ -126,9 +126,9 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) eudc-server (if (listp return-attrs) - (mapcar 'symbol-name return-attrs)))) + (mapcar #'symbol-name return-attrs)))) final-result) - (setq result (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) + (setq result (mapcar #'eudc-ldap-cleanup-record-filtering-addresses result)) (if (and eudc-strict-return-matches return-attrs @@ -154,7 +154,7 @@ attribute names are returned. Default to `person'." (let ((ldap-host-parameters-alist (list (cons eudc-server '(scope subtree sizelimit 1))))) - (mapcar 'eudc-ldap-cleanup-record-filtering-addresses + (mapcar #'eudc-ldap-cleanup-record-filtering-addresses (ldap-search (eudc-ldap-format-query-as-rfc1558 (list (cons "objectclass" diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index eb7032ac4c8..732881f75a0 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -1,4 +1,4 @@ -;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend +;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el index 66a684dfc59..18c8958c160 100644 --- a/lisp/net/eudcb-macos-contacts.el +++ b/lisp/net/eudcb-macos-contacts.el @@ -1,4 +1,4 @@ -;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend +;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend -*- lexical-binding: t; -*- ;; Copyright (C) 2020-2021 Free Software Foundation, Inc. @@ -74,7 +74,7 @@ end tell" str)) "`osascript' executable not found. " "Is this is a macOS 10.0 or later system?")))) -(defun eudc-macos-contacts-query-internal (query &optional return-attrs) +(defun eudc-macos-contacts-query-internal (query &optional _return-attrs) "Query macOS Contacts with QUERY. QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid macOS Contacts attribute names. @@ -108,7 +108,7 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (defun eudc-macos-contacts-set-server (dummy) "Set the EUDC server to macOS Contacts app. The server in DUMMY is not actually used, since this backend -always and implicitly connetcs to an instance of the Contacts app +always and implicitly connects to an instance of the Contacts app running on the local host." (interactive) (eudc-set-server dummy 'macos-contacts) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index e39a4c33b20..90301e92acf 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -779,7 +779,7 @@ Currently this means either text/html or application/xhtml+xml." (propertize "...: " 'face 'variable-pitch)))) (propertize "..." 'face 'variable-pitch))))))) - (replace-regexp-in-string + (string-replace "%" "%%" (format-spec eww-header-line-format @@ -855,7 +855,7 @@ Currently this means either text/html or application/xhtml+xml." (defun eww-view-source () "View the HTML source code of the current page." - (interactive) + (interactive nil eww-mode) (let ((buf (get-buffer-create "*eww-source*")) (source (plist-get eww-data :source))) (with-current-buffer buf @@ -881,7 +881,7 @@ Currently this means either text/html or application/xhtml+xml." (defun eww-toggle-paragraph-direction () "Cycle the paragraph direction between left-to-right, right-to-left and auto." - (interactive) + (interactive nil eww-mode) (setq bidi-paragraph-direction (cond ((eq bidi-paragraph-direction 'left-to-right) nil) @@ -899,7 +899,7 @@ Currently this means either text/html or application/xhtml+xml." This command uses heuristics to find the parts of the web page that contains the main textual portion, leaving out navigation menus and the like." - (interactive) + (interactive nil eww-mode) (let* ((old-data eww-data) (dom (with-temp-buffer (insert (plist-get old-data :source)) @@ -987,6 +987,7 @@ the like." (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) @@ -1015,10 +1016,40 @@ the like." ["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)) +(defun eww-context-menu (menu) + (define-key menu [eww-separator] menu-bar-separator) + (let ((easy-menu (make-sparse-keymap "Eww"))) + (easy-menu-define nil easy-menu nil + '("Eww" + ["Back to previous page" eww-back-url + :visible (not (zerop (length eww-history)))] + ["Forward to next page" eww-forward-url + :visible (not (zerop eww-history-position))] + ["Reload" eww-reload t])) + (dolist (item (reverse (lookup-key easy-menu [menu-bar eww]))) + (when (consp item) + (define-key menu (vector (car item)) (cdr item))))) + + (when (or (mouse-posn-property (event-start last-input-event) 'shr-url) + (mouse-posn-property (event-start last-input-event) 'image-url)) + (define-key menu [shr-mouse-browse-url-new-window] + `(menu-item "Follow URL in new window" ,(if browse-url-new-window-flag + 'shr-mouse-browse-url + 'shr-mouse-browse-url-new-window) + :help "Browse the URL under the mouse cursor in a new window")) + (define-key menu [shr-mouse-browse-url] + `(menu-item "Follow URL" ,(if browse-url-new-window-flag + 'shr-mouse-browse-url-new-window + 'shr-mouse-browse-url) + :help "Browse the URL under the mouse cursor"))) + + menu) + (defvar eww-tool-bar-map (let ((map (make-sparse-keymap))) (dolist (tool-bar-item @@ -1038,9 +1069,11 @@ the like." ;;;###autoload (define-derived-mode eww-mode special-mode "eww" "Mode for browsing the web." + :interactive nil (setq-local eww-data (list :title "")) (setq-local browse-url-browser-function #'eww-browse-url) (add-hook 'after-change-functions #'eww-process-text-input nil t) + (add-hook 'context-menu-functions 'eww-context-menu 5 t) (setq-local eww-history nil) (setq-local eww-history-position 0) (when (boundp 'tool-bar-map) @@ -1090,7 +1123,7 @@ instead of `browse-url-new-window-flag'." (defun eww-back-url () "Go to the previously displayed page." - (interactive) + (interactive nil eww-mode) (when (>= eww-history-position (length eww-history)) (user-error "No previous page")) (eww-save-history) @@ -1099,7 +1132,7 @@ instead of `browse-url-new-window-flag'." (defun eww-forward-url () "Go to the next displayed page." - (interactive) + (interactive nil eww-mode) (when (zerop eww-history-position) (user-error "No next page")) (eww-save-history) @@ -1123,7 +1156,7 @@ instead of `browse-url-new-window-flag'." "Go to the page marked `next'. A page is marked `next' if rel=\"next\" appears in a <link> or <a> tag." - (interactive) + (interactive nil eww-mode) (if (plist-get eww-data :next) (eww-browse-url (shr-expand-url (plist-get eww-data :next) (plist-get eww-data :url))) @@ -1133,7 +1166,7 @@ or <a> tag." "Go to the page marked `previous'. A page is marked `previous' if rel=\"previous\" appears in a <link> or <a> tag." - (interactive) + (interactive nil eww-mode) (if (plist-get eww-data :previous) (eww-browse-url (shr-expand-url (plist-get eww-data :previous) (plist-get eww-data :url))) @@ -1143,7 +1176,7 @@ or <a> tag." "Go to the page marked `up'. A page is marked `up' if rel=\"up\" appears in a <link> or <a> tag." - (interactive) + (interactive nil eww-mode) (if (plist-get eww-data :up) (eww-browse-url (shr-expand-url (plist-get eww-data :up) (plist-get eww-data :url))) @@ -1153,7 +1186,7 @@ or <a> tag." "Go to the page marked `top'. A page is marked `top' if rel=\"start\", rel=\"home\", or rel=\"contents\" appears in a <link> or <a> tag." - (interactive) + (interactive nil eww-mode) (let ((best-url (or (plist-get eww-data :start) (plist-get eww-data :contents) (plist-get eww-data :home)))) @@ -1166,7 +1199,7 @@ appears in a <link> or <a> tag." If LOCAL is non-nil (interactively, the command was invoked with a prefix argument), don't reload the page from the network, but just re-display the HTML already fetched." - (interactive "P") + (interactive "P" eww-mode) (let ((url (plist-get eww-data :url))) (if local (if (null (plist-get eww-data :dom)) @@ -1232,12 +1265,12 @@ just re-display the HTML already fetched." (defun eww-beginning-of-text () "Move to the start of the input field." - (interactive) + (interactive nil eww-mode) (goto-char (eww-beginning-of-field))) (defun eww-end-of-text () "Move to the end of the text in the input field." - (interactive) + (interactive nil eww-mode) (goto-char (eww-end-of-field)) (let ((start (eww-beginning-of-field))) (while (and (equal (following-char) ? ) @@ -1329,7 +1362,7 @@ just re-display the HTML already fetched." (defun eww-select-file () "Change the value of the upload file menu under point." - (interactive) + (interactive nil eww-mode) (let* ((input (get-text-property (point) 'eww-form))) (let ((filename (let ((insert-default-directory t)) @@ -1537,7 +1570,9 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-change-select (event) "Change the value of the select drop-down menu under point." - (interactive (list last-nonmenu-event)) + (interactive + (list last-nonmenu-event) + eww-mode) (mouse-set-point event) (let ((input (get-text-property (point) 'eww-form))) (popup-menu @@ -1572,7 +1607,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-toggle-checkbox () "Toggle the value of the checkbox under point." - (interactive) + (interactive nil eww-mode) (let* ((input (get-text-property (point) 'eww-form)) (type (plist-get input :type))) (if (equal type "checkbox") @@ -1592,9 +1627,9 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (goto-char (car elem)) (if (not (eq (cdr elem) input)) (progn - (plist-put input :checked nil) + (plist-put (cdr elem) :checked nil) (eww-update-field eww-form-checkbox-symbol)) - (plist-put input :checked t) + (plist-put (cdr elem) :checked t) (eww-update-field eww-form-checkbox-selected-symbol))))) (forward-char 1))))) @@ -1642,7 +1677,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-submit () "Submit the current form." - (interactive) + (interactive nil eww-mode) (let* ((this-input (get-text-property (point) 'eww-form)) (form (plist-get this-input :eww-form)) values next-submit) @@ -1729,7 +1764,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") "Browse the current URL with an external browser. The browser to used is specified by the `browse-url-secondary-browser-function' variable." - (interactive) + (interactive nil eww-mode) (funcall browse-url-secondary-browser-function (or url (plist-get eww-data :url)))) @@ -1739,7 +1774,9 @@ If EXTERNAL is single prefix, browse the URL using `browse-url-secondary-browser-function'. If EXTERNAL is double prefix, browse in new buffer." - (interactive (list current-prefix-arg last-nonmenu-event)) + (interactive + (list current-prefix-arg last-nonmenu-event) + eww-mode) (mouse-set-point mouse-event) (let ((url (get-text-property (point) 'shr-url))) (cond @@ -1773,14 +1810,14 @@ Differences in #targets are ignored." (defun eww-copy-page-url () "Copy the URL of the current page into the kill ring." - (interactive) + (interactive nil eww-mode) (message "%s" (plist-get eww-data :url)) (kill-new (plist-get eww-data :url))) (defun eww-download () "Download URL to `eww-download-directory'. Use link at point if there is one, else the current page's URL." - (interactive) + (interactive nil eww-mode) (let ((dir (if (stringp eww-download-directory) eww-download-directory (funcall eww-download-directory)))) @@ -1848,14 +1885,14 @@ Use link at point if there is one, else the current page's URL." (defun eww-set-character-encoding (charset) "Set character encoding to CHARSET. If CHARSET is nil then use UTF-8." - (interactive "zUse character set (default utf-8): ") + (interactive "zUse character set (default utf-8): " eww-mode) (if (null charset) (eww-reload nil 'utf-8) (eww-reload nil charset))) (defun eww-switch-to-buffer () "Prompt for an EWW buffer to display in the selected window." - (interactive) + (interactive nil eww-mode) (let ((completion-extra-properties '(:annotation-function (lambda (buf) (with-current-buffer buf @@ -1873,7 +1910,7 @@ If CHARSET is nil then use UTF-8." (defun eww-toggle-fonts () "Toggle whether to use monospaced or font-enabled layouts." - (interactive) + (interactive nil eww-mode) (setq shr-use-fonts (not shr-use-fonts)) (eww-reload) (message "Proportional fonts are now %s" @@ -1881,20 +1918,28 @@ If CHARSET is nil then use UTF-8." (defun eww-toggle-colors () "Toggle whether to use HTML-specified colors or not." - (interactive) + (interactive nil eww-mode) (message "Colors are now %s" (if (setq shr-use-colors (not shr-use-colors)) "on" "off")) (eww-reload)) +(defun eww-toggle-images () + "Toggle whether or not to display images." + (interactive nil eww-mode) + (setq shr-inhibit-images (not shr-inhibit-images)) + (eww-reload) + (message "Images are now %s" + (if shr-inhibit-images "off" "on"))) + ;;; Bookmarks code (defvar eww-bookmarks nil) (defun eww-add-bookmark () "Bookmark the current page." - (interactive) + (interactive nil eww-mode) (eww-read-bookmarks) (dolist (bookmark eww-bookmarks) (when (equal (plist-get eww-data :url) (plist-get bookmark :url)) @@ -1958,7 +2003,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-bookmark-kill () "Kill the current bookmark." - (interactive) + (interactive nil eww-bookmark-mode) (let* ((start (line-beginning-position)) (bookmark (get-text-property start 'eww-bookmark)) (inhibit-read-only t)) @@ -1972,7 +2017,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-bookmark-yank () "Yank a previously killed bookmark to the current line." - (interactive) + (interactive nil eww-bookmark-mode) (unless eww-bookmark-kill-ring (user-error "No previously killed bookmark")) (beginning-of-line) @@ -1990,7 +2035,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-bookmark-browse () "Browse the bookmark under point in eww." - (interactive) + (interactive nil eww-bookmark-mode) (let ((bookmark (get-text-property (line-beginning-position) 'eww-bookmark))) (unless bookmark (user-error "No bookmark on the current line")) @@ -1999,7 +2044,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-next-bookmark () "Go to the next bookmark in the list." - (interactive) + (interactive nil eww-bookmark-mode) (let ((first nil) bookmark) (unless (get-buffer "*eww bookmarks*") @@ -2018,7 +2063,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-previous-bookmark () "Go to the previous bookmark in the list." - (interactive) + (interactive nil eww-bookmark-mode) (let ((first nil) bookmark) (unless (get-buffer "*eww bookmarks*") @@ -2061,6 +2106,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." "Mode for listing bookmarks. \\{eww-bookmark-mode-map}" + :interactive nil (buffer-disable-undo) (setq truncate-lines t)) @@ -2109,7 +2155,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-history-browse () "Browse the history under point in eww." - (interactive) + (interactive nil eww-history-mode) (let ((history (get-text-property (line-beginning-position) 'eww-history))) (unless history (error "No history on the current line")) @@ -2137,6 +2183,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." "Mode for listing eww-histories. \\{eww-history-mode-map}" + :interactive nil (buffer-disable-undo) (setq truncate-lines t)) @@ -2191,7 +2238,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-buffer-select () "Switch to eww buffer." - (interactive) + (interactive nil eww-buffers-mode) (let ((buffer (get-text-property (line-beginning-position) 'eww-buffer))) (unless buffer @@ -2211,7 +2258,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-buffer-show-next () "Move to next eww buffer in the list and display it." - (interactive) + (interactive nil eww-buffers-mode) (forward-line) (when (eobp) (goto-char (point-min))) @@ -2219,7 +2266,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-buffer-show-previous () "Move to previous eww buffer in the list and display it." - (interactive) + (interactive nil eww-buffers-mode) (beginning-of-line) (when (bobp) (goto-char (point-max))) @@ -2228,7 +2275,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (defun eww-buffer-kill () "Kill buffer from eww list." - (interactive) + (interactive nil eww-buffers-mode) (let* ((start (line-beginning-position)) (buffer (get-text-property start 'eww-buffer)) (inhibit-read-only t)) @@ -2262,6 +2309,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." "Mode for listing buffers. \\{eww-buffers-mode-map}" + :interactive nil (buffer-disable-undo) (setq truncate-lines t)) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index ff58cbb035e..43dd9dc15cd 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -1,10 +1,10 @@ -;;; gnutls.el --- Support SSL/TLS connections through GnuTLS +;;; gnutls.el --- Support SSL/TLS connections through GnuTLS -*- lexical-binding: t; -*- ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. ;; Author: Ted Zlatanov <tzz@lifelogs.com> ;; Keywords: comm, tls, ssl, encryption -;; Originally-By: Simon Josefsson (See http://josefsson.org/emacs-security/) +;; Originally-By: Simon Josefsson (See https://josefsson.org/emacs-security/) ;; Thanks-To: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; This file is part of GNU Emacs. @@ -59,7 +59,6 @@ general, Emacs network security is handled by the Network Security Manager (NSM), and the default value of nil delegates the job of checking the connection security to the NSM. See Info node `(emacs) Network Security'." - :group 'gnutls :type '(choice (const nil) string)) @@ -91,7 +90,6 @@ checks are performed at the gnutls level. Instead the checks are performed via `open-network-stream' at a higher level by the Network Security Manager. See Info node `(emacs) Network Security'." - :group 'gnutls :version "24.4" :type '(choice (const t) @@ -118,7 +116,6 @@ Security'." If a file path contains glob wildcards, they will be expanded. The files may be in PEM or DER format, as per the GnuTLS documentation. The files may not exist, in which case they will be ignored." - :group 'gnutls :type '(choice (function :tag "Function to produce list of bundle filenames") (repeat (file :tag "Bundle filename")))) @@ -139,7 +136,6 @@ network security is handled at a higher level via node `(emacs) Network Security'." :type '(choice (const :tag "Use default value" nil) (integer :tag "Number of bits" 2048)) - :group 'gnutls :version "27.1") (defcustom gnutls-crlfiles @@ -150,7 +146,6 @@ node `(emacs) Network Security'." If a file path contains glob wildcards, they will be expanded. The files may be in PEM or DER format, as per the GnuTLS documentation. The files may not exist, in which case they will be ignored." - :group 'gnutls :type '(choice (function :tag "Function to produce list of CRL filenames") (repeat (file :tag "CRL filename"))) :version "27.1") @@ -341,8 +336,8 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." t) ;; if a list, look for hostname matches ((listp gnutls-verify-error) - (cadr (cl-find-if #'(lambda (x) - (string-match (car x) hostname)) + (cadr (cl-find-if (lambda (x) + (string-match (car x) hostname)) gnutls-verify-error))) ;; else it's nil (t nil)))) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index d1926302470..2c43d0f7532 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -1,4 +1,4 @@ -;;; goto-addr.el --- click to browse URL or to send to e-mail address +;;; goto-addr.el --- click to browse URL or to send to e-mail address -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2000-2021 Free Software Foundation, Inc. @@ -73,19 +73,16 @@ (defcustom goto-address-fontify-p t "Non-nil means URLs and e-mail addresses in buffer are fontified. But only if `goto-address-highlight-p' is also non-nil." - :type 'boolean - :group 'goto-address) + :type 'boolean) (defcustom goto-address-highlight-p t "Non-nil means URLs and e-mail addresses in buffer are highlighted." - :type 'boolean - :group 'goto-address) + :type 'boolean) (defcustom goto-address-fontify-maximum-size 30000 "Maximum size of file in which to fontify and/or highlight URLs. A value of t means there is no limit--fontify regardless of the size." - :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t)) - :group 'goto-address) + :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t))) (defvar goto-address-mail-regexp ;; Actually pretty much any char could appear in the username part. -stef @@ -122,30 +119,34 @@ will have no effect.") (defvar goto-address-highlight-keymap (let ((m (make-sparse-keymap))) - (define-key m (kbd "<mouse-2>") 'goto-address-at-point) - (define-key m (kbd "C-c RET") 'goto-address-at-point) + (define-key m (kbd "<mouse-2>") #'goto-address-at-point) + (define-key m (kbd "C-c RET") #'goto-address-at-point) m) "Keymap to hold goto-addr's mouse key defs under highlighted URLs.") +(defun goto-address-context-menu (menu) + (when (mouse-posn-property (event-start last-input-event) 'goto-address) + (define-key menu [goto-address-separator] menu-bar-separator) + (define-key menu [goto-address-at-mouse] + '(menu-item "Follow Link" goto-address-at-mouse + :help "Follow a link where you click"))) + menu) + (defcustom goto-address-url-face 'link "Face to use for URLs." - :type 'face - :group 'goto-address) + :type 'face) (defcustom goto-address-url-mouse-face 'highlight "Face to use for URLs when the mouse is on them." - :type 'face - :group 'goto-address) + :type 'face) (defcustom goto-address-mail-face 'italic "Face to use for e-mail addresses." - :type 'face - :group 'goto-address) + :type 'face) (defcustom goto-address-mail-mouse-face 'secondary-selection "Face to use for e-mail addresses when the mouse is on them." - :type 'face - :group 'goto-address) + :type 'face) (defun goto-address-unfontify (start end) "Remove `goto-address' fontification from the given region." @@ -252,6 +253,11 @@ address. If no e-mail address found, return nil." (goto-char (match-beginning 0)))) (match-string-no-properties 0))) +(defun goto-address-at-mouse (click) + "Send to the e-mail address or load the URL at mouse click." + (interactive "e") + (goto-address-at-point click)) + ;;;###autoload (defun goto-address () "Sets up goto-address functionality in the current buffer. @@ -270,15 +276,17 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and ;;;###autoload (define-minor-mode goto-address-mode "Minor mode to buttonize URLs and e-mail addresses in the current buffer." - nil - "" - nil - (if goto-address-mode - (jit-lock-register #'goto-address-fontify-region) + :lighter "" + (cond + (goto-address-mode + (jit-lock-register #'goto-address-fontify-region) + (add-hook 'context-menu-functions 'goto-address-context-menu 10 t)) + (t (jit-lock-unregister #'goto-address-fontify-region) (save-restriction (widen) - (goto-address-unfontify (point-min) (point-max))))) + (goto-address-unfontify (point-min) (point-max))) + (remove-hook 'context-menu-functions 'goto-address-context-menu t)))) (defun goto-addr-mode--turn-on () (when (not goto-address-mode) @@ -287,15 +295,12 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and ;;;###autoload (define-globalized-minor-mode global-goto-address-mode goto-address-mode goto-addr-mode--turn-on - :group 'goto-address :version "28.1") ;;;###autoload (define-minor-mode goto-address-prog-mode "Like `goto-address-mode', but only for comments and strings." - nil - "" - nil + :lighter "" (if goto-address-prog-mode (jit-lock-register #'goto-address-fontify-region) (jit-lock-unregister #'goto-address-fontify-region) diff --git a/lisp/net/imap.el b/lisp/net/imap.el index 052ef292957..6ca76f1f994 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -160,7 +160,6 @@ %l with the value of `imap-default-user'. The program should accept IMAP commands on stdin and return responses to stdout. Each entry in the list is tried until a successful connection is made." - :group 'imap :type '(repeat string)) (defcustom imap-gssapi-program (list @@ -173,7 +172,6 @@ the list is tried until a successful connection is made." %l with the value of `imap-default-user'. The program should accept IMAP commands on stdin and return responses to stdout. Each entry in the list is tried until a successful connection is made." - :group 'imap :type '(repeat string)) (defcustom imap-shell-program '("ssh %s imapd" @@ -186,7 +184,6 @@ number on server, %g with `imap-shell-host', and %l with `imap-default-user'. The program should read IMAP commands from stdin and write IMAP response to stdout. Each entry in the list is tried until a successful connection is made." - :group 'imap :type '(repeat string)) (defcustom imap-process-connection-type nil @@ -198,7 +195,6 @@ system has no ptys or if all ptys are busy: then a pipe is used in any case. The value takes effect when an IMAP server is opened; changing it after that has no effect." :version "22.1" - :group 'imap :type 'boolean) (defcustom imap-use-utf7 t @@ -206,7 +202,6 @@ opened; changing it after that has no effect." Since the UTF7 decoding currently only decodes into ISO-8859-1 characters, you may disable this decoding if you need to access UTF7 encoded mailboxes which doesn't translate into ISO-8859-1." - :group 'imap :type 'boolean) (defcustom imap-log nil @@ -217,7 +212,6 @@ It is not written to disk, however. Do not enable this variable unless you are comfortable with that. See also `imap-debug'." - :group 'imap :type 'boolean) (defcustom imap-debug nil @@ -232,17 +226,14 @@ variable unless you are comfortable with that. This variable only takes effect when loading the `imap' library. See also `imap-log'." - :group 'imap :type 'boolean) (defcustom imap-shell-host "gateway" "Hostname of rlogin proxy." - :group 'imap :type 'string) (defcustom imap-default-user (user-login-name) "Default username to use." - :group 'imap :type 'string) (defcustom imap-read-timeout (if (memq system-type '(windows-nt cygwin)) @@ -250,12 +241,10 @@ See also `imap-log'." 0.1) "How long to wait between checking for the end of output. Shorter values mean quicker response, but is more CPU intensive." - :type 'number - :group 'imap) + :type 'number) (defcustom imap-store-password nil "If non-nil, store session password without prompting." - :group 'imap :type 'boolean) ;;; Various variables @@ -737,9 +726,9 @@ sure of changing the value of `foo'." :end-of-command "\r\n" :success "^1 OK " :starttls-function - #'(lambda (capabilities) - (when (string-match-p "STARTTLS" capabilities) - "1 STARTTLS\r\n")))) + (lambda (capabilities) + (when (string-match-p "STARTTLS" capabilities) + "1 STARTTLS\r\n")))) done) (when process (imap-log buffer) @@ -987,8 +976,8 @@ t if it successfully authenticates, nil otherwise." "imap" buffer imap-server imap-port) ((error quit) nil))) (when imap-process - (set-process-filter imap-process 'imap-arrival-filter) - (set-process-sentinel imap-process 'imap-sentinel) + (set-process-filter imap-process #'imap-arrival-filter) + (set-process-sentinel imap-process #'imap-sentinel) (while (and (eq imap-state 'initial) (memq (process-status imap-process) '(open run))) (message "Waiting for response from %s..." imap-server) @@ -1012,7 +1001,7 @@ necessary. If nil, the buffer name is generated." (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) - (mapc 'make-local-variable imap-local-variables) + (mapc #'make-local-variable imap-local-variables) (set-buffer-multibyte nil) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -1034,7 +1023,7 @@ necessary. If nil, the buffer name is generated." ;; Stream changed? (if (not (eq imap-default-stream stream)) (with-current-buffer (generate-new-buffer " *temp*") - (mapc 'make-local-variable imap-local-variables) + (mapc #'make-local-variable imap-local-variables) (set-buffer-multibyte nil) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -1078,7 +1067,6 @@ necessary. If nil, the buffer name is generated." "If non-nil, check if IMAP is open. See the function `imap-ping-server'." :version "23.1" ;; No Gnus - :group 'imap :type 'boolean) (defun imap-opened (&optional buffer) @@ -1346,16 +1334,16 @@ If BUFFER is nil the current buffer is assumed." (when imap-current-mailbox (if asynch (imap-add-callback (imap-send-command "CLOSE") - `(lambda (tag status) - (message "IMAP mailbox `%s' closed... %s" - imap-current-mailbox status) - (when (eq ,imap-current-mailbox - imap-current-mailbox) - ;; Don't wipe out data if another mailbox - ;; was selected... - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth)))) + (let ((cmb imap-current-mailbox)) + (lambda (_tag status) + (message "IMAP mailbox `%s' closed... %s" + imap-current-mailbox status) + (when (eq cmb imap-current-mailbox) + ;; Don't wipe out data if another mailbox + ;; was selected... + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth))))) (when (imap-ok-p (imap-send-command-wait "CLOSE")) (setq imap-current-mailbox nil imap-message-data nil @@ -1740,8 +1728,8 @@ See `imap-enable-exchange-bug-workaround'." (prog1 (and (imap-fetch-safe '("*" . "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) - (apply 'max (imap-message-map - (lambda (uid _prop) uid) 'UID)))) + (apply #'max (imap-message-map + (lambda (uid _prop) uid) 'UID)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) (imap-mailbox-unselect))))))) @@ -1786,7 +1774,7 @@ first element. The rest of list contains the saved articles' UIDs." (prog1 (and (imap-fetch-safe '("*" . "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) - (apply 'max (imap-message-map + (apply #'max (imap-message-map (lambda (uid _prop) uid) 'UID)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) @@ -1820,7 +1808,7 @@ on failure." (numberp (nth 9 body))) (nth 9 body)) (t 0)) - (apply '+ (mapcar 'imap-body-lines body))) + (apply #'+ (mapcar #'imap-body-lines body))) 0)) (defun imap-envelope-from (from) @@ -2424,7 +2412,7 @@ Return nil if no complete line has arrived." (buffer-substring (point) (1- (re-search-forward "[] ]" nil t))))) (if (eq (char-before) ? ) (prog1 - (mapconcat 'identity (cons section (imap-parse-header-list)) " ") + (mapconcat #'identity (cons section (imap-parse-header-list)) " ") (search-forward "]" nil t)) section))) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index 0476835ebd9..7997bf3c90b 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -1,4 +1,4 @@ -;;; ldap.el --- client interface to LDAP for Emacs +;;; ldap.el --- client interface to LDAP for Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -418,12 +418,12 @@ RFC2798 Section 9.1.1") (encode-coding-string str ldap-coding-system)) (defun ldap-decode-address (str) - (mapconcat 'ldap-decode-string + (mapconcat #'ldap-decode-string (split-string str "\\$") "\n")) (defun ldap-encode-address (str) - (mapconcat 'ldap-encode-string + (mapconcat #'ldap-encode-string (split-string str "\n") "$")) @@ -601,7 +601,7 @@ an alist of attribute/value pairs." (sizelimit (plist-get search-plist 'sizelimit)) (withdn (plist-get search-plist 'withdn)) (numres 0) - arglist dn name value record result proc) + arglist dn name value record result) (if (or (null filter) (equal "" filter)) (error "No search filter")) @@ -671,7 +671,7 @@ an alist of attribute/value pairs." " bind distinguished name (binddn)")) (error "Failed ldapsearch invocation: %s \"%s\"" ldap-ldapsearch-prog - (mapconcat 'identity proc-args "\" \"")))))) + (mapconcat #'identity proc-args "\" \"")))))) (apply #'call-process ldap-ldapsearch-prog ;; Ignore stderr, which can corrupt results nil (list buf nil) nil diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index b95cd0febcd..5473ba7e697 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -332,7 +332,7 @@ whose car is a symbol, it is `eval'uated to yield the validity. If it is a string or list of strings, it represents a shell command to run to return a true or false shell value for the validity. -The last matching entry in this structure takes presedence over +The last matching entry in this structure takes precedence over preceding entries.") (put 'mailcap-mime-data 'risky-local-variable t) @@ -1075,7 +1075,7 @@ For instance, \"foo.png\" will result in \"image/png\"." (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) (setq type (cdr (assq 'type (cdr info)))) - (unless (string-match-p "\\*" type) + (unless (string-search "*" type) (push type res)))) (nreverse res))))) @@ -1156,6 +1156,46 @@ current buffer after passing its contents to the shell command." (mailcap--async-shell method file)) (funcall method)))) +(defun mailcap-view-file (file) + "View FILE according to rules given by the mailcap system. +This normally involves executing some external program to display +the file. + +See \"~/.mailcap\", `mailcap-mime-data' and related files and variables." + (interactive "fOpen file with mailcap: ") + (setq file (expand-file-name file)) + (mailcap-parse-mailcaps) + (let ((command (mailcap-mime-info + (mailcap-extension-to-mime (file-name-extension file))))) + (unless command + (error "No viewer for %s" (file-name-extension file))) + ;; Remove quotes around the file name - we'll use shell-quote-argument. + (while (string-match "['\"]%s['\"]" command) + (setq command (replace-match "%s" t t command))) + (setq command (replace-regexp-in-string + "%s" + (shell-quote-argument (convert-standard-filename file)) + command + nil t)) + ;; Handlers such as "gio open" and kde-open5 start viewer in background + ;; and exit immediately. Avoid `start-process' since it assumes + ;; :connection-type `pty' and kills children processes with SIGHUP + ;; when temporary terminal session is finished (Bug#44824). + ;; An alternative is `process-connection-type' let-bound to nil for + ;; `start-process-shell-command' call (with no chance to report failure). + (make-process + :name "mailcap-view-file" + :connection-type 'pipe + :buffer nil ; "*Messages*" may be suitable for debugging + :sentinel (lambda (proc event) + (when (and (memq (process-status proc) '(exit signal)) + (/= (process-exit-status proc) 0)) + (message + "Command %s: %s." + (mapconcat #'identity (process-command proc) " ") + (substring event 0 -1)))) + :command (list shell-file-name shell-command-switch command)))) + (provide 'mailcap) ;;; mailcap.el ends here diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el index 08edb44275c..727aa55de58 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -1,4 +1,4 @@ -;;; mairix.el --- Mairix interface for Emacs +;;; mairix.el --- Mairix interface for Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -83,55 +83,46 @@ (defcustom mairix-file-path "~/" "Path where output files produced by Mairix should be stored." - :type 'directory - :group 'mairix) + :type 'directory) (defcustom mairix-search-file "mairixsearch.mbox" "Name of the default file for storing the searches. Note that this will be prefixed by `mairix-file-path'." - :type 'string - :group 'mairix) + :type 'string) (defcustom mairix-command "mairix" "Command for calling mairix. You can add further options here if you want to, but better use `mairix-update-options' instead." - :type 'string - :group 'mairix) + :type 'string) (defcustom mairix-output-buffer "*mairix output*" "Name of the buffer for the output of the mairix binary." - :type 'string - :group 'mairix) + :type 'string) (defcustom mairix-customize-query-buffer "*mairix query*" "Name of the buffer for customizing a search query." - :type 'string - :group 'mairix) + :type 'string) (defcustom mairix-saved-searches-buffer "*mairix searches*" "Name of the buffer for displaying saved searches." - :type 'string - :group 'mairix) + :type 'string) (defcustom mairix-update-options '("-F" "-Q") "Options when calling mairix for updating the database. The default is \"-F\" and \"-Q\" for making updates faster. You should call mairix without these options from time to time (e.g. via cron job)." - :type '(repeat string) - :group 'mairix) + :type '(repeat string)) (defcustom mairix-search-options '("-Q") "Options when calling mairix for searching. The default is \"-Q\" for making searching faster." - :type '(repeat string) - :group 'mairix) + :type '(repeat string)) (defcustom mairix-synchronous-update nil "Defines if Emacs should wait for the mairix database update." - :type 'boolean - :group 'mairix) + :type 'boolean) (defcustom mairix-saved-searches nil "Saved mairix searches. @@ -144,8 +135,7 @@ threads (nil or t). Note that the file will be prefixed by (choice :tag "File" (const :tag "default") file) - (boolean :tag "Threads"))) - :group 'mairix) + (boolean :tag "Threads")))) (defcustom mairix-mail-program 'rmail "Mail program used to display search results. @@ -153,8 +143,7 @@ Currently RMail, Gnus (mbox), and VM are supported. If you use Gnus with maildir, use nnmairix.el instead." :type '(choice (const :tag "RMail" rmail) (const :tag "Gnus mbox" gnus) - (const :tag "VM" vm)) - :group 'mairix) + (const :tag "VM" vm))) (defcustom mairix-display-functions '((rmail mairix-rmail-display) @@ -166,8 +155,7 @@ This is an alist where each entry consists of a symbol from displaying the search results. The function will be called with the mailbox file produced by mairix as the single argument." :type '(repeat (list (symbol :tag "Mail program") - (function))) - :group 'mairix) + (function)))) (defcustom mairix-get-mail-header-functions '((rmail mairix-rmail-fetch-field) @@ -184,15 +172,13 @@ won't work." :type '(repeat (list (symbol :tag "Mail program") (choice :tag "Header function" (const :tag "none") - function))) - :group 'mairix) + function)))) (defcustom mairix-widget-select-window-function (lambda () (select-window (get-largest-window))) "Function for selecting the window for customizing the mairix query. The default chooses the largest window in the current frame." - :type 'function - :group 'mairix) + :type 'function) ;; Other variables @@ -342,6 +328,7 @@ Currently there are `threads' and `flags'.") ;;;; Main interactive functions +;;;###autoload (defun mairix-search (search threads) "Call Mairix with SEARCH. If THREADS is non-nil, also display whole threads of found @@ -356,6 +343,7 @@ messages. Results will be put into the default search file." threads) (mairix-show-folder mairix-search-file))) +;;;###autoload (defun mairix-use-saved-search () "Use a saved search for querying Mairix." (interactive) @@ -388,6 +376,7 @@ Overwrite existing entry? ") (setcdr (assoc name mairix-saved-searches) mairix-last-search)))) (mairix-select-save)) +;;;###autoload (defun mairix-edit-saved-searches-customize () "Edit the list of saved searches in a customization buffer." (interactive) @@ -400,6 +389,8 @@ in your .emacs by pressing `Save for Future Sessions'.\n" (make-string 65 ?=) "\n"))) (autoload 'mail-strip-quoted-names "mail-utils") + +;;;###autoload (defun mairix-search-from-this-article (threads) "Search messages from sender of the current article. This is effectively a shortcut for calling `mairix-search' with @@ -416,6 +407,7 @@ threads." threads) (error "No function for obtaining mail header specified")))) +;;;###autoload (defun mairix-search-thread-this-article () "Search thread for the current article. This is effectively a shortcut for calling `mairix-search' @@ -430,19 +422,21 @@ with m:msgid of the current article and enabled threads." (while (string-match "[<>]" mid) (setq mid (replace-match "" t t mid))) ;; mairix somehow does not like '$' in message-id - (when (string-match "\\$" mid) + (when (string-search "$" mid) (setq mid (concat mid "="))) (while (string-match "\\$" mid) (setq mid (replace-match "=," t t mid))) (mairix-search (format "m:%s" mid) t))) +;;;###autoload (defun mairix-widget-search-based-on-article () "Create mairix query based on current article using widgets." (interactive) (mairix-widget-search (mairix-widget-get-values))) +;;;###autoload (defun mairix-edit-saved-searches () "Edit current mairix searches." (interactive) @@ -455,6 +449,7 @@ with m:msgid of the current article and enabled threads." (defvar mairix-widgets) +;;;###autoload (defun mairix-widget-search (&optional mvalues) "Create mairix query interactively using graphical widgets. MVALUES may contain values from current article." @@ -466,24 +461,25 @@ MVALUES may contain values from current article." ;; generate Buttons (widget-create 'push-button :notify - (lambda (&rest ignore) + (lambda (&rest _) (mairix-widget-send-query mairix-widgets)) "Send Query") (widget-insert " ") (widget-create 'push-button :notify - (lambda (&rest ignore) + (lambda (&rest _) (mairix-widget-save-search mairix-widgets)) "Save search") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _) (kill-buffer mairix-customize-query-buffer)) "Cancel") (use-local-map widget-keymap) (widget-setup) (goto-char (point-min))) +;;;###autoload (defun mairix-update-database () "Call mairix for updating the database for SERVERS. Mairix will be called asynchronously unless @@ -502,7 +498,7 @@ Mairix will be called asynchronously unless (cdr commandsplit) mairix-update-options)) (setq args (append args mairix-update-options))) - (apply 'call-process args)) + (apply #'call-process args)) (progn (message "Updating mairix database...") (setq args (append (list "mairixupdate" (get-buffer-create mairix-output-buffer) @@ -511,8 +507,8 @@ Mairix will be called asynchronously unless (setq args (append args (cdr commandsplit) mairix-update-options)) (setq args (append args mairix-update-options))) (set-process-sentinel - (apply 'start-process args) - 'mairix-sentinel-mairix-update-finished))))) + (apply #'start-process args) + #'mairix-sentinel-mairix-update-finished))))) ;;;; Helper functions @@ -535,8 +531,11 @@ The mail program is given by `mairix-mail-program'." If FILE is nil, use default. If THREADS is non-nil, also return whole threads. Function returns t if messages were found." (let* ((commandsplit (split-string mairix-command)) - (args (cons (car commandsplit) - `(nil ,(get-buffer-create mairix-output-buffer) nil))) + (args (cons + (car commandsplit) + (append + `(nil ,(get-buffer-create mairix-output-buffer) nil) + mairix-search-options))) rval) (with-current-buffer mairix-output-buffer (erase-buffer)) @@ -557,7 +556,7 @@ whole threads. Function returns t if messages were found." mairix-file-path)) file)) (setq rval - (apply 'call-process + (apply #'call-process (append args (list "-o" file) query))) (if (zerop rval) (with-current-buffer mairix-output-buffer @@ -582,7 +581,7 @@ whole threads. Function returns t if messages were found." (setq header (replace-match "," t t header))) header)) -(defun mairix-sentinel-mairix-update-finished (proc status) +(defun mairix-sentinel-mairix-update-finished (_proc status) "Sentinel for mairix update process PROC with STATUS." (if (equal status "finished\n") (message "Updating mairix database... done") @@ -642,51 +641,50 @@ See %s for details" mairix-output-buffer))) (when (not (zerop (length flag))) (push (concat "F:" flag) query))) ;; return query string - (mapconcat 'identity query " "))) + (mapconcat #'identity query " "))) (defun mairix-widget-create-query (&optional values) "Create widgets for creating mairix queries. Fill in VALUES if based on an article." - (let (allwidgets) - (when (get-buffer mairix-customize-query-buffer) - (kill-buffer mairix-customize-query-buffer)) - (switch-to-buffer mairix-customize-query-buffer) - (kill-all-local-variables) - (erase-buffer) - (widget-insert - "Specify your query for Mairix using check boxes for activating fields.\n\n") - (widget-insert - (concat "Use ~word to match messages " - (propertize "not" 'face 'italic) - " containing the word)\n" - " substring= to match words containing the substring\n" - " substring=N to match words containing the substring, allowing\n" - " up to N errors(missing/extra/different letters)\n" - " ^substring= to match the substring at the beginning of a word.\n")) - (widget-insert - (format-message - "Whitespace will be converted to `,' (i.e. AND). Use `/' for OR.\n\n")) - (setq mairix-widgets (mairix-widget-build-editable-fields values)) - (when (member 'flags mairix-widget-other) - (widget-insert "\nFlags:\n Seen: ") - (mairix-widget-add "seen" - 'menu-choice - :value "ignore" - '(item "yes") '(item "no") '(item "ignore")) - (widget-insert " Replied: ") - (mairix-widget-add "replied" - 'menu-choice - :value "ignore" - '(item "yes") '(item "no") '(item "ignore")) - (widget-insert " Ticked: ") - (mairix-widget-add "flagged" - 'menu-choice - :value "ignore" - '(item "yes") '(item "no") '(item "ignore"))) - (when (member 'threads mairix-widget-other) - (widget-insert "\n") - (mairix-widget-add "Threads" 'checkbox nil)) - (widget-insert " Show full threads\n\n"))) + (when (get-buffer mairix-customize-query-buffer) + (kill-buffer mairix-customize-query-buffer)) + (switch-to-buffer mairix-customize-query-buffer) + (kill-all-local-variables) + (erase-buffer) + (widget-insert + "Specify your query for Mairix using check boxes for activating fields.\n\n") + (widget-insert + (concat "Use ~word to match messages " + (propertize "not" 'face 'italic) + " containing the word)\n" + " substring= to match words containing the substring\n" + " substring=N to match words containing the substring, allowing\n" + " up to N errors(missing/extra/different letters)\n" + " ^substring= to match the substring at the beginning of a word.\n")) + (widget-insert + (format-message + "Whitespace will be converted to `,' (i.e. AND). Use `/' for OR.\n\n")) + (setq mairix-widgets (mairix-widget-build-editable-fields values)) + (when (member 'flags mairix-widget-other) + (widget-insert "\nFlags:\n Seen: ") + (mairix-widget-add "seen" + 'menu-choice + :value "ignore" + '(item "yes") '(item "no") '(item "ignore")) + (widget-insert " Replied: ") + (mairix-widget-add "replied" + 'menu-choice + :value "ignore" + '(item "yes") '(item "no") '(item "ignore")) + (widget-insert " Ticked: ") + (mairix-widget-add "flagged" + 'menu-choice + :value "ignore" + '(item "yes") '(item "no") '(item "ignore"))) + (when (member 'threads mairix-widget-other) + (widget-insert "\n") + (mairix-widget-add "Threads" 'checkbox nil)) + (widget-insert " Show full threads\n\n")) (defun mairix-widget-build-editable-fields (values) "Build editable field widgets in `nnmairix-widget-fields-list'. @@ -703,7 +701,7 @@ VALUES may contain values for editable fields from current article." (concat "c" field) (widget-create 'checkbox :tag field - :notify (lambda (widget &rest ignore) + :notify (lambda (widget &rest _ignore) (mairix-widget-toggle-activate widget)) nil))) (list @@ -727,7 +725,7 @@ VALUES may contain values for editable fields from current article." "Add a widget NAME with optional ARGS." (push (list name - (apply 'widget-create args)) + (apply #'widget-create args)) mairix-widgets)) (defun mairix-widget-toggle-activate (widget) diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index d5aad3a3f77..90cca7d415c 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -1,4 +1,4 @@ -;;; net-utils.el --- network functions +;;; net-utils.el --- network functions -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -67,17 +67,14 @@ "tracert" "traceroute") "Program to trace network hops to a destination." - :group 'net-utils :type 'string) (defcustom traceroute-program-options nil "Options for the traceroute program." - :group 'net-utils :type '(repeat string)) (defcustom ping-program "ping" "Program to send network test packets to a host." - :group 'net-utils :type 'string) ;; On GNU/Linux and Irix, the system's ping program seems to send packets @@ -87,7 +84,6 @@ (list "-c" "4")) "Options for the ping program. These options can be used to limit how many ICMP packets are emitted." - :group 'net-utils :type '(repeat string)) (defcustom ifconfig-program @@ -98,7 +94,6 @@ These options can be used to limit how many ICMP packets are emitted." (t "ip")) "Program to print network configuration information." :version "25.1" ; add ip - :group 'net-utils :type 'string) (defcustom ifconfig-program-options @@ -108,7 +103,6 @@ These options can be used to limit how many ICMP packets are emitted." "Options for the ifconfig program." :version "25.1" :set-after '(ifconfig-program) - :group 'net-utils :type '(repeat string)) (defcustom iwconfig-program @@ -116,7 +110,6 @@ These options can be used to limit how many ICMP packets are emitted." ((net-utils--executable-find-sbin "iw") "iw") (t "iw")) "Program to print wireless network configuration information." - :group 'net-utils :type 'string :version "26.1") @@ -124,7 +117,6 @@ These options can be used to limit how many ICMP packets are emitted." (cond ((string-match-p "iw\\'" iwconfig-program) (list "dev")) (t nil)) "Options for the iwconfig program." - :group 'net-utils :type '(repeat string) :version "26.1") @@ -133,25 +125,21 @@ These options can be used to limit how many ICMP packets are emitted." ((net-utils--executable-find-sbin "ss")) (t "ss")) "Program to print network statistics." - :group 'net-utils :type 'string :version "26.1") (defcustom netstat-program-options (list "-a") "Options for the netstat program." - :group 'net-utils :type '(repeat string)) (defcustom arp-program (or (net-utils--executable-find-sbin "arp") "arp") "Program to print IP to address translation tables." - :group 'net-utils :type 'string) (defcustom arp-program-options (list "-a") "Options for the arp program." - :group 'net-utils :type '(repeat string)) (defcustom route-program @@ -162,7 +150,6 @@ These options can be used to limit how many ICMP packets are emitted." ((net-utils--executable-find-sbin "ip")) (t "ip")) "Program to print routing tables." - :group 'net-utils :type 'string :version "26.1") @@ -171,18 +158,15 @@ These options can be used to limit how many ICMP packets are emitted." ((string-match-p "netstat\\'" route-program) (list "-r")) (t (list "route"))) "Options for the route program." - :group 'net-utils :type '(repeat string) :version "26.1") (defcustom nslookup-program "nslookup" "Program to interactively query DNS information." - :group 'net-utils :type 'string) (defcustom nslookup-program-options nil "Options for the nslookup program." - :group 'net-utils :type '(repeat string)) (defcustom nslookup-prompt-regexp "^> " @@ -190,28 +174,23 @@ These options can be used to limit how many ICMP packets are emitted." This variable is only used if the variable `comint-use-prompt-regexp' is non-nil." - :group 'net-utils :type 'regexp) (defcustom dig-program "dig" "Program to query DNS information." - :group 'net-utils :type 'string) (defcustom dig-program-options nil "Options for the dig program." - :group 'net-utils :type '(repeat string) :version "26.1") (defcustom ftp-program "ftp" "Program to run to do FTP transfers." - :group 'net-utils :type 'string) (defcustom ftp-program-options nil "Options for the ftp program." - :group 'net-utils :type '(repeat string)) (defcustom ftp-prompt-regexp "^ftp>" @@ -219,17 +198,14 @@ This variable is only used if the variable This variable is only used if the variable `comint-use-prompt-regexp' is non-nil." - :group 'net-utils :type 'regexp) (defcustom smbclient-program "smbclient" "Smbclient program." - :group 'net-utils :type 'string) (defcustom smbclient-program-options nil "Options for the smbclient program." - :group 'net-utils :type '(repeat string)) (defcustom smbclient-prompt-regexp "^smb: >" @@ -237,17 +213,14 @@ This variable is only used if the variable This variable is only used if the variable `comint-use-prompt-regexp' is non-nil." - :group 'net-utils :type 'regexp) (defcustom dns-lookup-program "host" "Program to interactively query DNS information." - :group 'net-utils :type 'string) (defcustom dns-lookup-program-options nil "Options for the dns-lookup program." - :group 'net-utils :type '(repeat string)) ;; Internal variables @@ -265,7 +238,7 @@ This variable is only used if the variable 1 'font-lock-keyword-face) ;; Dotted quads (list - (mapconcat 'identity + (mapconcat #'identity (make-list 4 "[0-9]+") "\\.") 0 'font-lock-variable-name-face) @@ -273,7 +246,7 @@ This variable is only used if the variable (list (let ((host-expression "[-A-Za-z0-9]+")) (concat - (mapconcat 'identity + (mapconcat #'identity (make-list 2 host-expression) "\\.") "\\(\\." host-expression "\\)*")) @@ -288,7 +261,7 @@ This variable is only used if the variable (list ;; Dotted quads (list - (mapconcat 'identity (make-list 4 "[0-9]+") "\\.") + (mapconcat #'identity (make-list 4 "[0-9]+") "\\.") 0 'font-lock-variable-name-face) ;; Simple rfc4291 addresses (list (concat @@ -300,7 +273,7 @@ This variable is only used if the variable (list (let ((host-expression "[-A-Za-z0-9]+")) (concat - (mapconcat 'identity (make-list 2 host-expression) "\\.") + (mapconcat #'identity (make-list 2 host-expression) "\\.") "\\(\\." host-expression "\\)*")) 0 'font-lock-variable-name-face)) "Expressions to font-lock for general network utilities.") @@ -371,8 +344,8 @@ This variable is only used if the variable (erase-buffer) (insert header "\n") (set-process-filter - (apply 'start-process name buf program args) - 'net-utils-remove-ctrl-m-filter) + (apply #'start-process name buf program args) + #'net-utils-remove-ctrl-m-filter) (display-buffer buf) buf)) @@ -390,27 +363,27 @@ This variable is only used if the variable (when proc (set-process-filter proc nil) (delete-process proc))) - (let ((inhibit-read-only t) - (coding-system-for-read - ;; MS-Windows versions of network utilities output text - ;; encoded in the console (a.k.a. "OEM") codepage, which is - ;; different from the default system (a.k.a. "ANSI") - ;; codepage. - (if (eq system-type 'windows-nt) - (intern (format "cp%d" (w32-get-console-output-codepage))) - coding-system-for-read))) + (let ((inhibit-read-only t)) (erase-buffer)) (net-utils-mode) (setq-local net-utils--revert-cmd `(net-utils-run-simple ,(current-buffer) ,program-name ,args nodisplay)) - (set-process-filter - (apply 'start-process program-name - (current-buffer) program-name args) - 'net-utils-remove-ctrl-m-filter) + (let ((coding-system-for-read + ;; MS-Windows versions of network utilities output text + ;; encoded in the console (a.k.a. "OEM") codepage, which is + ;; different from the default system (a.k.a. "ANSI") + ;; codepage. + (if (eq system-type 'windows-nt) + (intern (format "cp%d" (w32-get-console-output-codepage))) + coding-system-for-read))) + (set-process-filter + (apply #'start-process program-name + (current-buffer) program-name args) + #'net-utils-remove-ctrl-m-filter)) (unless nodisplay (display-buffer (current-buffer))))) -(defun net-utils--revert-function (&optional ignore-auto noconfirm) +(defun net-utils--revert-function (&optional _ignore-auto _noconfirm) (message "Reverting `%s'..." (buffer-name)) (apply (car net-utils--revert-cmd) (cdr net-utils--revert-cmd)) (let ((proc (get-buffer-process (current-buffer)))) @@ -430,7 +403,7 @@ This variable is only used if the variable ifconfig-program ifconfig-program-options)) -(defalias 'ipconfig 'ifconfig) +(defalias 'ipconfig #'ifconfig) ;;;###autoload (defun iwconfig () @@ -532,7 +505,7 @@ in Lisp code." (net-utils-run-program "Nslookup" (concat "** " - (mapconcat 'identity + (mapconcat #'identity (list "Nslookup" host nslookup-program) " ** ")) nslookup-program @@ -618,7 +591,7 @@ This command uses `nslookup-program' to look up DNS records." (defvar nslookup-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\t" 'completion-at-point) + (define-key map "\t" #'completion-at-point) map)) ;; Using a derived mode gives us keymaps, hooks, etc. @@ -646,9 +619,9 @@ This command uses `dns-lookup-program' for looking up the DNS information." (net-utils-run-program (concat "DNS Lookup [" host "]") (concat "** " - (mapconcat 'identity - (list "DNS Lookup" host dns-lookup-program) - " ** ")) + (mapconcat #'identity + (list "DNS Lookup" host dns-lookup-program) + " ** ")) dns-lookup-program options))) @@ -669,13 +642,14 @@ This command uses `dig-program' for looking up the DNS information." (net-utils-run-program "Dig" (concat "** " - (mapconcat 'identity + (mapconcat #'identity (list "Dig" host dig-program) " ** ")) dig-program options))) (autoload 'comint-exec "comint") +(declare-function comint-watch-for-password-prompt "comint" (string)) ;; This is a lot less than ange-ftp, but much simpler. ;;;###autoload @@ -697,7 +671,7 @@ This command uses `dig-program' for looking up the DNS information." (defvar ftp-mode-map (let ((map (make-sparse-keymap))) ;; Occasionally useful - (define-key map "\t" 'completion-at-point) + (define-key map "\t" #'completion-at-point) map)) (define-derived-mode ftp-mode comint-mode "FTP" @@ -710,9 +684,9 @@ This command uses `dig-program' for looking up the DNS information." ;; password prompts will probably immediately follow the initial ;; connection), but it's better than getting prompted twice for the ;; same password. - (unless (memq 'comint-watch-for-password-prompt + (unless (memq #'comint-watch-for-password-prompt (default-value 'comint-output-filter-functions)) - (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt + (add-hook 'comint-output-filter-functions #'comint-watch-for-password-prompt nil t))) (defun smbclient (host service) @@ -759,9 +733,9 @@ This command uses `smbclient-program' to connect to HOST." ;; password prompts will probably immediately follow the initial ;; connection), but it's better than getting prompted twice for the ;; same password. - (unless (memq 'comint-watch-for-password-prompt + (unless (memq #'comint-watch-for-password-prompt (default-value 'comint-output-filter-functions)) - (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt + (add-hook 'comint-output-filter-functions #'comint-watch-for-password-prompt nil t))) @@ -810,7 +784,7 @@ This list is not complete.") (error "Could not open connection to %s" host)) (erase-buffer) (set-marker (process-mark tcp-connection) (point-min)) - (set-process-filter tcp-connection 'net-utils-remove-ctrl-m-filter) + (set-process-filter tcp-connection #'net-utils-remove-ctrl-m-filter) (and initial-string (process-send-string tcp-connection (concat initial-string "\r\n"))) @@ -825,7 +799,6 @@ This list is not complete.") If a host name passed to `finger' matches one of these regular expressions, it is assumed to be a host that doesn't accept queries of the form USER@HOST, and wants a query containing USER only." - :group 'net-utils :type '(repeat regexp) :version "21.1") @@ -852,7 +825,7 @@ and `network-connection-service-alist', which see." (let* ((user-and-host (concat user "@" host)) (process-name (concat "Finger [" user-and-host "]")) (regexps finger-X.500-host-regexps) - found) + ) ;; found (and regexps (while (not (string-match (car regexps) host)) (setq regexps (cdr regexps))) @@ -866,7 +839,6 @@ and `network-connection-service-alist', which see." (defcustom whois-server-name "rs.internic.net" "Default host name for the whois service." - :group 'net-utils :type 'string) (defcustom whois-server-list @@ -880,15 +852,19 @@ and `network-connection-service-alist', which see." ("whois.nic.gov") ("whois.ripe.net")) "A list of whois servers that can be queried." - :group 'net-utils :type '(repeat (list string))) ;; FIXME: modern whois clients include a much better tld <-> whois server ;; list, Emacs should probably avoid specifying the server as the client ;; will DTRT anyway... -rfr +;; I'm not sure about the above FIXME. It seems to me that we should +;; just check the Root Zone Database maintained at: +;; https://www.iana.org/domains/root/db +;; For example: whois -h whois.iana.org .se | grep whois (defcustom whois-server-tld - '(("rs.internic.net" . "com") - ("whois.publicinterestregistry.net" . "org") + '(("whois.verisign-grs.com" . "com") + ("whois.verisign-grs.com" . "net") + ("whois.pir.org" . "org") ("whois.ripe.net" . "be") ("whois.ripe.net" . "de") ("whois.ripe.net" . "dk") @@ -896,21 +872,22 @@ and `network-connection-service-alist', which see." ("whois.ripe.net" . "fi") ("whois.ripe.net" . "fr") ("whois.ripe.net" . "uk") + ("whois.iis.se" . "se") + ("whois.iis.nu" . "nu") ("whois.apnic.net" . "au") ("whois.apnic.net" . "ch") ("whois.apnic.net" . "hk") ("whois.apnic.net" . "jp") + ("whois.eu" . "eu") ("whois.nic.gov" . "gov") ("whois.nic.mil" . "mil")) "Alist to map top level domains to whois servers." - :group 'net-utils :type '(repeat (cons string string))) (defcustom whois-guess-server t "If non-nil then whois will try to deduce the appropriate whois server from the query. If the query doesn't look like a domain or hostname then the server named by `whois-server-name' is used." - :group 'net-utils :type 'boolean) (defun whois-get-tld (host) @@ -951,7 +928,6 @@ The port is deduced from `network-connection-service-alist'." (defcustom whois-reverse-lookup-server "whois.arin.net" "Server which provides inverse DNS mapping." - :group 'net-utils :type 'string) ;;;###autoload diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index b45cefcb442..1983688cef2 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -248,8 +248,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (list key cert))))))) ;;;###autoload -(defalias 'open-protocol-stream 'open-network-stream) -(define-obsolete-function-alias 'open-protocol-stream 'open-network-stream +(define-obsolete-function-alias 'open-protocol-stream #'open-network-stream "26.1") (defun network-stream-open-plain (name buffer host service parameters) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index ea96012af20..dc541943587 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -39,10 +39,10 @@ (require 'iso8601) ;; Silence warnings +(defvar newsticker-groups) (defvar w3-mode-map) (defvar w3m-minor-mode-map) - (defvar newsticker--retrieval-timer-list nil "List of timers for news retrieval. This is an alist, each element consisting of (feed-name . timer).") @@ -66,35 +66,34 @@ considered to be running if the newsticker timer list is not empty." ;; Hard-coding URLs like this is a recipe for propagating obsolete info. (defconst newsticker--raw-url-list-defaults - '( - ("Debian Security Advisories" - "http://www.debian.org/security/dsa.en.rdf") + '(("Debian Security Advisories" + "https://www.debian.org/security/dsa.en.rdf") ("Debian Security Advisories - Long format" - "http://www.debian.org/security/dsa-long.en.rdf") + "https://www.debian.org/security/dsa-long.en.rdf") ("Emacs Wiki" - "https://www.emacswiki.org/emacs?action=rss" - nil - 3600) + "https://www.emacswiki.org/emacs?action=rss" + nil + 3600) ("LWN (Linux Weekly News)" - "https://lwn.net/headlines/rss") + "https://lwn.net/headlines/rss") ("Quote of the day" - "http://feeds.feedburner.com/quotationspage/qotd" - "07:00" - 86400) + "https://feeds.feedburner.com/quotationspage/qotd" + "07:00" + 86400) ("The Register" - "https://www.theregister.co.uk/headlines.rss") + "https://www.theregister.co.uk/headlines.rss") ("slashdot" - "http://rss.slashdot.org/Slashdot/slashdot" - nil - 3600) ;/. will ban you if under 3600 seconds! + "http://rss.slashdot.org/Slashdot/slashdot" + nil + 3600) ;/. will ban you if under 3600 seconds! ("Wired News" - "https://www.wired.com/feed/rss") + "https://www.wired.com/feed/rss") ("Heise News (german)" - "http://www.heise.de/newsticker/heise.rdf") + "http://www.heise.de/newsticker/heise.rdf") ("Tagesschau (german)" - "http://www.tagesschau.de/newsticker.rdf" - nil - 1800)) + "http://www.tagesschau.de/newsticker.rdf" + nil + 1800)) "Default URL list in raw form. This list is fed into defcustom via `newsticker--splicer'.") @@ -153,10 +152,10 @@ value effective." :group 'newsticker) (defcustom newsticker-url-list-defaults - '(("Emacs Wiki" - "https://www.emacswiki.org/emacs?action=rss" - nil - 3600)) + '(("Emacs Wiki" + "https://www.emacswiki.org/emacs?action=rss" + nil + 3600)) "A customizable list of news feeds to select from. These were mostly extracted from the Radio Community Server <http://rcs.userland.com/>. @@ -164,7 +163,7 @@ These were mostly extracted from the Radio Community Server You may add other entries in `newsticker-url-list'." :type `(set ,@(mapcar #'newsticker--splicer newsticker--raw-url-list-defaults)) - :set 'newsticker--set-customvar-retrieval + :set #'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) (defcustom newsticker-url-list nil @@ -218,7 +217,7 @@ which apply for this feed only, overriding the value of (choice :tag "Wget Arguments" (const :tag "Default arguments" nil) (repeat :tag "Special arguments" string)))) - :set 'newsticker--set-customvar-retrieval + :set #'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) (defcustom newsticker-retrieval-method @@ -261,7 +260,7 @@ make it less than 1800 seconds (30 minutes)!" (const :tag "Daily" 86400) (const :tag "Weekly" 604800) (integer :tag "Interval")) - :set 'newsticker--set-customvar-retrieval + :set #'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) (defcustom newsticker-desc-comp-max @@ -550,7 +549,7 @@ name/timer pair to `newsticker--retrieval-timer-list'." (if (<= interval 0) (setq interval nil)) (setq timer (run-at-time start-time interval - 'newsticker-get-news feed-name)) + #'newsticker-get-news feed-name)) (if interval (add-to-list 'newsticker--retrieval-timer-list (cons feed-name timer)))))) @@ -611,7 +610,7 @@ This does NOT start the retrieval timers." (interactive) (let ((filename (read-string "Filename: " (concat feed ":_" - (replace-regexp-in-string + (string-replace " " "_" (newsticker--title item)) ".html")))) (with-temp-buffer @@ -645,6 +644,15 @@ If URL is nil it is searched at point." (add-to-list 'newsticker-url-list (list name url nil nil nil) t) (customize-variable 'newsticker-url-list)) +(defun newsticker-customize-feed (feed-name) + "Open customization buffer for `newsticker-url-list' and jump to FEED-NAME." + (interactive + (list (completing-read "Name of feed or group to edit: " + (mapcar #'car newsticker-url-list)))) + (customize-variable 'newsticker-url-list) + (when (search-forward (concat "Label: " feed-name) nil t) + (forward-line -1))) + (defun newsticker-customize () "Open the newsticker customization group." (interactive) @@ -671,8 +679,8 @@ See `newsticker-get-news'." (condition-case error-data (url-retrieve url 'newsticker--get-news-by-url-callback (list feed-name)) - (error (message "Error retrieving news from %s: %s" feed-name - error-data)))) + (error (message "Error retrieving news from %s: %s" feed-name + error-data)))) (force-mode-line-update)) (defun newsticker--get-news-by-url-callback (status feed-name) @@ -719,10 +727,10 @@ See `newsticker-get-news'." (error "Another wget-process is running for %s" feed-name)) ;; start wget (let* ((args (append wget-arguments (list url))) - (proc (apply 'start-process feed-name buffername + (proc (apply #'start-process feed-name buffername newsticker-wget-name args))) (set-process-coding-system proc 'no-conversion 'no-conversion) - (set-process-sentinel proc 'newsticker--sentinel) + (set-process-sentinel proc #'newsticker--sentinel) (process-put proc 'nt-feed-name feed-name) (setq newsticker--process-ids (cons (process-id proc) newsticker--process-ids)) @@ -816,7 +824,7 @@ Argument BUFFER is the buffer of the retrieval process." (setq coding-system (intern (downcase (match-string 1)))) (setq coding-system (condition-case nil - (check-coding-system coding-system) + (check-coding-system coding-system) (coding-system-error (message "newsticker.el: ignoring coding system %s for %s" @@ -927,8 +935,8 @@ Argument BUFFER is the buffer of the retrieval process." ;; setup scrollable text (when (= 0 (length newsticker--process-ids)) (when (fboundp 'newsticker--ticker-text-setup) ;silence - ;compiler - ;warnings + ;compiler + ;warnings (newsticker--ticker-text-setup))) (setq newsticker--latest-update-time (current-time)) (when something-was-added @@ -936,8 +944,8 @@ Argument BUFFER is the buffer of the retrieval process." (newsticker--cache-save-feed (newsticker--cache-get-feed name-symbol)) (when (fboundp 'newsticker--buffer-set-uptodate) ;silence - ;compiler - ;warnings + ;compiler + ;warnings (newsticker--buffer-set-uptodate nil))) ;; kill the process buffer if wanted (unless newsticker-debug @@ -1004,7 +1012,7 @@ Argument BUFFER is the buffer of the retrieval process." ;; And another one (20050702)! If description is HTML ;; encoded and starts with a `<', wrap the whole ;; description in a CDATA expression. This happened for - ;; http://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote + ;; https://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote (goto-char (point-min)) (while (re-search-forward "<description>\\(<img.*?\\)</description>" nil t) @@ -1098,8 +1106,8 @@ same as in `newsticker--parse-atom-1.0'." ;; time-fn (lambda (node) (newsticker--decode-rfc822-date - (car (xml-node-children - (car (xml-get-children node 'modified)))))) + (car (xml-node-children + (car (xml-get-children node 'modified)))))) ;; guid-fn (lambda (node) (newsticker--guid-to-string @@ -1123,9 +1131,9 @@ Restore an xml-string from a an xml NODE that was returned by xml-parse..." (children (cddr node))) (concat "<" qname (when att-list " ") - (mapconcat 'newsticker--unxml-attribute att-list " ") + (mapconcat #'newsticker--unxml-attribute att-list " ") ">" - (mapconcat 'newsticker--unxml children "") "</" qname ">"))) + (mapconcat #'newsticker--unxml children "") "</" qname ">"))) (defun newsticker--unxml-attribute (attribute) "Actually restore xml-string of an ATTRIBUTE of an xml node." @@ -1168,7 +1176,7 @@ URL `http://www.atompub.org/2005/08/17/draft-ietf-atompub-format-11.html'" ;; unxml the content or the summary node. Atom ;; allows for integrating (x)html into the atom ;; structure but we need the raw html string. - ;; e.g. http://www.heise.de/open/news/news-atom.xml + ;; e.g. https://www.heise.de/open/news/news-atom.xml ;; http://feeds.feedburner.com/ru_nix_blogs (or (newsticker--unxml (car (xml-node-children @@ -1548,6 +1556,7 @@ argument, which is one of the items in ITEMLIST." ;; ====================================================================== (defun newsticker--insert-bytes (bytes) + "Decode BYTES and insert in current buffer." (insert (decode-coding-string bytes 'binary))) (defun newsticker--remove-whitespace (string) @@ -1571,7 +1580,7 @@ Remove the pre-formatted from `newsticker--cache'." "Forget all cached pre-formatted data. Remove the pre-formatted from `newsticker--cache'." (mapc (lambda (feed) - (mapc 'newsticker--do-forget-preformatted + (mapc #'newsticker--do-forget-preformatted (cdr feed))) newsticker--cache) (when (fboundp 'newsticker--buffer-set-uptodate) @@ -1584,10 +1593,10 @@ This function calls `message' with arguments STRING and ARGS, if (and newsticker-debug ;;(not (active-minibuffer-window)) ;;(not (current-message)) - (apply 'message string args))) + (apply #'message string args))) (defun newsticker--decode-iso8601-date (string) - "Return ISO8601-STRING in format like `encode-time'. + "Return ISO8601-encoded STRING in format like `encode-time'. Converts from ISO-8601 to Emacs representation. If no time zone is present, this function defaults to universal time." (if string @@ -1669,8 +1678,9 @@ Sat, 07 Sep 2002 00:00:01 GMT (message "Cannot decode \"%s\": %s %s" rfc822-string (car error-data) (cdr error-data)) nil)))) - nil)) + nil)) +;; FIXME: Can this be replaced by seq-intersection? (defun newsticker--lists-intersect-p (list1 list2) "Return t if LIST1 and LIST2 share elements." (let ((result nil)) @@ -1728,27 +1738,27 @@ Save image as FILENAME in DIRECTORY, download it from URL." (let* ((proc-name (concat feed-name "-" filename)) (buffername (concat " *newsticker-wget-image-" proc-name "*")) (item (or (assoc feed-name newsticker-url-list) - (assoc feed-name newsticker-url-list-defaults) - (error - "Cannot get image for %s: Check newsticker-url-list" - feed-name))) + (assoc feed-name newsticker-url-list-defaults) + (error + "Cannot get image for %s: Check newsticker-url-list" + feed-name))) (wget-arguments (or (car (cdr (cdr (cdr (cdr item))))) newsticker-wget-arguments))) - (with-current-buffer (get-buffer-create buffername) - (erase-buffer) - ;; throw an error if there is an old wget-process around - (if (get-process feed-name) - (error "Another wget-process is running for image %s" - feed-name)) - ;; start wget - (let* ((args (append wget-arguments (list url))) - (proc (apply 'start-process proc-name buffername - newsticker-wget-name args))) - (set-process-coding-system proc 'no-conversion 'no-conversion) - (set-process-sentinel proc 'newsticker--image-sentinel) - (process-put proc 'nt-directory directory) - (process-put proc 'nt-feed-name feed-name) - (process-put proc 'nt-filename filename))))) + (with-current-buffer (get-buffer-create buffername) + (erase-buffer) + ;; throw an error if there is an old wget-process around + (if (get-process feed-name) + (error "Another wget-process is running for image %s" + feed-name)) + ;; start wget + (let* ((args (append wget-arguments (list url))) + (proc (apply #'start-process proc-name buffername + newsticker-wget-name args))) + (set-process-coding-system proc 'no-conversion 'no-conversion) + (set-process-sentinel proc #'newsticker--image-sentinel) + (process-put proc 'nt-directory directory) + (process-put proc 'nt-feed-name feed-name) + (process-put proc 'nt-filename filename))))) (defun newsticker--image-sentinel (process _event) "Sentinel for image-retrieving PROCESS caused by EVENT." @@ -1773,18 +1783,18 @@ Save image as FILENAME in DIRECTORY, download it from URL." "Save contents of BUFFER in DIRECTORY as FILE-NAME. Finally kill buffer." (with-current-buffer buffer - (let ((image-name (concat directory file-name))) - (set-buffer-file-coding-system 'no-conversion) - ;; make sure the cache dir exists - (unless (file-directory-p directory) - (make-directory directory)) - ;; write and close buffer - (let ((require-final-newline nil) - (backup-inhibited t) - (coding-system-for-write 'no-conversion)) - (write-region nil nil image-name nil 'quiet)) - (set-buffer-modified-p nil) - (kill-buffer buffer)))) + (let ((image-name (concat directory file-name))) + (set-buffer-file-coding-system 'no-conversion) + ;; make sure the cache dir exists + (unless (file-directory-p directory) + (make-directory directory)) + ;; write and close buffer + (let ((require-final-newline nil) + (backup-inhibited t) + (coding-system-for-write 'no-conversion)) + (write-region nil nil image-name nil 'quiet)) + (set-buffer-modified-p nil) + (kill-buffer buffer)))) (defun newsticker--image-remove (directory file-name) "In DIRECTORY remove FILE-NAME." @@ -1799,8 +1809,8 @@ Save image as FILENAME in DIRECTORY, download it from URL." (condition-case error-data (url-retrieve url 'newsticker--image-download-by-url-callback (list feed-name directory filename)) - (error (message "Error retrieving image from %s: %s" feed-name - error-data)))) + (error (message "Error retrieving image from %s: %s" feed-name + error-data)))) (force-mode-line-update)) (defun newsticker--image-download-by-url-callback (status feed-name directory filename) @@ -2137,11 +2147,11 @@ FEED is a symbol!" (concat newsticker-dir "/feeds")) (defun newsticker--cache-save () - "Save cache data for all feeds." - (unless (file-directory-p newsticker-dir) - (make-directory newsticker-dir t)) - (mapc 'newsticker--cache-save-feed newsticker--cache) - nil) + "Save cache data for all feeds." + (unless (file-directory-p newsticker-dir) + (make-directory newsticker-dir t)) + (mapc #'newsticker--cache-save-feed newsticker--cache) + nil) (defun newsticker--cache-save-feed (feed) "Save cache data for FEED." @@ -2207,14 +2217,14 @@ If AGES is nil, the total number of items is returned." (if (memq (newsticker--age (car items)) ages) (setq num (1+ num))) (if (memq (newsticker--age (car items)) '(new old immortal obsolete)) - (setq num (1+ num)))) + (setq num (1+ num)))) (setq items (cdr items))) num)) (defun newsticker--stat-num-items-total (&optional age) "Return total number of items in all feeds which have the given AGE. If AGE is nil, the total number of items is returned." - (apply '+ + (apply #'+ (mapcar (lambda (feed) (if age (newsticker--stat-num-items (intern (car feed)) age) @@ -2227,39 +2237,66 @@ If AGE is nil, the total number of items is returned." (defun newsticker-opml-export () "OPML subscription export. Export subscriptions to a buffer in OPML Format." - ;; FIXME: use newsticker-groups (interactive) (with-current-buffer (get-buffer-create "*OPML Export*") + (erase-buffer) (set-buffer-file-coding-system 'utf-8) (insert (concat "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" "<!-- OPML generated by Emacs newsticker.el -->\n" "<opml version=\"1.0\">\n" " <head>\n" - " <title>mySubscriptions</title>\n" + " <title>Emacs newsticker subscriptions</title>\n" " <dateCreated>" (format-time-string "%a, %d %b %Y %T %z") "</dateCreated>\n" " <ownerEmail>" user-mail-address "</ownerEmail>\n" " <ownerName>" (user-full-name) "</ownerName>\n" " </head>\n" " <body>\n")) - (dolist (sub (append newsticker-url-list newsticker-url-list-defaults)) - (insert " <outline text=\"") - (insert (newsticker--title sub)) - (insert "\" xmlUrl=\"") - (insert (xml-escape-string (let ((url (cadr sub))) - (if (stringp url) url (prin1-to-string url))))) - (insert "\"/>\n")) - (insert " </body>\n</opml>\n")) + (let ((feeds (append newsticker-url-list newsticker-url-list-defaults)) + ;; insert the feed groups and all feeds that are contained + (saved-feed-names (newsticker--opml-insert-elt newsticker-groups 2))) + ;; to be safe: insert all feeds that are not contained in any group + (dolist (f feeds) + (unless (seq-find (lambda (sfn) (string= (car f) sfn)) saved-feed-names) + (newsticker--opml-insert-feed (car f) 4))) + (insert " </body>\n</opml>\n"))) (pop-to-buffer "*OPML Export*") (when (fboundp 'sgml-mode) (sgml-mode))) +(defun newsticker--opml-insert-elt (elt depth) + "Insert an OPML ELT with indentation level DEPTH." + (if (listp elt) + (newsticker--opml-insert-group elt (+ 2 depth)) + (newsticker--opml-insert-feed elt (+ 2 depth)))) + +(defun newsticker--opml-insert-group (group depth) + "Insert an OPML GROUP with indentation level DEPTH." + (let (saved-feeds) + (insert (make-string depth ? ) "<outline type=\"folder\" text=\"" (car group) "\">\n") + (setq saved-feeds (mapcar (lambda (e) + (newsticker--opml-insert-elt e depth)) + (cdr group))) + (insert (make-string depth ? ) "</outline>\n") + (flatten-tree saved-feeds))) + +(defun newsticker--opml-insert-feed (feed-name depth) + "Insert an OPML FEED-NAME with indentation level DEPTH." + (let* ((feed-definition (seq-find (lambda (f) + (string= feed-name (car f))) + (append newsticker-url-list newsticker-url-list-defaults))) + (url (nth 1 feed-definition)) + (url-string (if (functionp url) (prin1-to-string url) + (xml-escape-string url)))) + (insert (make-string depth ? ) "<outline text=\"" feed-name + "\" xmlUrl=\"" url-string + "\"/>\n")) + feed-name) + (defun newsticker--opml-import-outlines (outlines) - "Recursively import OUTLINES from OPML data. -Note that nested outlines are currently flattened -- i.e. grouping is -removed." - (mapc (lambda (outline) + "Recursively import OUTLINES from OPML data." + (mapcar (lambda (outline) (let ((name (xml-get-attribute outline 'text)) (url (xml-get-attribute outline 'xmlUrl)) (children (xml-get-children outline 'outline))) @@ -2267,18 +2304,27 @@ removed." (add-to-list 'newsticker-url-list (list name url nil nil nil) t)) (if children - (newsticker--opml-import-outlines children)))) - outlines)) + (append (list name) + (newsticker--opml-import-outlines children)) + name))) + outlines)) (defun newsticker-opml-import (filename) - "Import OPML data from FILENAME." + "Import OPML data from FILENAME. +Feeds are added to `newsticker-url-list' and `newsticker-groups' +preserving the outline structure." (interactive "fOPML file: ") (set-buffer (find-file-noselect filename)) (goto-char (point-min)) (let* ((node-list (xml-parse-region (point-min) (point-max))) + (title (car (xml-node-children + (car (xml-get-children + (car (xml-get-children (car node-list) 'head)) + 'title))))) (body (car (xml-get-children (car node-list) 'body))) - (outlines (xml-get-children body 'outline))) - (newsticker--opml-import-outlines outlines)) + (outlines (xml-get-children body 'outline)) + (imported-groups-data (newsticker--opml-import-outlines outlines))) + (add-to-list 'newsticker-groups (cons title imported-groups-data) t)) (customize-variable 'newsticker-url-list)) ;; ====================================================================== @@ -2350,7 +2396,7 @@ the item." (make-directory temp-dir t)) (cd temp-dir) (message "Getting image %s" url) - (apply 'start-process "wget-image" + (apply #'start-process "wget-image" " *newsticker-wget-download-images*" newsticker-wget-name (list url)) @@ -2372,7 +2418,7 @@ This function is suited for adding it to `newsticker-new-item-functions'." (make-directory temp-dir t)) (cd temp-dir) (message "Getting enclosure %s" url) - (apply 'start-process "wget-enclosure" + (apply #'start-process "wget-enclosure" " *newsticker-wget-download-enclosures*" newsticker-wget-name (list url)) diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 21d47b838f5..420cf82e4d8 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -1,10 +1,10 @@ -;;; newst-plainview.el --- Single buffer frontend for newsticker. +;;; newst-plainview.el --- Single buffer frontend for newsticker. -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. ;; Author: Ulf Jasper <ulf.jasper@web.de> ;; Filename: newst-plainview.el -;; URL: http://www.nongnu.org/newsticker +;; URL: https://www.nongnu.org/newsticker ;; Package: newsticker ;; ====================================================================== @@ -90,7 +90,7 @@ The following sort methods are available: (const :tag "Keep original order" sort-by-original-order) (const :tag "Sort by time" sort-by-time) (const :tag "Sort by title" sort-by-title)) - :set 'newsticker--set-customvar-sorting + :set #'newsticker--set-customvar-sorting :group 'newsticker-plainview) (defcustom newsticker-heading-format @@ -107,7 +107,7 @@ The following printf-like specifiers can be used: %s The statistical data of the feed. See `newsticker-statistics-format'. %t The title of the feed, i.e. its name." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) (defcustom newsticker-item-format @@ -122,7 +122,7 @@ The following printf-like specifiers can be used: the title of the feed is used. %t The title of the item." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) (defcustom newsticker-desc-format @@ -133,7 +133,7 @@ The following printf-like specifiers can be used: %d The date the item was (first) retrieved. See `newsticker-date-format'." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) (defcustom newsticker-statistics-format @@ -146,7 +146,7 @@ The following printf-like specifiers can be used: %o The number of old items in the feed. %O The number of obsolete items in the feed." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) @@ -195,7 +195,7 @@ If set to t old items will be completely folded and only new items will show up in the *newsticker* buffer. Otherwise old as well as new items will be visible." :type 'boolean - :set 'newsticker--set-customvar-buffer + :set #'newsticker--set-customvar-buffer :group 'newsticker-plainview) (defcustom newsticker-show-descriptions-of-new-items @@ -204,14 +204,14 @@ well as new items will be visible." If set to t old items will be folded and new items will be unfolded. Otherwise old as well as new items will be folded." :type 'boolean - :set 'newsticker--set-customvar-buffer + :set #'newsticker--set-customvar-buffer :group 'newsticker-plainview) (defcustom newsticker-show-all-news-elements nil "Show all news elements." :type 'boolean - ;;:set 'newsticker--set-customvar + ;;:set #'newsticker--set-customvar :group 'newsticker-plainview) ;; ====================================================================== @@ -273,6 +273,7 @@ images." (defvar newsticker--plainview-tool-bar-map (when (boundp 'tool-bar-map) + (defvar tool-bar-map) (let ((tool-bar-map (make-sparse-keymap))) (tool-bar-add-item "newsticker/prev-feed" 'newsticker-previous-feed @@ -386,51 +387,45 @@ images." (defvar newsticker-mode-map (let ((map (make-keymap))) - (define-key map "sO" 'newsticker-show-old-items) - (define-key map "hO" 'newsticker-hide-old-items) - (define-key map "sa" 'newsticker-show-all-desc) - (define-key map "ha" 'newsticker-hide-all-desc) - (define-key map "sf" 'newsticker-show-feed-desc) - (define-key map "hf" 'newsticker-hide-feed-desc) - (define-key map "so" 'newsticker-show-old-item-desc) - (define-key map "ho" 'newsticker-hide-old-item-desc) - (define-key map "sn" 'newsticker-show-new-item-desc) - (define-key map "hn" 'newsticker-hide-new-item-desc) - (define-key map "se" 'newsticker-show-entry) - (define-key map "he" 'newsticker-hide-entry) - (define-key map "sx" 'newsticker-show-extra) - (define-key map "hx" 'newsticker-hide-extra) - - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map " " 'scroll-up-command) - (define-key map "q" 'newsticker-close-buffer) - (define-key map "p" 'newsticker-previous-item) - (define-key map "P" 'newsticker-previous-new-item) - (define-key map "F" 'newsticker-previous-feed) - (define-key map "\t" 'newsticker-next-item) - (define-key map "n" 'newsticker-next-item) - (define-key map "N" 'newsticker-next-new-item) - (define-key map "f" 'newsticker-next-feed) - (define-key map "M" 'newsticker-mark-all-items-as-read) - (define-key map "m" - 'newsticker-mark-all-items-at-point-as-read-and-redraw) - (define-key map "o" - 'newsticker-mark-item-at-point-as-read) - (define-key map "O" - 'newsticker-mark-all-items-at-point-as-read) - (define-key map "G" 'newsticker-get-all-news) - (define-key map "g" 'newsticker-get-news-at-point) - (define-key map "u" 'newsticker-buffer-update) - (define-key map "U" 'newsticker-buffer-force-update) - (define-key map "a" 'newsticker-add-url) - - (define-key map "i" - 'newsticker-mark-item-at-point-as-immortal) - - (define-key map "xf" - 'newsticker-toggle-auto-narrow-to-feed) - (define-key map "xi" - 'newsticker-toggle-auto-narrow-to-item) + (define-key map "sO" #'newsticker-show-old-items) + (define-key map "hO" #'newsticker-hide-old-items) + (define-key map "sa" #'newsticker-show-all-desc) + (define-key map "ha" #'newsticker-hide-all-desc) + (define-key map "sf" #'newsticker-show-feed-desc) + (define-key map "hf" #'newsticker-hide-feed-desc) + (define-key map "so" #'newsticker-show-old-item-desc) + (define-key map "ho" #'newsticker-hide-old-item-desc) + (define-key map "sn" #'newsticker-show-new-item-desc) + (define-key map "hn" #'newsticker-hide-new-item-desc) + (define-key map "se" #'newsticker-show-entry) + (define-key map "he" #'newsticker-hide-entry) + (define-key map "sx" #'newsticker-show-extra) + (define-key map "hx" #'newsticker-hide-extra) + + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map " " #'scroll-up-command) + (define-key map "q" #'newsticker-close-buffer) + (define-key map "p" #'newsticker-previous-item) + (define-key map "P" #'newsticker-previous-new-item) + (define-key map "F" #'newsticker-previous-feed) + (define-key map "\t" #'newsticker-next-item) + (define-key map "n" #'newsticker-next-item) + (define-key map "N" #'newsticker-next-new-item) + (define-key map "f" #'newsticker-next-feed) + (define-key map "M" #'newsticker-mark-all-items-as-read) + (define-key map "m" #'newsticker-mark-all-items-at-point-as-read-and-redraw) + (define-key map "o" #'newsticker-mark-item-at-point-as-read) + (define-key map "O" #'newsticker-mark-all-items-at-point-as-read) + (define-key map "G" #'newsticker-get-all-news) + (define-key map "g" #'newsticker-get-news-at-point) + (define-key map "u" #'newsticker-buffer-update) + (define-key map "U" #'newsticker-buffer-force-update) + (define-key map "a" #'newsticker-add-url) + + (define-key map "i" #'newsticker-mark-item-at-point-as-immortal) + + (define-key map "xf" #'newsticker-toggle-auto-narrow-to-feed) + (define-key map "xi" #'newsticker-toggle-auto-narrow-to-item) ;; Bind menu to mouse. (define-key map [down-mouse-3] newsticker-menu) @@ -479,11 +474,11 @@ images." ;; maps for the clickable portions (defvar newsticker--url-keymap (let ((map (make-sparse-keymap))) - (define-key map [mouse-1] 'newsticker-mouse-browse-url) - (define-key map [mouse-2] 'newsticker-mouse-browse-url) - (define-key map "\n" 'newsticker-browse-url) - (define-key map "\C-m" 'newsticker-browse-url) - (define-key map [(control return)] 'newsticker-handle-url) + (define-key map [mouse-1] #'newsticker-mouse-browse-url) + (define-key map [mouse-2] #'newsticker-mouse-browse-url) + (define-key map "\n" #'newsticker-browse-url) + (define-key map "\C-m" #'newsticker-browse-url) + (define-key map [(control return)] #'newsticker-handle-url) map) "Key map for click-able headings in the newsticker buffer.") @@ -980,7 +975,7 @@ not get changed." (let* (pos1 pos2 (inhibit-read-only t) inv-prop org-inv-prop - is-invisible) + ) ;; is-invisible (newsticker--buffer-beginning-of-item) (newsticker--buffer-goto '(desc)) (setq pos1 (max (point-min) (1- (point)))) @@ -1009,7 +1004,7 @@ not get changed." (let* (pos1 pos2 (inhibit-read-only t) inv-prop org-inv-prop - is-invisible) + ) ;; is-invisible (newsticker--buffer-beginning-of-item) (newsticker--buffer-goto '(desc)) (setq pos1 (max (point-min) (1- (point)))) @@ -1147,7 +1142,7 @@ If VALUE is nil, auto-narrowing is turned off, otherwise it is turned on." (setq index-alist (list feed-list))) index-alist))) -(defun newsticker--imenu-goto (name pos &rest args) +(defun newsticker--imenu-goto (_name pos &rest _args) "Go to item NAME at position POS and show item. ARGS are ignored." (goto-char pos) @@ -1236,6 +1231,9 @@ item-retrieval time is added as well." ;; insert the description (newsticker--buffer-do-insert-text item 'desc feed-name-symbol)) +(defvar w3m-fill-column) +(defvar w3-maximum-line-length) + (defun newsticker--buffer-do-insert-text (item type feed-name-symbol) "Actually insert contents of news item, format it, render it and all that. ITEM is a news item, TYPE tells which part of the item shall be inserted, diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el index b188bd4589e..40e304402ad 100644 --- a/lisp/net/newst-reader.el +++ b/lisp/net/newst-reader.el @@ -1,4 +1,4 @@ -;;; newst-reader.el --- Generic RSS reader functions. +;;; newst-reader.el --- Generic RSS reader functions. -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. @@ -94,7 +94,7 @@ done." (const :tag "Right" right) (const :tag "Center" center) (const :tag "Full" full)) - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defcustom newsticker-use-full-width @@ -103,7 +103,7 @@ done." If non-nil newsticker sets `fill-column' so that the whole window is used when filling. See also `newsticker-justification'." :type 'boolean - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defcustom newsticker-html-renderer @@ -122,7 +122,7 @@ htmlr if this option is set." (const :tag "w3" w3-region) (const :tag "w3m" w3m-region) (const :tag "htmlr" newsticker-htmlr-render)) - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defcustom newsticker-date-format @@ -130,7 +130,7 @@ htmlr if this option is set." "Format for the date part in item and feed lines. See `format-time-string' for a list of valid specifiers." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defgroup newsticker-faces nil diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el index 275c91a36ea..8cfafb5bfe4 100644 --- a/lisp/net/newst-ticker.el +++ b/lisp/net/newst-ticker.el @@ -1,4 +1,4 @@ -;; newst-ticker.el --- mode line ticker for newsticker. +;;; newst-ticker.el --- mode line ticker for newsticker. -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. @@ -83,7 +83,7 @@ smooth display (see `newsticker-scroll-smoothly') a value of 0.3 seems reasonable. For non-smooth display a value of 10 is a good starting point." :type 'number - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defcustom newsticker-scroll-smoothly @@ -104,7 +104,7 @@ at all. If you change `newsticker-scroll-smoothly' you should also change If t the echo area will not show immortal items. See also `newsticker-hide-old-items-in-echo-area'." :type 'boolean - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defcustom newsticker-hide-old-items-in-echo-area @@ -113,7 +113,7 @@ If t the echo area will not show immortal items. See also If t the echo area will show only new items, i.e. only items which have been added between the last two retrievals." :type 'boolean - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defcustom newsticker-hide-obsolete-items-in-echo-area @@ -122,7 +122,7 @@ been added between the last two retrievals." If t the echo area will not show obsolete items. See also `newsticker-hide-old-items-in-echo-area'." :type 'boolean - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defun newsticker--display-tick () @@ -205,7 +205,7 @@ running already." (setq newsticker--ticker-timer (run-at-time newsticker-ticker-interval newsticker-ticker-interval - 'newsticker--display-tick)))) + #'newsticker--display-tick)))) (defun newsticker-stop-ticker () "Stop newsticker's ticker (but not the news retrieval)." diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index cf55f66e780..d524e6dd173 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -31,10 +31,6 @@ ;; See newsticker.el ;; ====================================================================== -;;; History: -;; - -;; ====================================================================== ;;; Code: (require 'cl-lib) (require 'newst-reader) @@ -52,72 +48,73 @@ (defface newsticker-treeview-face '((((class color) (background dark)) :foreground "white") (((class color) (background light)) :foreground "black")) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-new-face '((t :inherit newsticker-treeview-face :weight bold)) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-old-face '((t :inherit newsticker-treeview-face)) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-immortal-face '((default :inherit newsticker-treeview-face :slant italic) (((class color) (background dark)) :foreground "orange") (((class color) (background light)) :foreground "blue")) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-obsolete-face '((t :inherit newsticker-treeview-face :strike-through t)) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-selection-face '((((class color) (background dark)) :background "#4444aa") (((class color) (background light)) :background "#bbbbff")) - "Face for newsticker selection." - :group 'newsticker-treeview) + "Face for newsticker selection.") (defcustom newsticker-treeview-date-format "%d.%m.%y, %H:%M" "Format for the date column in the treeview list buffer. See `format-time-string' for a list of valid specifiers." :version "25.1" - :type 'string - :group 'newsticker-treeview) + :type 'string) (defcustom newsticker-treeview-own-frame nil "Decides whether newsticker treeview creates and uses its own frame." - :type 'boolean - :group 'newsticker-treeview) + :type 'boolean) (defcustom newsticker-treeview-treewindow-width 30 "Width of tree window in treeview layout. See also `newsticker-treeview-listwindow-height'." - :type 'integer - :group 'newsticker-treeview) + :type 'integer) (defcustom newsticker-treeview-listwindow-height 10 "Height of list window in treeview layout. See also `newsticker-treeview-treewindow-width'." - :type 'integer - :group 'newsticker-treeview) + :type 'integer) (defcustom newsticker-treeview-automatically-mark-displayed-items-as-old t "Decides whether to automatically mark displayed items as old. If t an item is marked as old as soon as it is displayed. This applies to newsticker only." - :type 'boolean - :group 'newsticker-treeview) + :type 'boolean) + +(defcustom newsticker-treeview-use-feed-name-from-url-list-in-treeview + t + "Use the feed names from 'newsticker-url-list' for display in treeview." + :version "28.1" + :type 'boolean) + +(defcustom newsticker-treeview-use-feed-name-from-url-list-in-itemview + t + "Use feed names from 'newsticker-url-list' in itemview." + :version "28.1" + :type 'boolean) (defvar newsticker-groups '("Feeds") @@ -152,14 +149,16 @@ Example: (\"Topmost group\" \"feed1\" (\"subgroup1\" \"feed 2\") (defvar newsticker--treeview-feed-tree nil) (defvar newsticker--treeview-vfeed-tree nil) +(declare-function newsticker-handle-url "newst-plainview" ()) + ;; maps for the clickable portions (defvar newsticker--treeview-url-keymap (let ((map (make-sparse-keymap 'newsticker--treeview-url-keymap))) - (define-key map [mouse-1] 'newsticker-treeview-mouse-browse-url) - (define-key map [mouse-2] 'newsticker-treeview-mouse-browse-url) - (define-key map "\n" 'newsticker-treeview-browse-url) - (define-key map "\C-m" 'newsticker-treeview-browse-url) - (define-key map [(control return)] 'newsticker-handle-url) + (define-key map [mouse-1] #'newsticker-treeview-mouse-browse-url) + (define-key map [mouse-2] #'newsticker-treeview-mouse-browse-url) + (define-key map "\n" #'newsticker-treeview-browse-url) + (define-key map "\C-m" #'newsticker-treeview-browse-url) + (define-key map [(control return)] #'newsticker-handle-url) map) "Key map for click-able headings in the newsticker treeview buffers.") @@ -328,9 +327,9 @@ If string SHOW-FEED is non-nil it is shown in the item string." (replace-match " ")) (let ((map (make-sparse-keymap))) (dolist (key'([mouse-1] [mouse-3])) - (define-key map key 'newsticker-treeview-tree-click)) - (define-key map "\n" 'newsticker-treeview-show-item) - (define-key map "\C-m" 'newsticker-treeview-show-item) + (define-key map key #'newsticker-treeview-tree-click)) + (define-key map "\n" #'newsticker-treeview-show-item) + (define-key map "\C-m" #'newsticker-treeview-show-item) (add-text-properties pos1 (point-max) (list :nt-item item :nt-feed feed @@ -612,9 +611,9 @@ If CLEAR-BUFFER is non-nil the list buffer is completely erased." (defvar newsticker-treeview-list-sort-button-map (let ((map (make-sparse-keymap))) (define-key map [header-line mouse-1] - 'newsticker--treeview-list-sort-by-column) + #'newsticker--treeview-list-sort-by-column) (define-key map [header-line mouse-2] - 'newsticker--treeview-list-sort-by-column) + #'newsticker--treeview-list-sort-by-column) map) "Local keymap for newsticker treeview list window sort buttons.") @@ -738,11 +737,14 @@ for the button." (img (newsticker--image-read feed-name-symbol nil 40))) (if (and (display-images-p) img) (newsticker--insert-image img (car item)) - (insert (newsticker--real-feed-name feed-name-symbol)))) + (insert (if newsticker-treeview-use-feed-name-from-url-list-in-itemview + (symbol-name feed-name-symbol) + (newsticker--real-feed-name feed-name-symbol))))) (add-text-properties (point-min) (point) (list 'face 'newsticker-feed-face 'mouse-face 'highlight - 'help-echo "Visit in web browser." + 'help-echo (concat (newsticker--real-feed-name feed-name-symbol) + "\nClick to visit in web browser.") :nt-link (newsticker--link item) 'keymap newsticker--treeview-url-keymap)) (setq pos (point)) @@ -933,31 +935,31 @@ Optional arguments CHANGED-WIDGET and EVENT are ignored." (newsticker-treeview-mode))) (defun newsticker--treeview-propertize-tag (tag &optional num-new nt-id feed - vfeed) + vfeed tooltip) "Return propertized copy of string TAG. Optional argument NUM-NEW is used for choosing face, other -arguments NT-ID, FEED, and VFEED are added as properties." +arguments NT-ID, FEED, VFEED and TOOLTIP are added as properties." ;;(message "newsticker--treeview-propertize-tag `%s' %s" feed nt-id) (let ((face 'newsticker-treeview-face) (map (make-sparse-keymap))) (if (and num-new (> num-new 0)) (setq face 'newsticker-treeview-new-face)) (dolist (key '([mouse-1] [mouse-3])) - (define-key map key 'newsticker-treeview-tree-click)) - (define-key map "\n" 'newsticker-treeview-tree-do-click) - (define-key map "\C-m" 'newsticker-treeview-tree-do-click) + (define-key map key #'newsticker-treeview-tree-click)) + (define-key map "\n" #'newsticker-treeview-tree-do-click) + (define-key map "\C-m" #'newsticker-treeview-tree-do-click) (propertize tag 'face face 'keymap map :nt-id nt-id :nt-feed feed :nt-vfeed vfeed - 'help-echo tag + 'help-echo tooltip 'mouse-face 'highlight))) (defun newsticker--treeview-tree-get-tag (feed-name vfeed-name &optional nt-id) "Return a tag string for either FEED-NAME or, if it is nil, for VFEED-NAME. Optional argument NT-ID is added to the tag's properties." - (let (tag (num-new 0)) + (let (tag tooltip (num-new 0)) (cond (vfeed-name (cond ((string= vfeed-name "new") (setq num-new (newsticker--stat-num-items-total 'new)) @@ -970,18 +972,29 @@ Optional argument NT-ID is added to the tag's properties." (setq tag (format "Obsolete items (%d)" num-new))) ((string= vfeed-name "all") (setq num-new (newsticker--stat-num-items-total)) - (setq tag (format "All items (%d)" num-new))))) + (setq tag (format "All items (%d)" num-new)))) + (setq tooltip tag)) (feed-name (setq num-new (newsticker--stat-num-items-for-group (intern feed-name) 'new 'immortal)) (setq tag (format "%s (%d)" - (newsticker--real-feed-name (intern feed-name)) - num-new)))) + (if newsticker-treeview-use-feed-name-from-url-list-in-itemview + feed-name + (newsticker--real-feed-name (intern feed-name))) + num-new)) + (setq tooltip + (if (newsticker--group-get-group feed-name) + tag + (format "%s (%d)\n%s" + feed-name + num-new + (newsticker--real-feed-name (intern feed-name))))))) (if tag (newsticker--treeview-propertize-tag tag num-new nt-id - feed-name vfeed-name)))) + feed-name vfeed-name + tooltip)))) (defun newsticker--stat-num-items-for-group (feed-name-symbol &rest ages) "Count number of items in feed FEED-NAME-SYMBOL that have an age matching AGES." @@ -1085,6 +1098,7 @@ Arguments are ignored." ;; ====================================================================== (defvar newsticker-treeview-tool-bar-map (when (boundp 'tool-bar-map) + (defvar tool-bar-map) (let ((tool-bar-map (make-sparse-keymap))) (tool-bar-add-item "newsticker/prev-feed" 'newsticker-treeview-prev-feed @@ -1434,6 +1448,15 @@ Move to next item unless DONT-PROCEED is non-nil." newsticker--treeview-current-vfeed) (newsticker--treeview-get-selected-item))) +(defun newsticker-treeview-customize-current-feed () + "Open customization buffer for `newsticker-url-list' and move to current feed." + (interactive) + (let ((cur-feed (or newsticker--treeview-current-feed + newsticker--treeview-current-vfeed))) + (if (newsticker--group-get-group cur-feed) + (message "Cannot customize groups. Please select a feed.") + (newsticker-customize-feed cur-feed)))) + (defun newsticker--treeview-set-current-node (node) "Make NODE the current node." (with-current-buffer (newsticker--treeview-tree-buffer) @@ -1626,7 +1649,7 @@ Return t if a new feed was activated, nil otherwise." (interactive (list (let ((completion-ignore-case t)) (completing-read - "Jump to feed: " + "Jump to feed/group: " (append '("new" "obsolete" "immortal" "all") (mapcar #'car (append newsticker-url-list newsticker-url-list-defaults))) @@ -1852,28 +1875,34 @@ of the shift. If MOVE-GROUP is nil the currently selected feed `newsticker--treeview-current-feed' is shifted, if it is t then the current feed's parent group is shifted.." (let* ((cur-feed newsticker--treeview-current-feed) - (thing (if move-group - (newsticker--group-find-parent-group cur-feed) + (thing (if (and move-group + (not (newsticker--group-get-group cur-feed))) + (car (newsticker--group-find-parent-group cur-feed)) cur-feed)) (parent-group (newsticker--group-find-parent-group - (if move-group (car thing) thing)))) + ;;(if move-group (car thing) thing) + thing))) (unless parent-group (error "Group not found!")) (let* ((siblings (cdr parent-group)) - (pos (cl-position thing siblings :test 'equal)) + (pos (cl-position thing siblings :test + (lambda (o1 o2) + (equal (if (listp o1) (car o1) o1) + (if (listp o2) (car o2) o2))))) (tpos (+ pos delta )) (new-pos (max 0 (min (length siblings) tpos))) (beg (cl-subseq siblings 0 (min pos new-pos))) (end (cl-subseq siblings (+ 1 (max pos new-pos)))) (p (elt siblings new-pos))) (when (not (= pos new-pos)) - (setcdr parent-group - (cl-concatenate 'list - beg - (if (> delta 0) - (list p thing) - (list thing p)) - end)) + (let ((th (or (newsticker--group-get-group thing) thing))) + (setcdr parent-group + (cl-concatenate 'list + beg + (if (> delta 0) + (list p th) + (list th p)) + end))) (newsticker--treeview-tree-update) (newsticker-treeview-update) (newsticker-treeview-jump cur-feed))))) @@ -1986,36 +2015,37 @@ Return t if groups have changed, nil otherwise." (defvar newsticker-treeview-mode-map (let ((map (make-sparse-keymap 'newsticker-treeview-mode-map))) - (define-key map " " 'newsticker-treeview-next-page) - (define-key map "a" 'newsticker-add-url) - (define-key map "b" 'newsticker-treeview-browse-url-item) - (define-key map "F" 'newsticker-treeview-prev-feed) - (define-key map "f" 'newsticker-treeview-next-feed) - (define-key map "g" 'newsticker-treeview-get-news) - (define-key map "G" 'newsticker-get-all-news) - (define-key map "i" 'newsticker-treeview-toggle-item-immortal) - (define-key map "j" 'newsticker-treeview-jump) - (define-key map "n" 'newsticker-treeview-next-item) - (define-key map "N" 'newsticker-treeview-next-new-or-immortal-item) - (define-key map "O" 'newsticker-treeview-mark-list-items-old) - (define-key map "o" 'newsticker-treeview-mark-item-old) - (define-key map "p" 'newsticker-treeview-prev-item) - (define-key map "P" 'newsticker-treeview-prev-new-or-immortal-item) - (define-key map "q" 'newsticker-treeview-quit) - (define-key map "S" 'newsticker-treeview-save-item) - (define-key map "s" 'newsticker-treeview-save) - (define-key map "u" 'newsticker-treeview-update) - (define-key map "v" 'newsticker-treeview-browse-url) - ;;(define-key map "\n" 'newsticker-treeview-scroll-item) - ;;(define-key map "\C-m" 'newsticker-treeview-scroll-item) - (define-key map "\M-m" 'newsticker-group-move-feed) - (define-key map "\M-a" 'newsticker-group-add-group) - (define-key map "\M-d" 'newsticker-group-delete-group) - (define-key map "\M-r" 'newsticker-group-rename-group) - (define-key map [M-down] 'newsticker-group-shift-feed-down) - (define-key map [M-up] 'newsticker-group-shift-feed-up) - (define-key map [M-S-down] 'newsticker-group-shift-group-down) - (define-key map [M-S-up] 'newsticker-group-shift-group-up) + (define-key map " " #'newsticker-treeview-next-page) + (define-key map "a" #'newsticker-add-url) + (define-key map "b" #'newsticker-treeview-browse-url-item) + (define-key map "c" #'newsticker-treeview-customize-current-feed) + (define-key map "F" #'newsticker-treeview-prev-feed) + (define-key map "f" #'newsticker-treeview-next-feed) + (define-key map "g" #'newsticker-treeview-get-news) + (define-key map "G" #'newsticker-get-all-news) + (define-key map "i" #'newsticker-treeview-toggle-item-immortal) + (define-key map "j" #'newsticker-treeview-jump) + (define-key map "n" #'newsticker-treeview-next-item) + (define-key map "N" #'newsticker-treeview-next-new-or-immortal-item) + (define-key map "O" #'newsticker-treeview-mark-list-items-old) + (define-key map "o" #'newsticker-treeview-mark-item-old) + (define-key map "p" #'newsticker-treeview-prev-item) + (define-key map "P" #'newsticker-treeview-prev-new-or-immortal-item) + (define-key map "q" #'newsticker-treeview-quit) + (define-key map "S" #'newsticker-treeview-save-item) + (define-key map "s" #'newsticker-treeview-save) + (define-key map "u" #'newsticker-treeview-update) + (define-key map "v" #'newsticker-treeview-browse-url) + ;;(define-key map "\n" #'newsticker-treeview-scroll-item) + ;;(define-key map "\C-m" #'newsticker-treeview-scroll-item) + (define-key map "\M-m" #'newsticker-group-move-feed) + (define-key map "\M-a" #'newsticker-group-add-group) + (define-key map "\M-d" #'newsticker-group-delete-group) + (define-key map "\M-r" #'newsticker-group-rename-group) + (define-key map [M-down] #'newsticker-group-shift-feed-down) + (define-key map [M-up] #'newsticker-group-shift-feed-up) + (define-key map [M-S-down] #'newsticker-group-shift-group-down) + (define-key map [M-S-up] #'newsticker-group-shift-group-up) map) "Mode map for newsticker treeview.") diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 0ce65a35ead..1d9ee6db86c 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -640,7 +640,7 @@ References: [1]: Sotirov A, Stevens M et al (2008). \"MD5 considered harmful today - Creating a rogue CA certificate\", -`http://www.win.tue.nl/hashclash/rogue-ca/' +`https://www.win.tue.nl/hashclash/rogue-ca/' [2]: Turner S, Chen L (2011). \"Updated Security Considerations for the MD5 Message-Digest and the HMAC-MD5 Algorithms\", `https://tools.ietf.org/html/rfc6151'" diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index dcac36f2a4a..a267ac319b6 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -551,8 +551,8 @@ Returns the process associated with the connection." (when result (let ((response (plist-get (cdr result) :greeting))) (setq pop3-timestamp - (substring response (or (string-match "<" response) 0) - (+ 1 (or (string-match ">" response) -1))))) + (substring response (or (string-search "<" response) 0) + (+ 1 (or (string-search ">" response) -1))))) (set-process-query-on-exit-flag (car result) nil) (erase-buffer) (car result))))) @@ -725,9 +725,9 @@ Otherwise, return the size of the message-id MSG." (setq pop3-read-point (point-marker)) (goto-char (match-beginning 0)) (setq end (point-marker)) - (mapcar #'(lambda (s) (let ((split (split-string s " "))) - (cons (string-to-number (nth 0 split)) - (string-to-number (nth 1 split))))) + (mapcar (lambda (s) (let ((split (split-string s " "))) + (cons (string-to-number (nth 0 split)) + (string-to-number (nth 1 split))))) (split-string (buffer-substring start end) "\r\n" t))))))) (defun pop3-retr (process msg crashbuf) diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 6b3663a5fb2..42a7e796798 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -37,7 +37,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." ;; add a check first to avoid doing unnecessary work. (if (string-match "\\`[[:ascii:]]+\\'" domain) domain - (mapconcat 'puny-encode-string (split-string domain "[.]") "."))) + (mapconcat #'puny-encode-string (split-string domain "[.]") "."))) (defun puny-encode-string (string) "Encode STRING according to the IDNA/punycode algorithm. @@ -57,7 +57,7 @@ For instance, \"bücher\" => \"xn--bcher-kva\"." (defun puny-decode-domain (domain) "Decode DOMAIN according to the IDNA/punycode algorithm. For instance, \"xn--ff-2sa.org\" => \"fśf.org\"." - (mapconcat 'puny-decode-string (split-string domain "[.]") ".")) + (mapconcat #'puny-decode-string (split-string domain "[.]") ".")) (defun puny-decode-string (string) "Decode an IDNA/punycode-encoded string. @@ -75,7 +75,7 @@ For instance \"xn--bcher-kva\" => \"bücher\"." (defconst puny-damp 700) (defconst puny-tmin 1) (defconst puny-tmax 26) -(defconst puny-skew 28) +(defconst puny-skew 38) ;; 0-25 a-z ;; 26-36 0-9 diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index ab1f43f552b..2574c8cb63e 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -1,4 +1,4 @@ -;;; quickurl.el --- insert a URL based on text at point in buffer +;;; quickurl.el --- insert a URL based on text at point in buffer -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -97,23 +97,19 @@ (locate-user-emacs-file "quickurls" ".quickurls") "File that contains the URL list." :version "24.4" ; added locate-user-emacs-file - :type 'file - :group 'quickurl) + :type 'file) (defcustom quickurl-format-function #'quickurl-format-url "Function to format the URL before insertion into the current buffer." - :type 'function - :group 'quickurl) + :type 'function) (defcustom quickurl-sort-function #'quickurl-sort-urls "Function to sort the URL list." - :type 'function - :group 'quickurl) + :type 'function) (defcustom quickurl-grab-lookup-function #'current-word "Function to grab the thing to lookup." - :type 'function - :group 'quickurl) + :type 'function) (defun quickurl--assoc-function (key alist) "Default function for `quickurl-assoc-function'." @@ -122,31 +118,26 @@ (defcustom quickurl-assoc-function #'quickurl--assoc-function "Function to use for alist lookup into `quickurl-urls'." :version "26.1" ; was the obsolete assoc-ignore-case - :type 'function - :group 'quickurl) + :type 'function) (defcustom quickurl-completion-ignore-case t "Should `quickurl-ask' ignore case when doing the input lookup?" - :type 'boolean - :group 'quickurl) + :type 'boolean) (defcustom quickurl-prefix ";; -*- lisp -*-\n\n" "Text to write to `quickurl-url-file' before writing the URL list." - :type 'string - :group 'quickurl) + :type 'string) (defcustom quickurl-postfix "" "Text to write to `quickurl-url-file' after writing the URL list. See the constant `quickurl-reread-hook-postfix' for some example text that could be used here." - :type 'string - :group 'quickurl) + :type 'string) (defcustom quickurl-list-mode-hook nil "Hooks for `quickurl-list-mode'." - :type 'hook - :group 'quickurl) + :type 'hook) ;; Constants. diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 58cc8b1be55..e7aec505b0b 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -25,7 +25,7 @@ ;;; Commentary: ;; Internet Relay Chat (IRC) is a form of instant communication over -;; the Internet. It is mainly designed for group (many-to-many) +;; the Internet. It is mainly designed for group (many-to-many) ;; communication in discussion forums called channels, but also allows ;; one-to-one communication. @@ -44,7 +44,10 @@ (require 'cl-lib) (require 'ring) (require 'time-date) +(require 'auth-source) +(require 'parse-time) (eval-when-compile (require 'subr-x)) +(eval-when-compile (require 'rx)) (defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version)) @@ -56,10 +59,10 @@ :group 'applications) (defcustom rcirc-server-alist - '(("chat.freenode.net" :channels ("#rcirc") - ;; Don't use the TLS port by default, in case gnutls is not available. - ;; :port 7000 :encryption tls - )) + (if (gnutls-available-p) + '(("irc.libera.chat" :channels ("#rcirc") + :port 6697 :encryption tls)) + '(("irc.libera.chat" :channels ("#rcirc")))) "An alist of IRC connections to establish when running `rcirc'. Each element looks like (SERVER-NAME PARAMETERS). @@ -108,8 +111,9 @@ for connections using SSL/TLS. `:server-alias' -VALUE must be a string that will be used instead of the server name for -display purposes. If absent, the real server name will be displayed instead." +VALUE must be a string that will be used instead of the server +name for display purposes. If absent, the real server name will +be displayed instead." :type '(alist :key-type string :value-type (plist :options ((:nick string) @@ -120,7 +124,8 @@ display purposes. If absent, the real server name will be displayed instead." (:channels (repeat string)) (:encryption (choice (const tls) (const plain))) - (:server-alias string))))) + (:server-alias string)))) + :version "28.1") (defcustom rcirc-default-port 6667 "The default port to connect to." @@ -179,24 +184,36 @@ If nil, no maximum is applied." (integer :tag "Number of characters"))) (defvar-local rcirc-ignore-buffer-activity-flag nil - "If non-nil, ignore activity in this buffer.") + "Non-nil means ignore activity in this buffer.") (defvar-local rcirc-low-priority-flag nil - "If non-nil, activity in this buffer is considered low priority.") + "Non-nil means activity in this buffer is considered low priority.") (defcustom rcirc-omit-responses '("JOIN" "PART" "QUIT" "NICK") "Responses which will be hidden when `rcirc-omit-mode' is enabled." :type '(repeat string)) -(defvar rcirc-prompt-start-marker nil) +(defcustom rcirc-omit-after-reconnect + '("JOIN" "TOPIC" "NAMES") + "Types of messages to hide right after reconnecting." + :type '(repeat string) + :version "28.1") + +(defvar-local rcirc-reconncting nil + "Non-nil means we have just reconnected. +This is used to hide the message types enumerated in +`rcirc-supress-after-reconnect'.") + +(defvar-local rcirc-prompt-start-marker nil + "Marker indicating the beginning of the message prompt.") (define-minor-mode rcirc-omit-mode "Toggle the hiding of \"uninteresting\" lines. Uninteresting lines are those whose responses are listed in `rcirc-omit-responses'." - nil " Omit" nil + :lighter " Omit" (if rcirc-omit-mode (progn (add-to-invisibility-spec '(rcirc-omit . nil)) @@ -228,8 +245,7 @@ number. If zero or nil, no truncating is done." (integer :tag "Number of lines"))) (defcustom rcirc-scroll-show-maximum-output t - "If non-nil, scroll buffer to keep the point at the bottom of -the window." + "Non-nil means scroll to keep the point at the bottom of the window." :type 'boolean) (defcustom rcirc-authinfo nil @@ -245,13 +261,15 @@ The ARGUMENTS for each METHOD symbol are: `chanserv': NICK CHANNEL PASSWORD `bitlbee': NICK PASSWORD `quakenet': ACCOUNT PASSWORD + `sasl': NICK PASSWORD Examples: - ((\"freenode\" nickserv \"bob\" \"p455w0rd\") - (\"freenode\" chanserv \"bob\" \"#bobland\" \"passwd99\") + ((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\") + (\"Libera.Chat\" chanserv \"bob\" \"#bobland\" \"passwd99\") (\"bitlbee\" bitlbee \"robert\" \"sekrit\") (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") - (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))" + (\"quakenet.org\" quakenet \"bobby\" \"sekrit\") + (\"oftc\" sasl \"bob\" \"hunter2\"))" :type '(alist :key-type (regexp :tag "Server") :value-type (choice (list :tag "NickServ" (const nickserv) @@ -269,6 +287,10 @@ Examples: (list :tag "QuakeNet" (const quakenet) (string :tag "Account") + (string :tag "Password")) + (list :tag "SASL" + (const sasl) + (string :tag "Nick") (string :tag "Password"))))) (defcustom rcirc-auto-authenticate-flag t @@ -290,10 +312,11 @@ The following replacements are made: %s is the server. %t is the buffer target, a channel or a user. -Setting this alone will not affect the prompt; -use either M-x customize or also call `rcirc-update-prompt'." +Setting this alone will not affect the prompt; use either +\\[execute-extended-command] customize or also call +`rcirc-update-prompt'." :type 'string - :set 'rcirc-set-changed + :set #'rcirc-set-changed :initialize 'custom-initialize-default) (defcustom rcirc-keywords nil @@ -329,7 +352,8 @@ Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT." :type 'hook) (defvar rcirc-authenticated-hook nil - "Hook run after successfully authenticated.") + "Hook run after successfully authenticated. +Functions in this hook are called with a single argument PROCESS.") (defcustom rcirc-always-use-server-buffer-flag nil "Non-nil means messages without a channel target will go to the server buffer." @@ -384,13 +408,21 @@ will be killed." :version "24.3" :type 'boolean) -(defvar rcirc-nick nil) +(defcustom rcirc-nick-filter #'identity + "Function applied to nicknames before displaying." + :version "28.1" + :type 'function) + +(defvar-local rcirc-nick nil + "The nickname used for the current connection.") -(defvar rcirc-prompt-end-marker nil) +(defvar-local rcirc-prompt-end-marker nil + "Marker indicating the end of the message prompt.") -(defvar rcirc-nick-table nil) +(defvar-local rcirc-nick-table nil + "Hash table mapping nicks to channels.") -(defvar rcirc-recent-quit-alist nil +(defvar-local rcirc-recent-quit-alist nil "Alist of nicks that have recently quit or parted the channel.") (defvar rcirc-nick-syntax-table @@ -401,8 +433,8 @@ will be killed." table) "Syntax table which includes all nick characters as word constituents.") -;; each process has an alist of (target . buffer) pairs -(defvar rcirc-buffer-alist nil) +(defvar-local rcirc-buffer-alist nil + "Alist of (TARGET . BUFFER) pairs.") (defvar rcirc-activity nil "List of buffers with unviewed activity.") @@ -411,16 +443,16 @@ will be killed." "String displayed in mode line representing `rcirc-activity'.") (put 'rcirc-activity-string 'risky-local-variable t) -(defvar rcirc-server-buffer nil +(defvar-local rcirc-server-buffer nil "The server buffer associated with this channel buffer.") -(defvar rcirc-server-parameters nil +(defvar-local rcirc-server-parameters nil "List of parameters received from the server.") -(defvar rcirc-target nil +(defvar-local rcirc-target nil "The channel or user associated with this buffer.") -(defvar rcirc-urls nil +(defvar-local rcirc-urls nil "List of URLs seen in the current buffer and their start positions.") (put 'rcirc-urls 'permanent-local t) @@ -428,7 +460,8 @@ will be killed." "Kill connection after this many seconds if there is no activity.") -(defvar rcirc-startup-channels nil) +(defvar-local rcirc-startup-channels nil + "List of channel names to join after authenticating.") (defvar rcirc-server-name-history nil "History variable for \\[rcirc] call.") @@ -498,6 +531,12 @@ If ARG is non-nil, instead prompt for connection parameters." (encryption (plist-get (cdr c) :encryption)) (server-alias (plist-get (cdr c) :server-alias)) contact) + (when-let (((not password)) + (auth (auth-source-search :host server + :user user-name + :port port)) + (fn (plist-get (car auth) :secret))) + (setq password (funcall fn))) (when server (let (connected) (dolist (p (rcirc-process-list)) @@ -529,23 +568,78 @@ If ARG is non-nil, instead prompt for connection parameters." (defalias 'irc 'rcirc) -(defvar rcirc-process-output nil) -(defvar rcirc-topic nil) -(defvar rcirc-keepalive-timer nil) -(defvar rcirc-last-server-message-time nil) -(defvar rcirc-server nil) ; server provided by server -(defvar rcirc-server-name nil) ; server name given by 001 response -(defvar rcirc-timeout-timer nil) -(defvar rcirc-user-authenticated nil) -(defvar rcirc-user-disconnect nil) -(defvar rcirc-connecting nil) -(defvar rcirc-connection-info nil) -(defvar rcirc-process nil) +(defvar-local rcirc-process-output nil + "Partial message response.") +(defvar-local rcirc-topic nil + "Topic of the current channel.") +(defvar rcirc-keepalive-timer nil + "Timer for sending KEEPALIVE message.") +(defvar-local rcirc-last-server-message-time nil + "Timestamp for the last server response.") +(defvar-local rcirc-server nil + "Server provided by server.") +(defvar-local rcirc-server-name nil + "Server name given by 001 response.") +(defvar-local rcirc-timeout-timer nil + "Timer for determining a network timeout.") +(defvar-local rcirc-user-authenticated nil + "Flag indicating if the user is authenticated.") +(defvar-local rcirc-user-disconnect nil + "Flag indicating if the connection was broken.") +(defvar-local rcirc-connecting nil + "Flag indicating if the connection is being established.") +(defvar-local rcirc-connection-info nil + "Information about the current connection. +If defined, it is a list of this form (SERVER PORT NICK USER-NAME +FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS). +See `rcirc-connect' for more details on these variables.") +(defvar-local rcirc-process nil + "Network process for the current connection.") + +;;; IRCv3 capability negotiation (https://ircv3.net/specs/extensions/capability-negotiation) +(defvar rcirc-implemented-capabilities + '("message-tags" ;https://ircv3.net/specs/extensions/message-tags + "server-time" ;https://ircv3.net/specs/extensions/server-time + "batch" ;https://ircv3.net/specs/extensions/batch + "message-ids" ;https://ircv3.net/specs/extensions/message-ids + "invite-notify" ;https://ircv3.net/specs/extensions/invite-notify + "sasl" ;https://ircv3.net/specs/extensions/sasl-3.1 + ) + "A list of capabilities that rcirc supports.") +(defvar-local rcirc-requested-capabilities nil + "A list of capabilities that client has requested.") +(defvar-local rcirc-acked-capabilities nil + "A list of capabilities that the server supports.") +(defvar-local rcirc-finished-sasl t + "Check whether SASL authentication has completed") + +(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)))))) + +(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))))))) ;;;###autoload (defun rcirc-connect (server &optional port nick user-name full-name startup-channels password encryption server-alias) + "Connect to SERVER. +The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, +ENCRYPTION, SERVER-ALIAS are interpreted as in +`rcirc-server-alist'. STARTUP-CHANNELS is a list of channels +that are joined after authentication." (save-excursion (message "Connecting to %s..." (or server-alias server)) (let* ((inhibit-eol-conversion) @@ -558,6 +652,7 @@ If ARG is non-nil, instead prompt for connection parameters." (user-name (or user-name rcirc-default-user-name)) (full-name (or full-name rcirc-default-full-name)) (startup-channels startup-channels) + (use-sasl (eq (rcirc-get-server-method server) 'sasl)) (process (open-network-stream (or server-alias server) nil server port-number :type (or encryption 'plain)))) @@ -565,38 +660,42 @@ If ARG is non-nil, instead prompt for connection parameters." (set-process-coding-system process 'raw-text 'raw-text) (switch-to-buffer (rcirc-generate-new-buffer-name process nil)) (set-process-buffer process (current-buffer)) - (rcirc-mode process nil) + (unless (eq major-mode 'rcirc-mode) + (rcirc-mode process nil)) (set-process-sentinel process 'rcirc-sentinel) (set-process-filter process 'rcirc-filter) - (setq-local rcirc-connection-info - (list server port nick user-name full-name startup-channels - password encryption server-alias)) - (setq-local rcirc-process process) - (setq-local rcirc-server server) - (setq-local rcirc-server-name - (or server-alias server)) ; Update when we get 001 response. - (setq-local rcirc-buffer-alist nil) - (setq-local rcirc-nick-table (make-hash-table :test 'equal)) - (setq-local rcirc-nick nick) - (setq-local rcirc-process-output nil) - (setq-local rcirc-startup-channels startup-channels) - (setq-local rcirc-last-server-message-time (current-time)) - - (setq-local rcirc-timeout-timer nil) - (setq-local rcirc-user-disconnect nil) - (setq-local rcirc-user-authenticated nil) - (setq-local rcirc-connecting t) - (setq-local rcirc-server-parameters nil) + (setq rcirc-connection-info + (list server port nick user-name full-name startup-channels + password encryption server-alias)) + (setq rcirc-process process) + (setq rcirc-server server) + (setq rcirc-server-name (or server-alias server)) ; Update when we get 001 response. + (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-connecting t) (add-hook 'auto-save-hook 'rcirc-log-write) + (when use-sasl + (rcirc-send-string process "CAP REQ sasl")) + (when use-sasl + (setq-local rcirc-finished-sasl nil)) ;; identify + (dolist (cap rcirc-implemented-capabilities) + (rcirc-send-string process "CAP" "REQ" : cap) + (push cap rcirc-requested-capabilities)) (unless (zerop (length password)) - (rcirc-send-string process (concat "PASS " password))) - (rcirc-send-string process (concat "NICK " nick)) - (rcirc-send-string process (concat "USER " user-name - " 0 * :" full-name)) + (rcirc-send-string process "PASS" password)) + (rcirc-send-string process "NICK" nick) + (rcirc-send-string process "USER" user-name "0" "*" : full-name) + ;; Setup sasl, and initiate authentication. + (when (and rcirc-auto-authenticate-flag + use-sasl) + (rcirc-send-string process "AUTHENTICATE" "PLAIN")) ;; setup ping timer if necessary (unless rcirc-keepalive-timer @@ -604,31 +703,33 @@ If ARG is non-nil, instead prompt for connection parameters." (run-at-time 0 (/ rcirc-timeout-seconds 2) 'rcirc-keepalive))) (message "Connecting to %s...done" (or server-alias server)) + (setq mode-line-process nil) ;; return process object process))) (defmacro with-rcirc-process-buffer (process &rest body) + "Evaluate BODY in the buffer of PROCESS." (declare (indent 1) (debug t)) `(with-current-buffer (process-buffer ,process) ,@body)) (defmacro with-rcirc-server-buffer (&rest body) + "Evaluate BODY in the server buffer of the current channel." (declare (indent 0) (debug t)) - `(with-current-buffer rcirc-server-buffer - ,@body)) + `(if (buffer-live-p rcirc-server-buffer) + (with-current-buffer rcirc-server-buffer + ,@body) + (user-error "Server buffer was killed"))) (define-obsolete-function-alias 'rcirc-float-time 'float-time "26.1") (defun rcirc-prompt-for-encryption (server-plist) "Prompt the user for the encryption method to use. SERVER-PLIST is the property list for the server." - (let ((choices '("plain" "tls")) - (default (or (plist-get server-plist :encryption) - "plain"))) - (intern - (completing-read (format-prompt "Encryption" default) - choices nil t nil nil default)))) + (if (or (eq (plist-get server-plist :encryption) 'plain) + (yes-or-no-p "Encrypt connection?")) + 'tls 'plain)) (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. @@ -649,14 +750,18 @@ last ping." (setq rcirc-keepalive-timer nil))) (defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message) + "Uptime header in PROCESS buffer. +MESSAGE should contain a timestamp, indicating when the KEEPALIVE +message was generated." (with-rcirc-process-buffer process (setq header-line-format (format "%f" (float-time (time-since (string-to-number message))))))) -(defvar rcirc-debug-buffer "*rcirc debug*") +(defvar rcirc-debug-buffer "*rcirc debug*" + "Buffer name for debugging messages.") (defvar rcirc-debug-flag nil - "If non-nil, write information to `rcirc-debug-buffer'.") + "Non-nil means write information to `rcirc-debug-buffer'.") (defun rcirc-debug (process text) "Add an entry to the debug log including PROCESS and TEXT. Debug text is appended to `rcirc-debug-buffer' if `rcirc-debug-flag' @@ -690,12 +795,12 @@ When 0, do not auto-reconnect." :version "25.1" :type 'integer) -(defvar rcirc-last-connect-time nil +(defvar-local rcirc-last-connect-time nil "The last time the buffer was connected.") (defun rcirc-sentinel (process sentinel) "Called when PROCESS receives SENTINEL." - (let ((sentinel (replace-regexp-in-string "\n" "" sentinel))) + (let ((sentinel (string-replace "\n" "" sentinel))) (rcirc-debug process (format "SENTINEL: %S %S\n" process sentinel)) (with-rcirc-process-buffer process (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) @@ -718,6 +823,8 @@ When 0, do not auto-reconnect." (run-hook-with-args 'rcirc-sentinel-functions process sentinel)))) (defun rcirc-disconnect-buffer (&optional buffer) + "Disconnect BUFFER. +If BUFFER is nil, default to the current buffer." (with-current-buffer (or buffer (current-buffer)) ;; set rcirc-target to nil for each channel so cleanup ;; doesn't happen when we reconnect @@ -755,19 +862,19 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (rcirc-process-server-response process line)))))) (defun rcirc-reschedule-timeout (process) + "Update timeout indicator for PROCESS." (with-rcirc-process-buffer process (when (not rcirc-connecting) (with-rcirc-process-buffer process (when rcirc-timeout-timer (cancel-timer rcirc-timeout-timer)) (setq rcirc-timeout-timer (run-at-time rcirc-timeout-seconds nil - 'rcirc-delete-process + 'delete-process process)))))) -(defun rcirc-delete-process (process) - (delete-process process)) - -(defvar rcirc-trap-errors-flag t) +(defvar rcirc-trap-errors-flag t + "Non-nil means Lisp errors are degraded to error messages.") (defun rcirc-process-server-response (process text) + "Parse TEXT as received from PROCESS." (if rcirc-trap-errors-flag (condition-case err (rcirc-process-server-response-1 process text) @@ -776,17 +883,91 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (format "\"%s\" %s" text err) t))) (rcirc-process-server-response-1 process text))) +(defconst rcirc-process-regexp + (rx-let ((message-tag ; message tags as specified in + ; https://ircv3.net/specs/extensions/message-tags + (: (? "+") + (? (+ (or alnum "-")) (+ "." (+ (or alnum "-"))) "/") + (+ (any alnum "-")) + (? "=" + (* (not (any 0 ?\n ?\r ?\; ?\s))))))) + (rx line-start + (optional "@" (group message-tag (* ";" message-tag)) (+ space)) + ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1. + ;; We're a bit more accepting than the RFC: We allow any non-space + ;; characters in the command name, multiple spaces between + ;; arguments, and allow the last argument to omit the leading ":", + ;; even if there are less than 15 arguments. + (optional + (group ":" (group (one-or-more (not (any " ")))) " ")) + (group (one-or-more (not (any " ")))))) + "Regular expression used for parsing server response.") + +(defconst rcirc-tag-regexp + (rx bos + (group + (? "+") + (? (+ (or alnum "-")) (+ "." (+ (or alnum "-"))) "/") + (+ (any alnum "-"))) + (? "=" (group (* (not (any 0 ?\n ?\r ?\; ?\s))))) + eos) + "Regular expression used for destructing a tag.") + +(defvar rcirc-message-tags nil + "Alist of parsed message tags.") + +(defvar rcirc-supported-batch-types + '() + "List of recognized batch types. +Each element has the form (TYPE HANDLE), where TYPE is a string +and HANDLE is either the symbol `immediate' or `deferred'. +Messages in an immediate batch are handled just like regular +messages, while deferred messages are stored in +`rcirc-batch-messages'.") + +(defvar-local rcirc-batch-attributes nil + "Alist mapping batch IDs to parameters.") + +(defvar-local rcirc-batched-messages nil + "Alist mapping batch IDs to deferred messages. +Note that the messages are stored in reverse order.") + +(defsubst rcirc-get-tag (key &optional default) + "Return tag value for KEY or DEFAULT." + (alist-get key rcirc-message-tags default nil #'string=)) + (defun rcirc-process-server-response-1 (process text) - ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1. We're a - ;; bit more accepting than the RFC: We allow any non-space - ;; characters in the command name, multiple spaces between - ;; arguments, and allow the last argument to omit the leading ":", - ;; even if there are less than 15 arguments. - (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\)" text) - (let* ((user (match-string 2 text)) + "Parse TEXT as received from PROCESS." + (if (string-match rcirc-process-regexp text) + (let* ((rcirc-message-tags + (append + (and-let* ((tag-data (match-string 1 text))) + (save-match-data + (mapcar + (lambda (tag) + (unless (string-match rcirc-tag-regexp tag) + ;; This should not happen, unless there is + ;; a mismatch between this regular + ;; expression and `rcirc-process-regexp'. + (error "Malformed tag %S" tag)) + (cons (match-string 1 tag) + (replace-regexp-in-string + (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) + (lambda (rep) + (concat (substring rep 0 -2) + (cl-case (aref rep (1- (length rep))) + (?: ";") + (?s " ") + (?\\ "\\\\") + (?r "\r") + (?n "\n")))) + (match-string 2 tag)))) + (split-string tag-data ";")))) + rcirc-message-tags)) + (user (match-string 3 text)) (sender (rcirc-user-nick user)) - (cmd (match-string 3 text)) - (cmd-end (match-end 3)) + (cmd (match-string 4 text)) + (cmd-end (match-end 4)) (args nil) (handler (intern-soft (concat "rcirc-handler-" cmd)))) (cl-loop with i = cmd-end @@ -799,9 +980,18 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (push (substring text (match-end 0)) args) (cl-assert (= i (length text)))) (cl-callf nreverse args))) - (if (not (fboundp handler)) - (rcirc-handler-generic process cmd sender args text) - (funcall handler process sender args text)) + (cond ((and-let* ((batch-id (rcirc-get-tag "batch")) + (type (cadr (assoc batch-id rcirc-batch-attributes))) + (attr (assoc type rcirc-supported-batch-types)) + ((eq (cadr attr) 'deferred))) + ;; handle deferred batch messages later + (push (list cmd process sender args text rcirc-message-tags) + (alist-get batch-id rcirc-batched-messages + nil nil #'string=)) + t)) + ((not (fboundp handler)) + (rcirc-handler-generic process cmd sender args text)) + ((funcall handler process sender args text))) (run-hook-with-args 'rcirc-receive-message-functions process cmd sender args text)) (message "UNHANDLED: %s" text))) @@ -810,17 +1000,34 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") "Responses that don't trigger activity in the mode-line indicator.") (defun rcirc-handler-generic (process response sender args _text) - "Generic server response handler." + "Generic server response handler. +This handler is called, when no more specific handler could be +found. PROCESS, SENDER and RESPONSE are passed on to +`rcirc-print'. ARGS are concatenated into a single string and +used as the message body." (rcirc-print process sender response nil (mapconcat 'identity (cdr args) " ") (not (member response rcirc-responses-no-activity)))) (defun rcirc--connection-open-p (process) + "Check if PROCESS is open or running." (memq (process-status process) '(run open))) -(defun rcirc-send-string (process string) - "Send PROCESS a STRING plus a newline." - (let ((string (concat (encode-coding-string string rcirc-encode-coding-system) +(defun rcirc-send-string (process &rest parts) + "Send PROCESS a PARTS plus a newline. +PARTS may contain a `:' symbol, to designate that the next string +is the message, that should be prefixed by a colon. If the last +element in PARTS is a list, append it to PARTS." + (let ((last (car (last parts)))) + (when (listp last) + (setf parts (append (butlast parts) last)))) + (when-let (message (memq : parts)) + (cl-check-type (cadr message) string) + (setf (cadr message) (concat ":" (cadr message)) + parts (remq : parts))) + (let ((string (concat (encode-coding-string + (mapconcat #'identity parts " ") + rcirc-encode-coding-system) "\n"))) (unless (rcirc--connection-open-p process) (error "Network connection to %s is not open" @@ -829,13 +1036,17 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (process-send-string process string))) (defun rcirc-send-privmsg (process target string) + "Send TARGET the message in STRING via PROCESS." (cl-check-type target string) - (rcirc-send-string process (format "PRIVMSG %s :%s" target string))) + (rcirc-send-string process "PRIVMSG" target : string)) + +(defun rcirc-ctcp-wrap (&rest args) + "Join ARGS into a string wrapped by ASCII 1 charterers." + (concat "\C-a" (string-join (delq nil args) " ") "\C-a")) (defun rcirc-send-ctcp (process target request &optional args) - (let ((args (if args (concat " " args) ""))) - (rcirc-send-privmsg process target - (format "\C-a%s%s\C-a" request args)))) + "Send TARGET a REQUEST via PROCESS." + (rcirc-send-privmsg process target (rcirc-ctcp-wrap request args))) (defun rcirc-buffer-process (&optional buffer) "Return the process associated with channel BUFFER. @@ -861,7 +1072,7 @@ With no argument or nil as argument, use the current buffer." "Return the nick associated with BUFFER. With no argument or nil as argument, use the current buffer." (with-current-buffer (or buffer (current-buffer)) - (with-current-buffer rcirc-server-buffer + (with-rcirc-server-buffer (or rcirc-nick rcirc-default-nick)))) (defvar rcirc-max-message-length 420 @@ -894,17 +1105,22 @@ If SILENT is non-nil, do not print the message in any irc buffer." (let ((response (if noticep "NOTICE" "PRIVMSG"))) (rcirc-get-buffer-create process target) (dolist (msg (rcirc-split-message message)) - (rcirc-send-string process (concat response " " target " :" msg)) + (rcirc-send-string process response target : msg) (unless silent (rcirc-print process (rcirc-nick process) response target msg))))) -(defvar rcirc-input-ring nil) -(defvar rcirc-input-ring-index 0) +(defvar-local rcirc-input-ring nil + "Ring object for input.") + +(defvar-local rcirc-input-ring-index 0 + "Current position in the input ring.") (defun rcirc-prev-input-string (arg) + "Move ARG elements ahead in the input ring." (ring-ref rcirc-input-ring (+ rcirc-input-ring-index arg))) (defun rcirc-insert-prev-input () + "Insert previous element in input ring." (interactive) (when (<= rcirc-prompt-end-marker (point)) (delete-region rcirc-prompt-end-marker (point-max)) @@ -912,6 +1128,7 @@ If SILENT is non-nil, do not print the message in any irc buffer." (setq rcirc-input-ring-index (1+ rcirc-input-ring-index)))) (defun rcirc-insert-next-input () + "Insert next element in input ring." (interactive) (when (<= rcirc-prompt-end-marker (point)) (delete-region rcirc-prompt-end-marker (point-max)) @@ -945,63 +1162,62 @@ The list is updated automatically by `defun-rcirc-command'.") (if (re-search-backward "[[:space:]@]" rcirc-prompt-end-marker t) (1+ (point)) rcirc-prompt-end-marker))) - (table (if (and (= beg rcirc-prompt-end-marker) - (eq (char-after beg) ?/)) - (delete-dups - (nconc (sort (copy-sequence rcirc-client-commands) - 'string-lessp) - (sort (copy-sequence rcirc-server-commands) - 'string-lessp))) - (rcirc-channel-nicks (rcirc-buffer-process) - rcirc-target)))) - (list beg (point) table)))) - -(defvar rcirc-completions nil) -(defvar rcirc-completion-start nil) - -(defun rcirc-complete () - "Cycle through completions from list of nicks in channel or IRC commands. -IRC command completion is performed only if `/' is the first input char." - (interactive) - (unless (rcirc-looking-at-input) - (error "Point not located after rcirc prompt")) - (if (eq last-command this-command) - (setq rcirc-completions - (append (cdr rcirc-completions) (list (car rcirc-completions)))) - (let ((completion-ignore-case t) - (table (rcirc-completion-at-point))) - (setq rcirc-completion-start (car table)) - (setq rcirc-completions - (and rcirc-completion-start - (all-completions (buffer-substring rcirc-completion-start - (cadr table)) - (nth 2 table)))))) - (let ((completion (car rcirc-completions))) - (when completion - (delete-region rcirc-completion-start (point)) - (insert - (cond - ((= (aref completion 0) ?/) (concat completion " ")) - ((= rcirc-completion-start rcirc-prompt-end-marker) - (format rcirc-nick-completion-format completion)) - (t completion)))))) - -(defun set-rcirc-decode-coding-system (coding-system) - "Set the decode coding system used in this channel." + (table (cond + ;; No completion before the prompt + ((< beg rcirc-prompt-end-marker) nil) + ;; Only complete nicks mid-message + ((> beg rcirc-prompt-end-marker) + (mapcar rcirc-nick-filter + (rcirc-channel-nicks + (rcirc-buffer-process) + rcirc-target))) + ;; Complete commands at the beginning of the + ;; message, when the first character is a dash + ((eq (char-after beg) ?/) + (mapcar + (lambda (cmd) (concat cmd " ")) + (nconc (sort (copy-sequence rcirc-client-commands) + 'string-lessp) + (sort (copy-sequence rcirc-server-commands) + 'string-lessp)))) + ;; Complete usernames right after the prompt by + ;; appending a colon after the name + ((mapcar + (lambda (str) (concat (funcall rcirc-nick-filter str) ": ")) + (rcirc-channel-nicks (rcirc-buffer-process) + rcirc-target)))))) + (list beg (point) + (lambda (str pred action) + (if (eq action 'metadata) + '(metadata (cycle-sort-function . identity)) + (complete-with-action action table str pred))))))) + +(defun rcirc-set-decode-coding-system (coding-system) + "Set the decode CODING-SYSTEM used in this channel." (interactive "zCoding system for incoming messages: ") (setq-local rcirc-decode-coding-system coding-system)) -(defun set-rcirc-encode-coding-system (coding-system) - "Set the encode coding system used in this channel." +(define-obsolete-function-alias + 'rcirc-set-decode-coding-system + 'set-rcirc-decode-coding-system + "28.1") + +(defun rcirc-set-encode-coding-system (coding-system) + "Set the encode CODING-SYSTEM used in this channel." (interactive "zCoding system for outgoing messages: ") (setq-local rcirc-encode-coding-system coding-system)) +(define-obsolete-function-alias + 'rcirc-set-encode-coding-system + 'set-rcirc-encode-coding-system + "28.1") + (defvar rcirc-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") 'rcirc-send-input) (define-key map (kbd "M-p") 'rcirc-insert-prev-input) (define-key map (kbd "M-n") 'rcirc-insert-next-input) - (define-key map (kbd "TAB") 'rcirc-complete) + (define-key map (kbd "TAB") 'completion-at-point) (define-key map (kbd "C-c C-b") 'rcirc-browse-url) (define-key map (kbd "C-c C-c") 'rcirc-edit-multiline) (define-key map (kbd "C-c C-j") 'rcirc-cmd-join) @@ -1024,34 +1240,35 @@ IRC command completion is performed only if `/' is the first input char." map) "Keymap for rcirc mode.") -(defvar rcirc-short-buffer-name nil +(defvar-local rcirc-short-buffer-name nil "Generated abbreviation to use to indicate buffer activity.") (defvar rcirc-mode-hook nil "Hook run when setting up rcirc buffer.") -(defvar rcirc-last-post-time nil) +(defvar-local rcirc-last-post-time nil + "Timestamp indicating last user action.") (defvar rcirc-log-alist nil "Alist of lines to log to disk when `rcirc-log-flag' is non-nil. Each element looks like (FILENAME . TEXT).") -(defvar rcirc-current-line 0 +(defvar-local rcirc-current-line 0 "The current number of responses printed in this channel. This number is independent of the number of lines in the buffer.") (defun rcirc-mode (process target) - ;; FIXME: Use define-derived-mode. "Major mode for IRC channel buffers. \\{rcirc-mode-map}" + ;; FIXME: Use define-derived-mode. (kill-all-local-variables) (use-local-map rcirc-mode-map) (setq mode-name "rcirc") (setq major-mode 'rcirc-mode) (setq mode-line-process nil) - (setq-local rcirc-input-ring + (setq rcirc-input-ring ;; If rcirc-input-ring is already a ring with desired ;; size do not re-initialize. (if (and (ring-p rcirc-input-ring) @@ -1059,18 +1276,14 @@ This number is independent of the number of lines in the buffer.") rcirc-input-ring-size)) rcirc-input-ring (make-ring rcirc-input-ring-size))) - (setq-local rcirc-server-buffer (process-buffer process)) - (setq-local rcirc-target target) - (setq-local rcirc-topic nil) - (setq-local rcirc-last-post-time (current-time)) + (setq rcirc-server-buffer (process-buffer process)) + (setq rcirc-target target) + (setq rcirc-last-post-time (current-time)) (setq-local fill-paragraph-function 'rcirc-fill-paragraph) - (setq-local rcirc-recent-quit-alist nil) - (setq-local rcirc-current-line 0) - (setq-local rcirc-last-connect-time (current-time)) + (setq rcirc-current-line 0) + (setq rcirc-last-connect-time (current-time)) (use-hard-newlines t) - (setq-local rcirc-short-buffer-name nil) - (setq-local rcirc-urls nil) ;; setup for omitting responses (setq buffer-invisibility-spec '()) @@ -1091,8 +1304,8 @@ This number is independent of the number of lines in the buffer.") (if (consp (cdr i)) (cddr i) (cdr i)))))) ;; setup the prompt and markers - (setq-local rcirc-prompt-start-marker (point-max-marker)) - (setq-local rcirc-prompt-end-marker (point-max-marker)) + (setq rcirc-prompt-start-marker (point-max-marker)) + (setq rcirc-prompt-end-marker (point-max-marker)) (rcirc-update-prompt) (goto-char rcirc-prompt-end-marker) @@ -1113,6 +1326,7 @@ This number is independent of the number of lines in the buffer.") (add-hook 'completion-at-point-functions 'rcirc-completion-at-point nil 'local) + (setq-local completion-cycle-threshold t) (run-mode-hooks 'rcirc-mode-hook)) @@ -1151,7 +1365,7 @@ If ALL is non-nil, update prompts in all IRC buffers." 'front-sticky t 'rear-nonsticky t)))))))) (defun rcirc-set-changed (option value) - "Set OPTION to VALUE and do updates after a customization change." + "Set OPTION to VALUE and update after a customization change." (set-default option value) (cond ((eq option 'rcirc-prompt) (rcirc-update-prompt 'all)) @@ -1165,9 +1379,10 @@ If ALL is non-nil, update prompts in all IRC buffers." (or (eq (aref target 0) ?#) (eq (aref target 0) ?&)))) -(defcustom rcirc-log-directory "~/.emacs.d/rcirc-log" +(defcustom rcirc-log-directory (locate-user-emacs-file "rcirc-log") "Directory to keep IRC logfiles." - :type 'directory) + :type 'directory + :version "28.1") (defcustom rcirc-log-flag nil "Non-nil means log IRC activity to disk. @@ -1193,10 +1408,11 @@ with it." (kill-buffer (cdr channel)))))) (defun rcirc-change-major-mode-hook () - "Part the channel when changing the major-mode." + "Part the channel when changing the major mode." (rcirc-clean-up-buffer "Changed major mode")) (defun rcirc-clean-up-buffer (reason) + "Clean up current buffer and part with REASON." (let ((buffer (current-buffer))) (rcirc-clear-activity buffer) (when (and (rcirc-buffer-process) @@ -1207,7 +1423,7 @@ with it." (rcirc-update-short-buffer-names) (if (rcirc-channel-p rcirc-target) (rcirc-send-string (rcirc-buffer-process) - (concat "PART " rcirc-target " :" reason)) + "PART" rcirc-target : reason) (when rcirc-target (rcirc-remove-nick-channel (rcirc-buffer-process) (rcirc-buffer-nick) @@ -1247,9 +1463,11 @@ Create the buffer if it doesn't exist." (let ((new-buffer (get-buffer-create (rcirc-generate-new-buffer-name process target)))) (with-current-buffer new-buffer - (rcirc-mode process target) + (unless (eq major-mode 'rcirc-mode) + (rcirc-mode process target))) + (setq mode-line-process nil) (rcirc-put-nick-channel process (rcirc-nick process) target - rcirc-current-line)) + rcirc-current-line) new-buffer))))) (defun rcirc-send-input () @@ -1285,6 +1503,8 @@ Create the buffer if it doesn't exist." (setq rcirc-input-ring-index 0)))))) (defun rcirc-fill-paragraph (&optional justify) + "Implementation for `fill-paragraph-function'. +The argument JUSTIFY is passed on to `fill-region'." (interactive "P") (when (> (point) rcirc-prompt-end-marker) (save-restriction @@ -1293,13 +1513,15 @@ Create the buffer if it doesn't exist." (fill-region (point-min) (point-max) justify))))) (defun rcirc-process-input-line (line) - (if (string-match "^/\\([^ ]+\\) ?\\(.*\\)$" line) + "Process LINE as a message or a command." + (if (string-match "^/\\([^/ ][^ ]*\\) ?\\(.*\\)$" line) (rcirc-process-command (match-string 1 line) (match-string 2 line) line) (rcirc-process-message line))) (defun rcirc-process-message (line) + "Process LINE as a message to be sent." (if (not rcirc-target) (message "Not joined (no target)") (delete-region rcirc-prompt-end-marker (point)) @@ -1307,28 +1529,31 @@ Create the buffer if it doesn't exist." (setq rcirc-last-post-time (current-time)))) (defun rcirc-process-command (command args line) - (if (eq (aref command 0) ?/) - ;; "//text" will send "/text" as a message - (rcirc-process-message (substring line 1)) - (let ((fun (intern-soft (concat "rcirc-cmd-" command))) - (process (rcirc-buffer-process))) - (newline) - (with-current-buffer (current-buffer) - (delete-region rcirc-prompt-end-marker (point)) - (if (string= command "me") - (rcirc-print process (rcirc-buffer-nick) - "ACTION" rcirc-target args) + "Process COMMAND with arguments ARGS. +LINE is the raw input, from which COMMAND and ARGS was +extracted." + (let ((fun (intern-soft (concat "rcirc-cmd-" command))) + (process (rcirc-buffer-process))) + (newline) + (with-current-buffer (current-buffer) + (delete-region rcirc-prompt-end-marker (point)) + (if (string= command "me") (rcirc-print process (rcirc-buffer-nick) - "COMMAND" rcirc-target line)) - (set-marker rcirc-prompt-end-marker (point)) - (if (fboundp fun) - (funcall fun args process rcirc-target) - (rcirc-send-string process - (concat command " :" args))))))) - -(defvar-local rcirc-parent-buffer nil) + "ACTION" rcirc-target args) + (rcirc-print process (rcirc-buffer-nick) + "COMMAND" rcirc-target line)) + (set-marker rcirc-prompt-end-marker (point)) + (if (fboundp fun) + (funcall fun args process rcirc-target) + (rcirc-send-string process command : args))))) + +(defvar-local rcirc-parent-buffer nil + "Message buffer that requested a multiline buffer.") (put 'rcirc-parent-buffer 'permanent-local t) -(defvar rcirc-window-configuration nil) + +(defvar rcirc-window-configuration nil + "Window configuration before creating multiline buffer.") + (defun rcirc-edit-multiline () "Move current edit to a dedicated buffer." (interactive) @@ -1358,9 +1583,7 @@ Create the buffer if it doesn't exist." (define-minor-mode rcirc-multiline-minor-mode "Minor mode for editing multiple lines in rcirc." - :init-value nil :lighter " rcirc-mline" - :keymap rcirc-multiline-minor-mode-map :global nil (setq fill-column rcirc-max-message-length)) @@ -1426,9 +1649,10 @@ the of the following escape sequences replaced by the described values: :value-type string)) (defun rcirc-format-response-string (process sender response target text) - "Return a nicely-formatted response string, incorporating TEXT -\(and perhaps other arguments). The specific formatting used -is found by looking up RESPONSE in `rcirc-response-formats'." + "Return a formatted response string from SENDER, incorporating TEXT. +The specific formatting used is found by looking up RESPONSE in +`rcirc-response-formats'. PROCESS is the process object used for +communication." (with-temp-buffer (insert (or (cdr (assoc response rcirc-response-formats)) (cdr (assq t rcirc-response-formats)))) @@ -1437,7 +1661,7 @@ is found by looking up RESPONSE in `rcirc-response-formats'." (sender (if (or (not sender) (string= (rcirc-server-name process) sender)) "" - sender)) + (funcall rcirc-nick-filter sender))) face) (while (re-search-forward "%\\(\\(f\\(.\\)\\)\\|\\(.\\)\\)" nil t) (rcirc-add-face start (match-beginning 0) face) @@ -1482,7 +1706,8 @@ is found by looking up RESPONSE in `rcirc-response-formats'." (buffer-substring (point-min) (point-max)))) (defun rcirc-target-buffer (process sender response target _text) - "Return a buffer to print the server response." + "Return a buffer to print the server response from SENDER. +PROCESS is the process object for the current connection." (cl-assert (not (bufferp target))) (with-rcirc-process-buffer process (cond ((not target) @@ -1498,8 +1723,9 @@ is found by looking up RESPONSE in `rcirc-response-formats'." ((or (rcirc-get-buffer process target) (rcirc-any-buffer process)))))) -(defvar-local rcirc-activity-types nil) (defvar-local rcirc-last-sender nil) +(defvar-local rcirc-activity-types nil + "List of symbols designating kinds of activities in a buffer.") (defcustom rcirc-omit-threshold 100 "Lines since last activity from a nick before `rcirc-omit-responses' are omitted." @@ -1512,14 +1738,16 @@ is found by looking up RESPONSE in `rcirc-response-formats'." (defun rcirc-last-quit-line (process nick target) "Return the line number where NICK left TARGET. -Returns nil if the information is not recorded." +Returns nil if the information is not recorded. +PROCESS is the process object for the current connection." (let ((chanbuf (rcirc-get-buffer process target))) (when chanbuf (cdr (assoc-string nick (with-current-buffer chanbuf rcirc-recent-quit-alist)))))) (defun rcirc-last-line (process nick target) - "Return the line from the last activity from NICK in TARGET." + "Return the line from the last activity from NICK in TARGET. +PROCESS is the process object for the current connection." (let ((line (or (cdr (assoc-string target (gethash nick (with-rcirc-server-buffer rcirc-nick-table)) t)) @@ -1530,7 +1758,8 @@ Returns nil if the information is not recorded." nil))) (defun rcirc-elapsed-lines (process nick target) - "Return the number of lines since activity from NICK in TARGET." + "Return the number of lines since activity from NICK in TARGET. +PROCESS is the process object for the current connection." (let ((last-activity-line (rcirc-last-line process nick target))) (when (and last-activity-line (> last-activity-line 0)) @@ -1538,11 +1767,12 @@ Returns nil if the information is not recorded." (defvar rcirc-markup-text-functions '(rcirc-markup-attributes + rcirc-color-attributes + rcirc-remove-markup-codes rcirc-markup-my-nick rcirc-markup-urls rcirc-markup-keywords rcirc-markup-bright-nicks) - "List of functions used to manipulate text before it is printed. Each function takes two arguments, SENDER, and RESPONSE. The @@ -1552,7 +1782,8 @@ at the beginning of the `rcirc-text' propertized text.") (defun rcirc-print (process sender response target text &optional activity) "Print TEXT in the buffer associated with TARGET. Format based on SENDER and RESPONSE. If ACTIVITY is non-nil, -record activity." +record activity. PROCESS is the process object for the current +connection." (or text (setq text "")) (unless (and (or (member sender rcirc-ignore-list) (member (with-syntax-table rcirc-nick-syntax-table @@ -1562,11 +1793,13 @@ record activity." ;; do not ignore if we sent the message (not (string= sender (rcirc-nick process)))) (let* ((buffer (rcirc-target-buffer process sender response target text)) + (time (if-let ((time (rcirc-get-tag "time"))) + (parse-iso8601-time-string time) + (current-time))) (inhibit-read-only t)) (with-current-buffer buffer (let ((moving (= (point) rcirc-prompt-end-marker)) - (old-point (point-marker)) - (fill-start (marker-position rcirc-prompt-start-marker))) + (old-point (point-marker))) (setq text (decode-coding-string text rcirc-decode-coding-system)) (unless (string= sender (rcirc-nick process)) @@ -1580,25 +1813,32 @@ record activity." ;; temporarily set the marker insertion-type because ;; insert-before-markers results in hidden text in new buffers (goto-char rcirc-prompt-start-marker) + (catch 'exit + (while (not (bobp)) + (goto-char (or (previous-single-property-change (point) 'hard) + (point-min))) + (when (let ((then (get-text-property (point) 'rcirc-time))) + (and then (not (time-less-p time then)))) + (next-single-property-change (point) 'hard) + (forward-char 1) + (throw 'exit nil)))) (set-marker-insertion-type rcirc-prompt-start-marker t) (set-marker-insertion-type rcirc-prompt-end-marker t) - (let ((start (point))) - (insert (rcirc-format-response-string process sender response nil - text) - (propertize "\n" 'hard t)) - - ;; squeeze spaces out of text before rcirc-text - (fill-region fill-start - (1- (or (next-single-property-change fill-start - 'rcirc-text) - rcirc-prompt-end-marker))) - - ;; run markup functions - (save-excursion - (save-restriction - (narrow-to-region start rcirc-prompt-start-marker) - (goto-char (or (next-single-property-change start 'rcirc-text) + ;; run markup functions + (cl-assert (bolp)) + (save-excursion + (save-restriction + (narrow-to-region (point) (point)) + (insert (propertize (rcirc-format-response-string process sender response + nil text) + 'rcirc-msgid (rcirc-get-tag "msgid")) + (propertize "\n" 'hard t)) + + ;; squeeze spaces out of text before rcirc-text + (fill-region (point-min) (point-max)) + + (goto-char (or (next-single-property-change (point-min) 'rcirc-text) (point))) (when (rcirc-buffer-process) (save-excursion (rcirc-markup-timestamp sender response)) @@ -1609,14 +1849,21 @@ record activity." (when rcirc-read-only-flag (add-text-properties (point-min) (point-max) - '(read-only t front-sticky t)))) - ;; make text omittable + '(read-only t front-sticky t))) + + (add-text-properties (point-min) (point-max) + (list 'rcirc-time time)) + + ;; make text omittable (let ((last-activity-lines (rcirc-elapsed-lines process sender target))) (if (and (not (string= (rcirc-nick process) sender)) - (member response rcirc-omit-responses) + (or (member response rcirc-omit-responses) + (if (member response rcirc-omit-after-reconnect) + rcirc-reconncting + (setq rcirc-reconncting nil))) (or (not last-activity-lines) (< rcirc-omit-threshold last-activity-lines))) - (put-text-property (1- start) (1- rcirc-prompt-start-marker) + (put-text-property (point-min) (point-max) 'invisible 'rcirc-omit) ;; otherwise increment the line count (setq rcirc-current-line (1+ rcirc-current-line)))))) @@ -1638,11 +1885,11 @@ record activity." (window-buffer w)) (>= (window-point w) rcirc-prompt-end-marker)) - (set-window-point w (point-max)))) + (set-window-point w (point-max)))) nil t) ;; restore the point - (goto-char (if moving rcirc-prompt-end-marker old-point)) + (goto-char (if moving rcirc-prompt-end-marker old-point))) ;; keep window on bottom line if it was already there (when rcirc-scroll-show-maximum-output @@ -1659,28 +1906,29 @@ record activity." ;; flush undo (can we do something smarter here?) (buffer-disable-undo) - (buffer-enable-undo)) - - ;; record mode line activity - (when (and activity - (not rcirc-ignore-buffer-activity-flag) - (not (and rcirc-dim-nicks sender - (string-match (regexp-opt rcirc-dim-nicks) sender) - (rcirc-channel-p target)))) - (rcirc-record-activity (current-buffer) - (when (not (rcirc-channel-p rcirc-target)) - 'nick))) - - (when (and rcirc-log-flag - (or target - rcirc-log-process-buffers)) - (rcirc-log process sender response target text)) - - (sit-for 0) ; displayed text before hook - (run-hook-with-args 'rcirc-print-functions - process sender response target text))))) + (buffer-enable-undo) + + ;; record mode line activity + (when (and activity + (not rcirc-ignore-buffer-activity-flag) + (not (and rcirc-dim-nicks sender + (string-match (regexp-opt rcirc-dim-nicks) sender) + (rcirc-channel-p target)))) + (rcirc-record-activity (current-buffer) + (when (not (rcirc-channel-p rcirc-target)) + 'nick))) + + (when (and rcirc-log-flag + (or target + rcirc-log-process-buffers)) + (rcirc-log process sender response target text)) + + (sit-for 0) ; displayed text before hook + (run-hook-with-args 'rcirc-print-functions + process sender response target text))))) (defun rcirc-generate-log-filename (process target) + "Return filename for log file based on PROCESS and TARGET." (if target (rcirc-generate-new-buffer-name process target) (process-name process))) @@ -1702,11 +1950,15 @@ guarantee valid filenames for the current OS." :type 'function) (defun rcirc-log (process sender response target text) - "Record line in `rcirc-log', to be later written to disk." - (let ((filename (funcall rcirc-log-filename-function process target))) + "Record TEXT from SENDER to TARGET to be logged. +The message is logged in `rcirc-log', and is later written to +disk. PROCESS is the process object for the current connection." + (let ((filename (funcall rcirc-log-filename-function process target)) + (time (and-let* ((time (rcirc-get-tag "time"))) + (parse-iso8601-time-string time)))) (unless (null filename) (let ((cell (assoc-string filename rcirc-log-alist)) - (line (concat (format-time-string rcirc-time-format) + (line (concat (format-time-string rcirc-time-format time) (substring-no-properties (rcirc-format-response-string process sender response target text)) @@ -1741,14 +1993,17 @@ log-files with absolute names (see `rcirc-log-filename-function')." rcirc-log-directory))) (defun rcirc-join-channels (process channels) - "Join CHANNELS." + "Join CHANNELS. +PROCESS is the process object for the current connection." (save-window-excursion (dolist (channel channels) (with-rcirc-process-buffer process (rcirc-cmd-join channel process))))) ;;; nick management -(defvar rcirc-nick-prefix-chars "~&@%+") +(defvar rcirc-nick-prefix-chars '(?~ ?& ?@ ?% ?+) + "List of junk characters to strip from nick prefixes.") + (defun rcirc-user-nick (user) "Return the nick from USER. Remove any non-nick junk." (save-match-data @@ -1758,7 +2013,8 @@ log-files with absolute names (see `rcirc-log-filename-function')." user))) (defun rcirc-nick-channels (process nick) - "Return list of channels for NICK." + "Return list of channels for NICK. +PROCESS is the process object for the current connection." (with-rcirc-process-buffer process (mapcar (lambda (x) (car x)) (gethash nick rcirc-nick-table)))) @@ -1768,7 +2024,7 @@ log-files with absolute names (see `rcirc-log-filename-function')." Update the associated linestamp if LINE is non-nil. If the record doesn't exist, and LINE is nil, set the linestamp -to zero." +to zero. PROCESS is the process object for the current connection." (let ((nick (rcirc-user-nick nick))) (with-rcirc-process-buffer process (let* ((chans (gethash nick rcirc-nick-table)) @@ -1780,12 +2036,14 @@ to zero." rcirc-nick-table)))))) (defun rcirc-nick-remove (process nick) - "Remove NICK from table." + "Remove NICK from table. +PROCESS is the process object for the current connection." (with-rcirc-process-buffer process (remhash nick rcirc-nick-table))) (defun rcirc-remove-nick-channel (process nick channel) - "Remove the CHANNEL from list associated with NICK." + "Remove the CHANNEL from list associated with NICK. +PROCESS is the process object for the current connection." (with-rcirc-process-buffer process (let* ((chans (gethash nick rcirc-nick-table)) (newchans @@ -1799,7 +2057,8 @@ to zero." (remhash nick rcirc-nick-table))))) (defun rcirc-channel-nicks (process target) - "Return the list of nicks associated with TARGET sorted by last activity." + "Return the list of nicks associated with TARGET sorted by last activity. +PROCESS is the process object for the current connection." (when target (if (rcirc-channel-p target) (with-rcirc-process-buffer process @@ -1818,8 +2077,9 @@ to zero." (list target)))) (defun rcirc-ignore-update-automatic (nick) - "Remove NICK from `rcirc-ignore-list' -if NICK is also on `rcirc-ignore-list-automatic'." + "Check if NICK is in `rcirc-ignore-list-automatic'. +If so, remove from `rcirc-ignore-list'. PROCESS is the process +object for the current connection." (when (member nick rcirc-ignore-list-automatic) (setq rcirc-ignore-list-automatic (delete nick rcirc-ignore-list-automatic) @@ -1827,7 +2087,7 @@ if NICK is also on `rcirc-ignore-list-automatic'." (delete nick rcirc-ignore-list)))) (defun rcirc-nickname< (s1 s2) - "Return t if IRC nickname S1 is less than S2, and nil otherwise. + "Return non-nil if IRC nickname S1 is less than S2, and nil otherwise. Operator nicknames (@) are considered less than voiced nicknames (+). Any other nicknames are greater than voiced nicknames. The comparison is case-insensitive." @@ -1849,7 +2109,7 @@ INPUT is a string containing nicknames separated by SEP. This function does not alter the INPUT string." (let* ((parts (split-string input sep t)) (sorted (sort parts 'rcirc-nickname<))) - (mapconcat 'identity sorted sep))) + (mapconcat rcirc-nick-filter sorted sep))) ;;; activity tracking (defvar rcirc-track-minor-mode-map @@ -1862,9 +2122,6 @@ This function does not alter the INPUT string." ;;;###autoload (define-minor-mode rcirc-track-minor-mode "Global minor mode for tracking activity in rcirc buffers." - :init-value nil - :lighter "" - :keymap rcirc-track-minor-mode-map :global t (or global-mode-string (setq global-mode-string '(""))) ;; toggle the mode-line channel indicator @@ -1880,12 +2137,8 @@ This function does not alter the INPUT string." (remove-hook 'window-configuration-change-hook 'rcirc-window-configuration-change))) -(or (assq 'rcirc-ignore-buffer-activity-flag minor-mode-alist) - (setq minor-mode-alist - (cons '(rcirc-ignore-buffer-activity-flag " Ignore") minor-mode-alist))) -(or (assq 'rcirc-low-priority-flag minor-mode-alist) - (setq minor-mode-alist - (cons '(rcirc-low-priority-flag " LowPri") minor-mode-alist))) +(add-to-list 'minor-mode-alist '(rcirc-ignore-buffer-activity-flag " Ignore")) +(add-to-list 'minor-mode-alist '(rcirc-low-priority-flag " LowPri")) (defun rcirc-toggle-ignore-buffer-activity () "Toggle the value of `rcirc-ignore-buffer-activity-flag'." @@ -1910,9 +2163,7 @@ This function does not alter the INPUT string." (defun rcirc-switch-to-server-buffer () "Switch to the server buffer associated with current channel buffer." (interactive) - (unless (buffer-live-p rcirc-server-buffer) - (error "No such buffer")) - (switch-to-buffer rcirc-server-buffer)) + (switch-to-buffer (with-rcirc-server-buffer (current-buffer)))) (defun rcirc-jump-to-first-unread-line () "Move the point to the first unread line in this buffer." @@ -1948,7 +2199,8 @@ With prefix ARG, go to the next low priority buffer with activity." (concat " Type C-u " (key-description (this-command-keys)) " for low priority activity.") - ""))))) + "")))) + (rcirc-update-activity-string)) (define-obsolete-variable-alias 'rcirc-activity-hooks 'rcirc-activity-functions "24.3") @@ -2004,7 +2256,6 @@ activity. Only run if the buffer is not visible and (defvar rcirc-update-activity-string-hook nil "Hook run whenever the activity string is updated.") -;; TODO: add mouse properties (defun rcirc-update-activity-string () "Update mode-line string." (let* ((pair (rcirc-split-activity rcirc-activity)) @@ -2023,19 +2274,26 @@ activity. Only run if the buffer is not visible and ((not (null (rcirc-process-list))) "[]") (t "[]"))) - (run-hooks 'rcirc-update-activity-string-hook))) + (run-hooks 'rcirc-update-activity-string-hook) + (force-mode-line-update t))) (defun rcirc-activity-string (buffers) + "Generate activity string for all BUFFERS." (mapconcat (lambda (b) (let ((s (substring-no-properties (rcirc-short-buffer-name b)))) (with-current-buffer b (dolist (type rcirc-activity-types) - (rcirc-add-face 0 (length s) - (cl-case type + (rcirc-facify s (cl-case type (nick 'rcirc-track-nick) - (keyword 'rcirc-track-keyword)) - s))) - s)) + (keyword 'rcirc-track-keyword))))) + (let ((map (make-mode-line-mouse-map + 'mouse-1 + (lambda () + (interactive) + (pop-to-buffer b))))) + (propertize s + 'mouse-face 'mode-line-highlight + 'local-map map)))) buffers ",")) (defun rcirc-short-buffer-name (buffer) @@ -2044,7 +2302,7 @@ activity. Only run if the buffer is not visible and (or rcirc-short-buffer-name (buffer-name)))) (defun rcirc-visible-buffers () - "Return a list of the visible buffers that are in rcirc-mode." + "Return a list of the visible buffers that are in `rcirc-mode'." (let (acc) (walk-windows (lambda (w) (with-current-buffer (window-buffer w) @@ -2052,13 +2310,16 @@ activity. Only run if the buffer is not visible and (push (current-buffer) acc))))) acc)) -(defvar rcirc-visible-buffers nil) +(defvar rcirc-visible-buffers nil + "List of visible IRC buffers.") + (defun rcirc-window-configuration-change () + "Clear activity and overlay arrows, unless minibuffer is active." (unless (minibuffer-window-active-p (minibuffer-window)) (rcirc-window-configuration-change-1))) (defun rcirc-window-configuration-change-1 () - ;; clear activity and overlay arrows + "Clear activity and overlay arrows." (let* ((old-activity rcirc-activity) (hidden-buffers rcirc-visible-buffers)) @@ -2084,6 +2345,7 @@ activity. Only run if the buffer is not visible and ;;; buffer name abbreviation (defun rcirc-update-short-buffer-names () + "Update variable `rcirc-short-buffer-name' for IRC buffers." (let ((bufalist (apply 'append (mapcar (lambda (process) (with-rcirc-process-buffer process @@ -2095,10 +2357,15 @@ activity. Only run if the buffer is not visible and (setq rcirc-short-buffer-name (car i))))))) (defun rcirc-abbreviate (pairs) + "Generate alist of abbreviated buffer names to buffers. +PAIRS is the concatenated value of all `rcirc-buffer-alist' +values, from each process." (apply 'append (mapcar 'rcirc-rebuild-tree (rcirc-make-trees pairs)))) -(defun rcirc-rebuild-tree (tree &optional acc) - (let ((ch (char-to-string (car tree)))) +(defun rcirc-rebuild-tree (tree) + "Merge prefix TREE into alist of unique prefixes to buffers." + (let ((ch (char-to-string (car tree))) + acc) (dolist (x (cdr tree)) (if (listp x) (setq acc (append acc @@ -2110,6 +2377,12 @@ activity. Only run if the buffer is not visible and acc)) (defun rcirc-make-trees (pairs) + "Generate tree prefix tree of buffer names. +PAIRS is a list of (TARGET . BUFFER) entries. The resulting tree +is a list of (CHAR . CHILDREN) cons-cells, where CHAR is the +leading character and CHILDREN is either BUFFER when a unique +prefix could be found or another tree if it shares the same +prefix with another element in PAIRS." (let (alist) (mapc (lambda (pair) (if (consp pair) @@ -2142,50 +2415,85 @@ activity. Only run if the buffer is not visible and ;; the current buffer/channel/user, and ARGS, which is a string ;; containing the text following the /cmd. -(defmacro defun-rcirc-command (command argument docstring interactive-form - &rest body) - "Define a command." - `(progn - (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command))) - (defun ,(intern (concat "rcirc-cmd-" (symbol-name command))) - (,@argument &optional process target) - ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given" - "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - ,interactive-form - (let ((process (or process (rcirc-buffer-process))) - (target (or target rcirc-target))) - (ignore target) ; mark `target' variable as ignorable - ,@body)))) - -(defun-rcirc-command msg (message) - "Send private MESSAGE to TARGET." - (interactive "i") - (if (null message) - (progn - (setq target (completing-read "Message nick: " +(defmacro rcirc-define-command (command arguments &rest body) + "Define a new client COMMAND in BODY that takes ARGUMENTS. +ARGUMENTS may designate optional arguments using a single +`&optional' symbol. Just like `defun', a string at the beginning +of BODY is interpreted as the documentation string. Following +that, an interactive form can specified." + (declare (debug (symbolp (&rest symbolp) def-body)) + (indent defun)) + (cl-check-type command symbol) + (cl-check-type arguments list) + (let* ((fn-name (intern (concat "rcirc-cmd-" (symbol-name command)))) + (total (length (remq '&optional arguments))) + (required (- (length arguments) (length (memq '&optional arguments)))) + (optional (- total required)) + (regexp (with-temp-buffer + (insert "\\`") + (when arguments + (dotimes (_ (1- (length arguments))) + (insert "\\(?:\\(.+?\\)[[:space:]]+")) + (dotimes (i (1- (length arguments))) + (if (< i optional) + (insert "\\)?") + (insert "\\)")))) + (insert "\\(.*?\\)") + (insert "[[:space:]]*\\'") + (buffer-string))) + (argument (gensym)) + documentation + interactive-spec) + (when (stringp (car body)) + (setq documentation (pop body))) + (when (eq (car-safe (car-safe body)) 'interactive) + (setq interactive-spec (cdr (pop body)))) + `(progn + (defun ,fn-name (,argument &optional process target) + ,(concat documentation + "\n\nNote: If PROCESS or TARGET are nil, the values given" + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + (interactive (list ,@interactive-spec)) + (unless (if (listp ,argument) + (<= ,required (length ,argument) ,total) + (string-match ,regexp ,argument)) + (user-error "Malformed input (%s): %S" ',command ',argument)) + (let ((process (or process (rcirc-buffer-process))) + (target (or target rcirc-target))) + (ignore target process) + (let (,@(cl-loop + for i from 0 for arg in (delq '&optional arguments) + collect `(,arg (if (listp ,argument) + (nth ,i ,argument) + (match-string ,(1+ i) ,argument))))) + ,@body))) + (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command)))))) + +(define-obsolete-function-alias + 'defun-rcirc-command + 'rcirc-define-command + "28.1") + +(rcirc-define-command msg (chan-or-nick message) + "Send MESSAGE to CHAN-OR-NICK." + (interactive (list (completing-read "Message nick: " (with-rcirc-server-buffer - rcirc-nick-table))) - (when (> (length target) 0) - (setq message (read-string (format "Message %s: " target))) - (when (> (length message) 0) - (rcirc-send-message process target message)))) - (if (not (string-match "\\([^ ]+\\) \\(.+\\)" message)) - (message "Not enough args, or something.") - (setq target (match-string 1 message) - message (match-string 2 message)) - (rcirc-send-message process target message)))) - -(defun-rcirc-command query (nick) + rcirc-nick-table)) + (read-string "Message: "))) + (rcirc-send-message process chan-or-nick message)) + +(rcirc-define-command query (nick) "Open a private chat buffer to NICK." (interactive (list (completing-read "Query nick: " - (with-rcirc-server-buffer rcirc-nick-table)))) + (with-rcirc-server-buffer + rcirc-nick-table)))) (let ((existing-buffer (rcirc-get-buffer process nick))) (switch-to-buffer (or existing-buffer (rcirc-get-buffer-create process nick))) (when (not existing-buffer) (rcirc-cmd-whois nick)))) -(defun-rcirc-command join (channels) +(rcirc-define-command join (channels) "Join CHANNELS. CHANNELS is a comma- or space-separated string of channel names." (interactive "sJoin channels: ") @@ -2194,46 +2502,35 @@ CHANNELS is a comma- or space-separated string of channel names." (rcirc-get-buffer-create process ch)) split-channels)) (channels (mapconcat 'identity split-channels ","))) - (rcirc-send-string process (concat "JOIN " channels)) + (rcirc-send-string process "JOIN" channels) (when (not (eq (selected-window) (minibuffer-window))) (dolist (b buffers) ;; order the new channel buffers in the buffer list (switch-to-buffer b))))) -(defun-rcirc-command invite (nick-channel) +(rcirc-define-command invite (nick channel) "Invite NICK to CHANNEL." (interactive (list - (concat - (completing-read "Invite nick: " - (with-rcirc-server-buffer rcirc-nick-table)) - " " - (read-string "Channel: ")))) - (rcirc-send-string process (concat "INVITE " nick-channel))) - -(defun-rcirc-command part (channel) + (completing-read "Invite nick: " + (with-rcirc-server-buffer rcirc-nick-table)) + (read-string "Channel: "))) + (rcirc-send-string process "INVITE" nick channel)) + +(rcirc-define-command part (&optional channel reason) "Part CHANNEL. CHANNEL should be a string of the form \"#CHANNEL-NAME REASON\". If omitted, CHANNEL-NAME defaults to TARGET, and REASON defaults to `rcirc-default-part-reason'." - (interactive "sPart channel: ") - (let ((channel (if (> (length channel) 0) channel target)) - (msg rcirc-default-part-reason)) - (when (string-match "\\`\\([&#+!]\\S-+\\)?\\s-*\\(.+\\)?\\'" channel) - (when (match-beginning 2) - (setq msg (match-string 2 channel))) - (setq channel (if (match-beginning 1) - (match-string 1 channel) - target))) - (rcirc-send-string process (concat "PART " channel " :" msg)))) - -(defun-rcirc-command quit (reason) + (interactive "sPart channel: \nsReason: ") + (rcirc-send-string process "PART" (or channel target) + : (or reason rcirc-default-part-reason))) + +(rcirc-define-command quit (&optional reason) "Send a quit message to server with REASON." (interactive "sQuit reason: ") - (rcirc-send-string process (concat "QUIT :" - (if (not (zerop (length reason))) - reason - rcirc-default-quit-reason)))) + (rcirc-send-string process "QUIT" + : (or reason rcirc-default-quit-reason))) -(defun-rcirc-command reconnect (_) +(rcirc-define-command reconnect () "Reconnect to current server." (interactive "i") (with-rcirc-server-buffer @@ -2244,79 +2541,73 @@ to `rcirc-default-part-reason'." (setf (nth 5 conn-info) (cl-remove-if-not #'rcirc-channel-p (mapcar #'car rcirc-buffer-alist))) + (dolist (buf (nth 5 conn-info)) + (with-current-buffer (cdr (assoc buf rcirc-buffer-alist)) + (setq rcirc-reconncting t))) (apply #'rcirc-connect conn-info)))))) -(defun-rcirc-command nick (nick) +(rcirc-define-command nick (nick) "Change nick to NICK." - (interactive "i") - (when (null nick) - (setq nick (read-string "New nick: " (rcirc-nick process)))) - (rcirc-send-string process (concat "NICK " nick))) + (interactive (list (read-string "New nick: "))) + (rcirc-send-string process "NICK" nick)) -(defun-rcirc-command names (channel) +(rcirc-define-command names (&optional channel) "Display list of names in CHANNEL or in current channel if CHANNEL is nil. If called interactively, prompt for a channel when prefix arg is supplied." - (interactive "P") - (if (called-interactively-p 'interactive) - (if channel - (setq channel (read-string "List names in channel: " target)))) - (let ((channel (if (> (length channel) 0) - channel - target))) - (rcirc-send-string process (concat "NAMES " channel)))) - -(defun-rcirc-command topic (topic) + (interactive (list (and current-prefix-arg + (read-string "List names in channel: ")))) + (rcirc-send-string process "NAMES" (or channel target))) + +(rcirc-define-command topic (topic) "List TOPIC for the TARGET channel. With a prefix arg, prompt for new topic." - (interactive "P") - (if (and (called-interactively-p 'interactive) topic) - (setq topic (read-string "New Topic: " rcirc-topic))) - (rcirc-send-string process (concat "TOPIC " target - (when (> (length topic) 0) - (concat " :" topic))))) + (interactive (list (and current-prefix-arg + (read-string "List names in channel: ")))) + (if (> (length topic) 0) + (rcirc-send-string process "TOPIC" : topic) + (rcirc-send-string process "TOPIC"))) -(defun-rcirc-command whois (nick) +(rcirc-define-command whois (nick) "Request information from server about NICK." - (interactive (list - (completing-read "Whois: " - (with-rcirc-server-buffer rcirc-nick-table)))) - (rcirc-send-string process (concat "WHOIS " nick))) - -(defun-rcirc-command mode (args) - "Set mode with ARGS." - (interactive (list (concat (read-string "Mode nick or channel: ") - " " (read-string "Mode: ")))) - (rcirc-send-string process (concat "MODE " args))) - -(defun-rcirc-command list (channels) + (interactive (list (completing-read + "Whois: " + (with-rcirc-server-buffer rcirc-nick-table)))) + (rcirc-send-string process "WHOIS" nick)) + +(rcirc-define-command mode (nick-or-chan mode) + "Set NICK-OR-CHAN mode to MODE." + (interactive (list (read-string "Mode nick or channel: ") + (read-string "Mode: "))) + (rcirc-send-string process "MODE" nick-or-chan mode)) + +(rcirc-define-command list (channels) "Request information on CHANNELS from server." (interactive "sList Channels: ") - (rcirc-send-string process (concat "LIST " channels))) + (rcirc-send-string process "LIST" channels)) -(defun-rcirc-command oper (args) +(rcirc-define-command oper (args) "Send operator command to server." (interactive "sOper args: ") - (rcirc-send-string process (concat "OPER " args))) + (rcirc-send-string process "OPER" args)) -(defun-rcirc-command quote (message) +(rcirc-define-command quote (message) "Send MESSAGE literally to server." (interactive "sServer message: ") (rcirc-send-string process message)) -(defun-rcirc-command kick (arg) +(rcirc-define-command kick (nick reason) "Kick NICK from current channel." (interactive (list - (concat (completing-read "Kick nick: " - (rcirc-channel-nicks - (rcirc-buffer-process) - rcirc-target)) - (read-from-minibuffer "Kick reason: ")))) - (let* ((arglist (split-string arg)) - (argstring (concat (car arglist) " :" - (mapconcat 'identity (cdr arglist) " ")))) - (rcirc-send-string process (concat "KICK " target " " argstring)))) + (completing-read "Kick nick: " + (rcirc-channel-nicks + (rcirc-buffer-process) + rcirc-target)) + (read-from-minibuffer "Kick reason: "))) + (rcirc-send-string process "KICK" target nick : reason)) (defun rcirc-cmd-ctcp (args &optional process _target) + "Handle ARGS as a CTCP command. +PROCESS is the process object for the current connection." (if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args) (let* ((target (match-string 1 args)) (request (upcase (match-string 2 args))) @@ -2328,14 +2619,18 @@ With a prefix arg, prompt for new topic." "usage: /ctcp NICK REQUEST"))) (defun rcirc-ctcp-sender-PING (process target _request) - "Send a CTCP PING message to TARGET." + "Send a CTCP PING message to TARGET. +PROCESS is the process object for the current connection." (let ((timestamp (format-time-string "%s"))) (rcirc-send-ctcp process target "PING" timestamp))) (defun rcirc-cmd-me (args process target) + "Send an action message ARGS to TARGET. +PROCESS is the process object for the current connection." (when target (rcirc-send-ctcp process target "ACTION" args))) (defun rcirc-add-or-remove (set &rest elements) + "Toggle membership of ELEMENTS in SET." (dolist (elt elements) (if (and elt (not (string= "" elt))) (setq set (if (member-ignore-case elt set) @@ -2343,7 +2638,8 @@ With a prefix arg, prompt for new topic." (cons elt set))))) set) -(defun-rcirc-command ignore (nick) + +(rcirc-define-command ignore (nick) "Manage the ignore list. Ignore NICK, unignore NICK if already ignored, or list ignored nicks when no NICK is given. When listing ignored nicks, the @@ -2360,7 +2656,7 @@ ones added to the list automatically are marked with an asterisk." "*" ""))) rcirc-ignore-list " "))) -(defun-rcirc-command bright (nick) +(rcirc-define-command bright (nick) "Manage the bright nick list." (interactive "sToggle emphasis of nick: ") (setq rcirc-bright-nicks @@ -2369,7 +2665,7 @@ ones added to the list automatically are marked with an asterisk." (rcirc-print process nil "BRIGHT" target (mapconcat 'identity rcirc-bright-nicks " "))) -(defun-rcirc-command dim (nick) +(rcirc-define-command dim (nick) "Manage the dim nick list." (interactive "sToggle deemphasis of nick: ") (setq rcirc-dim-nicks @@ -2378,7 +2674,7 @@ ones added to the list automatically are marked with an asterisk." (rcirc-print process nil "DIM" target (mapconcat 'identity rcirc-dim-nicks " "))) -(defun-rcirc-command keyword (keyword) +(rcirc-define-command keyword (keyword) "Manage the keyword list. Mark KEYWORD, unmark KEYWORD if already marked, or list marked keywords when no KEYWORD is given." @@ -2453,28 +2749,85 @@ If ARG is given, opens the URL in a new browser window." arg))) (defun rcirc-markup-timestamp (_sender _response) + "Insert a timestamp." (goto-char (point-min)) - (insert (rcirc-facify (format-time-string rcirc-time-format) - 'rcirc-timestamp))) + (let ((time (and-let* ((time (rcirc-get-tag "time"))) + (parse-iso8601-time-string time)))) + (insert (rcirc-facify (format-time-string rcirc-time-format time) + 'rcirc-timestamp)))) (defun rcirc-markup-attributes (_sender _response) - (while (re-search-forward "\\([\C-b\C-_\C-v]\\).*?\\(\\1\\|\C-o\\)" nil t) + "Highlight IRC markup, indicated by ASCII control codes." + (while (re-search-forward + (rx (group (or #x02 #x1d #x1f #x1e #x11)) + (*? nonl) + (group (or (backref 1) (+ #x0f) eol))) + nil t) (rcirc-add-face (match-beginning 0) (match-end 0) - (cl-case (char-after (match-beginning 1)) - (?\C-b 'bold) - (?\C-v 'italic) - (?\C-_ 'underline))) - ;; keep the ^O since it could terminate other attributes - (when (not (eq ?\C-o (char-before (match-end 2)))) - (delete-region (match-beginning 2) (match-end 2))) - (delete-region (match-beginning 1) (match-end 1)) - (goto-char (match-beginning 1))) - ;; remove the ^O characters now - (goto-char (point-min)) - (while (re-search-forward "\C-o+" nil t) + (cl-case (char-after (match-beginning 0)) + (#x02 'bold) + (#x1d 'italic) + (#x1f 'underline) + (#x1e '(:strike-through t)) + (#x11 'rcirc-monospace-text))) + (goto-char (1+ (match-beginning 0))))) + +(defconst rcirc-color-codes + ;; Taken from https://modern.ircdocs.horse/formatting.html + ["white" "black" "blue" "green" "red" "brown" "magenta" + "orange" "yellow" "light green" "cyan" "light cyan" + "light blue" "pink" "grey" "light grey" + "#470000" "#472100" "#474700" "#324700" "#004700" "#00472c" + "#004747" "#002747" "#000047" "#2e0047" "#470047" "#47002a" + "#740000" "#743a00" "#747400" "#517400" "#007400" "#007449" + "#007474" "#004074" "#000074" "#4b0074" "#740074" "#740045" + "#b50000" "#b56300" "#b5b500" "#7db500" "#00b500" "#00b571" + "#00b5b5" "#0063b5" "#0000b5" "#7500b5" "#b500b5" "#b5006b" + "#ff0000" "#ff8c00" "#ffff00" "#b2ff00" "#00ff00" "#00ffa0" + "#00ffff" "#008cff" "#0000ff" "#a500ff" "#ff00ff" "#ff0098" + "#ff5959" "#ffb459" "#ffff71" "#cfff60" "#6fff6f" "#65ffc9" + "#6dffff" "#59b4ff" "#5959ff" "#c459ff" "#ff66ff" "#ff59bc" + "#ff9c9c" "#ffd39c" "#ffff9c" "#e2ff9c" "#9cff9c" "#9cffdb" + "#9cffff" "#9cd3ff" "#9c9cff" "#dc9cff" "#ff9cff" "#ff94d3" + "#000000" "#131313" "#282828" "#363636" "#4d4d4d" "#656565" + "#818181" "#9f9f9f" "#bcbcbc" "#e2e2e2" "#ffffff"] + "Vector of colors for each IRC color code.") + +(defun rcirc-color-attributes (_sender _response) + "Highlight IRC color-codes, indicated by ASCII control codes." + (while (re-search-forward + (rx #x03 + (? (group (= 2 digit)) (? "," (group (= 2 digit)))) + (*? nonl) + (or #x03 #x0f eol)) + nil t) + (let (foreground background) + (when-let ((fg-raw (match-string 1)) + (fg (string-to-number fg-raw)) + ((<= 0 fg (1- (length rcirc-color-codes))))) + (setq foreground (aref rcirc-color-codes fg))) + (when-let ((bg-raw (match-string 2)) + (bg (string-to-number bg-raw)) + ((<= 0 bg (1- (length rcirc-color-codes))))) + (setq background (aref rcirc-color-codes bg))) + (rcirc-add-face (match-beginning 0) (match-end 0) + `(face (:foreground + ,foreground + :background + ,background)))))) + +(defun rcirc-remove-markup-codes (_sender _response) + "Remove ASCII control codes used to designate markup." + (while (re-search-forward + (rx (or #x02 #x1d #x1f #x1e #x11 #x0f + (: #x03 (? (= 2 digit) (? "," (= 2 digit)))))) + nil t) (delete-region (match-beginning 0) (match-end 0)))) (defun rcirc-markup-my-nick (_sender response) + "Highlight the users nick. +If RESPONSE indicates that the nick was mentioned in a message, +highlight the entire line and record the activity." (with-syntax-table rcirc-nick-syntax-table (while (re-search-forward (concat "\\b" (regexp-quote (rcirc-nick @@ -2489,6 +2842,7 @@ If ARG is given, opens the URL in a new browser window." (rcirc-record-activity (current-buffer) 'nick))))) (defun rcirc-markup-urls (_sender _response) + "Highlight and activate URLs." (while (and rcirc-url-regexp ; nil means disable URL catching. (re-search-forward rcirc-url-regexp nil t)) (let* ((start (match-beginning 0)) @@ -2505,12 +2859,17 @@ If ARG is given, opens the URL in a new browser window." 'follow-link t 'rcirc-url url 'action (lambda (button) - (browse-url (button-get button 'rcirc-url)))) + (browse-url-button-open-url + (button-get button 'rcirc-url)))) ;; Record the URL if it is not already the latest stored URL. (unless (string= url (caar rcirc-urls)) (push (cons url start) rcirc-urls))))) (defun rcirc-markup-keywords (sender response) + "Highlight keywords as specified by `rcirc-keywords'. +Keywords are only highlighted in messages (as indicated by +RESPONSE) when they were not written by the user (as indicated by +SENDER)." (when (and (string= response "PRIVMSG") (not (string= sender (rcirc-nick (rcirc-buffer-process))))) (let* ((target (or rcirc-target "")) @@ -2525,6 +2884,9 @@ If ARG is given, opens the URL in a new browser window." (rcirc-record-activity (current-buffer) 'keyword)))))) (defun rcirc-markup-bright-nicks (_sender response) + "Highlight nicks brightly as specified by `rcirc-bright-nicks'. +This highlighting only takes place in name lists (as indicated by +RESPONSE)." (when (and rcirc-bright-nicks (string= response "NAMES")) (with-syntax-table rcirc-nick-syntax-table @@ -2533,6 +2895,8 @@ If ARG is given, opens the URL in a new browser window." 'rcirc-bright-nick))))) (defun rcirc-markup-fill (_sender response) + "Fill messages as configured by `rcirc-fill-column'. +MOTD messages are not filled (as indicated by RESPONSE)." (when (not (string= response "372")) ; /motd (let ((fill-prefix (or rcirc-fill-prefix @@ -2550,8 +2914,11 @@ If ARG is given, opens the URL in a new browser window." ;; server or a user, depending on the command, the ARGS, which is a ;; list of strings, and the TEXT, which is the original server text, ;; verbatim -(defun rcirc-handler-001 (process sender args text) - (rcirc-handler-generic process "001" sender args text) +(defun rcirc-handler-001 (process sender args _text) + "Handle welcome message. +SENDER and ARGS are used to initialize the current connection. +PROCESS is the process object for the current connection." + (rcirc-handler-generic process "001" sender args nil) (with-rcirc-process-buffer process (setq rcirc-connecting nil) (rcirc-reschedule-timeout process) @@ -2575,11 +2942,16 @@ If ARG is given, opens the URL in a new browser window." (rcirc-join-channels process rcirc-startup-channels)))) (defun rcirc-join-channels-post-auth (process) - "Join `rcirc-startup-channels' after authenticating." + "Join `rcirc-startup-channels' after authenticating. +PROCESS is the process object for the current connection." (with-rcirc-process-buffer process (rcirc-join-channels process rcirc-startup-channels))) (defun rcirc-handler-PRIVMSG (process sender args text) + "Handle a (private) message from SENDER. +ARGS should have the form (TARGET MESSAGE). TEXT is the verbatim +message as received from the server. PROCESS is the process +object for the current connection." (rcirc-check-auth-status process sender args text) (let ((target (if (rcirc-channel-p (car args)) (car args) @@ -2593,6 +2965,10 @@ If ARG is given, opens the URL in a new browser window." (rcirc-put-nick-channel process sender target rcirc-current-line)))) (defun rcirc-handler-NOTICE (process sender args text) + "Handle a notice message from SENDER. +ARGS should have the form (TARGET MESSAGE). +TEXT is the verbatim message as received from the server. +PROCESS is the process object for the current connection." (rcirc-check-auth-status process sender args text) (let ((target (car args)) (message (cadr args))) @@ -2602,7 +2978,7 @@ If ARG is given, opens the URL in a new browser window." (rcirc-print process sender "NOTICE" (cond ((rcirc-channel-p target) target) - ;;; -ChanServ- [#gnu] Welcome... + ;; -ChanServ- [#gnu] Welcome... ((string-match "\\[\\(#[^] ]+\\)\\]" message) (match-string 1 message)) (sender @@ -2614,7 +2990,9 @@ If ARG is given, opens the URL in a new browser window." (defun rcirc-check-auth-status (process sender args _text) "Check if the user just authenticated. If authenticated, runs `rcirc-authenticated-hook' with PROCESS as -the only argument." +the only argument. ARGS should have the form (TARGET MESSAGE). +SENDER is used the determine the authentication method. PROCESS +is the process object for the current connection." (with-rcirc-process-buffer process (when (and (not rcirc-user-authenticated) rcirc-authenticate-before-join @@ -2644,9 +3022,17 @@ the only argument." (remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t)))))) (defun rcirc-handler-WALLOPS (process sender args _text) + "Handle WALLOPS message from SENDER. +ARGS should have the form (MESSAGE). +PROCESS is the process object for the current +connection." (rcirc-print process sender "WALLOPS" sender (car args) t)) (defun rcirc-handler-JOIN (process sender args _text) + "Handle JOIN message from SENDER. +ARGS should have the form (CHANNEL). +PROCESS is the process object for the current +connection." (let ((channel (car args))) (with-current-buffer (rcirc-get-buffer-create process channel) ;; when recently rejoining, restore the linestamp @@ -2668,6 +3054,8 @@ the only argument." ;; PART and KICK are handled the same way (defun rcirc-handler-PART-or-KICK (process _response channel _sender nick _args) + "Remove NICK from CHANNEL. +PROCESS is the process object for the current connection." (rcirc-ignore-update-automatic nick) (if (not (string= nick (rcirc-nick process))) ;; this is someone else leaving @@ -2685,6 +3073,9 @@ the only argument." (rcirc-disconnect-buffer buffer))))) (defun rcirc-handler-PART (process sender args _text) + "Handle PART message from SENDER. +ARGS should have the form (CHANNEL REASON). +PROCESS is the process object for the current connection." (let* ((channel (car args)) (reason (cadr args)) (message (concat channel " " reason))) @@ -2696,6 +3087,9 @@ the only argument." (rcirc-handler-PART-or-KICK process "PART" channel sender sender reason))) (defun rcirc-handler-KICK (process sender args _text) + "Handle PART message from SENDER. +ARGS should have the form (CHANNEL NICK REASON). +PROCESS is the process object for the current connection." (let* ((channel (car args)) (nick (cadr args)) (reason (nth 2 args)) @@ -2708,7 +3102,8 @@ the only argument." (rcirc-handler-PART-or-KICK process "KICK" channel sender nick reason))) (defun rcirc-maybe-remember-nick-quit (process nick channel) - "Remember NICK as leaving CHANNEL if they recently spoke." + "Remember NICK as leaving CHANNEL if they recently spoke. +PROCESS is the process object for the current connection." (let ((elapsed-lines (rcirc-elapsed-lines process nick channel))) (when (and elapsed-lines (< elapsed-lines rcirc-omit-threshold)) @@ -2724,6 +3119,8 @@ the only argument." rcirc-recent-quit-alist)))))))))) (defun rcirc-handler-QUIT (process sender args _text) + "Handle QUIT message from SENDER. +PROCESS is the process object for the current connection." (rcirc-ignore-update-automatic sender) (mapc (lambda (channel) ;; broadcast quit message each channel @@ -2734,6 +3131,9 @@ the only argument." (rcirc-nick-remove process sender)) (defun rcirc-handler-NICK (process sender args _text) + "Handle NICK message from SENDER. +ARGS should have the form (NEW-NICK). +PROCESS is the process object for the current connection." (let* ((old-nick sender) (new-nick (car args)) (channels (rcirc-nick-channels process old-nick))) @@ -2765,21 +3165,30 @@ the only argument." (when rcirc-auto-authenticate-flag (rcirc-authenticate)))))) (defun rcirc-handler-PING (process _sender args _text) - (rcirc-send-string process (concat "PONG :" (car args)))) + "Respond to a PING with a PONG. +ARGS should have the form (MESSAGE). MESSAGE is relayed back to +the server. PROCESS is the process object for the current +connection." + (rcirc-send-string process "PONG" : (car args))) (defun rcirc-handler-PONG (_process _sender _args _text) - ;; do nothing - ) + "Ignore all incoming PONG messages.") (defun rcirc-handler-TOPIC (process sender args _text) + "Note the topic change from SENDER. +PROCESS is the process object for the current connection." (let ((topic (cadr args))) (rcirc-print process sender "TOPIC" (car args) topic) (with-current-buffer (rcirc-get-buffer process (car args)) (setq rcirc-topic topic)))) -(defvar rcirc-nick-away-alist nil) +(defvar rcirc-nick-away-alist nil + "Alist from nicks to away messages.") + (defun rcirc-handler-301 (process _sender args text) - "RPL_AWAY" + "Handle away messages (RPL_AWAY). +ARGS should have the form (NICK AWAY-MESSAGE). +PROCESS is the process object for the current connection." (let* ((nick (cadr args)) (rec (assoc-string nick rcirc-nick-away-alist)) (away-message (nth 2 args))) @@ -2793,7 +3202,9 @@ the only argument." rcirc-nick-away-alist)))))) (defun rcirc-handler-317 (process sender args _text) - "RPL_WHOISIDLE" + "Handle idle messages from SENDER (RPL_WHOISIDLE). +ARGS should have the form (NICK IDLE-SECS SIGNON-TIME). +PROCESS is the process object for the current connection." (let* ((nick (nth 1 args)) (idle-secs (string-to-number (nth 2 args))) (idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs)) @@ -2804,15 +3215,20 @@ the only argument." (rcirc-print process sender "317" nil message t))) (defun rcirc-handler-332 (process _sender args _text) - "RPL_TOPIC" + "Update topic when notified by server (RPL_TOPIC). +ARGS should have the form (CHANNEL TOPIC). +PROCESS is the process object for the current connection." (let ((buffer (or (rcirc-get-buffer process (cadr args)) (rcirc-get-temp-buffer-create process (cadr args))))) (with-current-buffer buffer (setq rcirc-topic (nth 2 args))))) (defun rcirc-handler-333 (process sender args _text) - "333 says who set the topic and when. -Not in rfc1459.txt" + "Update when and who set the current topic. +ARGS has the form (CHANNEL SETTER TIME). SENDER is passed on to +`rcirc-print'. PROCESS is the process object for the current +connection. This is a non-standard extension, not specified in +RFC1459." (let ((buffer (or (rcirc-get-buffer process (cadr args)) (rcirc-get-temp-buffer-create process (cadr args))))) (with-current-buffer buffer @@ -2823,10 +3239,17 @@ Not in rfc1459.txt" (format "%s (%s on %s)" rcirc-topic setter time)))))) (defun rcirc-handler-477 (process sender args _text) - "ERR_NOCHANMODES" + "Notify user that CHANNEL does not support modes (ERR_NOCHANMODES). +ARGS has the form (CHANNEL MESSAGE). SENDER is passed on to +`rcirc-print'. PROCESS is the process object for the current +connection." (rcirc-print process sender "477" (cadr args) (nth 2 args))) (defun rcirc-handler-MODE (process sender args _text) + "Handle MODE messages. +ARGS should have the form (TARGET . MESSAGE-LIST). +SENDER is passed on to `rcirc-print'. +PROCESS is the process object for the current connection." (let ((target (car args)) (msg (mapconcat 'identity (cdr args) " "))) (rcirc-print process sender "MODE" @@ -2847,7 +3270,9 @@ Not in rfc1459.txt" (get-buffer-create tmpnam))) (defun rcirc-handler-353 (process _sender args _text) - "RPL_NAMREPLY" + "Start handling list of users (RPL_NAMREPLY). +ARGS should have the form (TYPE CHANNEL . NICK-LIST). +PROCESS is the process object for the current connection." (let ((channel (nth 2 args)) (names (or (nth 3 args) ""))) (mapc (lambda (nick) @@ -2860,7 +3285,9 @@ Not in rfc1459.txt" (insert (car (last args)) " ")))) (defun rcirc-handler-366 (process sender args _text) - "RPL_ENDOFNAMES" + "Handle end of user list (RPL_ENDOFNAMES). +SENDER is passed on to `rcirc-print'. +PROCESS is the process object for the current connection." (let* ((channel (cadr args)) (buffer (rcirc-get-temp-buffer-create process channel))) (with-current-buffer buffer @@ -2870,7 +3297,10 @@ Not in rfc1459.txt" (kill-buffer buffer))) (defun rcirc-handler-433 (process sender args text) - "ERR_NICKNAMEINUSE" + "Warn user that nick is used (ERR_NICKNAMEINUSE). +ARGS should have the form (NICK CHANNEL WARNING). +SENDER is passed on to `rcirc-handler-generic'. +PROCESS is the process object for the current connection." (rcirc-handler-generic process "433" sender args text) (with-rcirc-process-buffer process (let* ((length (string-to-number @@ -2879,8 +3309,10 @@ Not in rfc1459.txt" (rcirc-cmd-nick (rcirc--make-new-nick (cadr args) length) nil process)))) (defun rcirc--make-new-nick (nick length) - ;; If we already have some ` chars at the end, then shorten the - ;; non-` bit of the name. + "Attempt to create a unused nickname out of NICK. +A new nick may at most be LENGTH characters long. If we already +have some ` chars at the end, then shorten the non-` bit of the +name." (when (= (length nick) length) (setq nick (replace-regexp-in-string "[^`]\\(`+\\)\\'" "\\1" nick))) (concat @@ -2890,7 +3322,14 @@ Not in rfc1459.txt" "`")) (defun rcirc-handler-005 (process sender args text) - "ERR_NICKNAMEINUSE" + "Register supported server features (RPL_ISUPPORT). +ARGS should be a list of string feature parameters, either of the +form \"PARAMETER\" to enable a feature, \"PARAMETER=VALUE\" to +configure a specific option or \"-PARAMETER\" to disable a +previously specified feature. SENDER is passed on to +`rcirc-handler-generic'. PROCESS is the process object for the +current connection. Note that this is not the behaviour as +specified in RFC2812, where 005 stood for RPL_BOUNCE." (rcirc-handler-generic process "005" sender args text) (with-rcirc-process-buffer process (setq rcirc-server-parameters (append rcirc-server-parameters args)))) @@ -2925,7 +3364,8 @@ Passwords are stored in `rcirc-authinfo' (which see)." (rcirc-send-privmsg process "&bitlbee" - (concat "IDENTIFY " (car args))))) + (concat "IDENTIFY " (car args)))) + (sasl nil)) ;; quakenet authentication doesn't rely on the user's nickname. ;; the variable `nick' here represents the Q account name. (when (eq method 'quakenet) @@ -2935,12 +3375,37 @@ Passwords are stored in `rcirc-authinfo' (which see)." (format "AUTH %s %s" nick (car args)))))))))) (defun rcirc-handler-INVITE (process sender args _text) - (rcirc-print process sender "INVITE" nil (mapconcat 'identity args " ") t)) + "Notify user of an invitation from SENDER. +ARGS should have the form (TARGET CHANNEL). PROCESS is the +process object for the current connection." + (let ((self (buffer-local-value 'rcirc-nick rcirc-process)) + (target (car args)) + (chan (cadr args))) + (if (string= target self) + (rcirc-print process sender "INVITE" nil + (format "%s invited you to %s" + sender chan) + t) + (rcirc-print process sender "INVITE" chan + (format "%s invited %s" + sender target) + t)))) (defun rcirc-handler-ERROR (process sender args _text) + "Print a error message. +SENDER and ARGS (in concatenated form) are passed on to +`rcirc-print'. PROCESS is the process object for the current +connection." (rcirc-print process sender "ERROR" nil (mapconcat 'identity args " "))) (defun rcirc-handler-CTCP (process target sender text) + "Handle Client-To-Client-Protocol message TEXT. +The message is addressed from SENDER to TARGET. Attempt to find +an appropriate handler, by invoicing the function +`rcirc-handler-ctcp-REQUEST', where REQUEST is the message type +as extracted from TEXT. If no handler was found, an error +message will be printed. PROCESS is the process object for the +current connection." (if (string-match "^\\([^ ]+\\) *\\(.*\\)$" text) (let* ((request (upcase (match-string 1 text))) (args (match-string 2 text)) @@ -2955,28 +3420,128 @@ Passwords are stored in `rcirc-authinfo' (which see)." (rcirc-print process sender "CTCP" target (format "%s" text) t)))))) -(defun rcirc-handler-ctcp-VERSION (process _target sender _args) - (rcirc-send-string process - (concat "NOTICE " sender - " :\C-aVERSION " rcirc-id-string - "\C-a"))) +(defun rcirc-handler-ctcp-VERSION (process _target sender _message) + "Handle a CTCP VERSION message from SENDER. +PROCESS is the process object for the current connection." + (rcirc-send-string process "NOTICE" sender : + (rcirc-ctcp-wrap "VERSION" rcirc-id-string))) -(defun rcirc-handler-ctcp-ACTION (process target sender args) - (rcirc-print process sender "ACTION" target args t)) +(defun rcirc-handler-ctcp-ACTION (process target sender message) + "Handle a CTCP ACTION MESSAGE from SENDER to TARGET. +PROCESS is the process object for the current connection." + (rcirc-print process sender "ACTION" target message t)) -(defun rcirc-handler-ctcp-TIME (process _target sender _args) - (rcirc-send-string process - (concat "NOTICE " sender - " :\C-aTIME " (current-time-string) "\C-a"))) +(defun rcirc-handler-ctcp-TIME (process _target sender _message) + "Respond to CTCP TIME message from SENDER. +PROCESS is the process object for the current connection." + (rcirc-send-string process "NOTICE" sender : + (rcirc-ctcp-wrap "TIME" (current-time-string)))) (defun rcirc-handler-CTCP-response (process _target sender message) + "Handle CTCP response MESSAGE from SENDER. +PROCESS is the process object for the current connection." (rcirc-print process sender "CTCP" nil message t)) + + +(defun rcirc-handler-CAP (process _sender args _text) + "Handle capability negotiation messages. +ARGS should have the form (USER SUBCOMMAND . ARGUMENTS). PROCESS +is the process object for the current connection." + (with-rcirc-process-buffer process + (let ((subcmd (cadr args))) + (dolist (cap (cddr args)) + (cond ((string= subcmd "ACK") + (push cap rcirc-acked-capabilities) + (setq rcirc-requested-capabilities + (delete cap rcirc-requested-capabilities))) + ((string= subcmd "NAK") + (setq rcirc-requested-capabilities + (delete cap rcirc-requested-capabilities)))))) + (when (and (null rcirc-requested-capabilities) rcirc-finished-sasl) + ;; All requested capabilities have been responded to + (rcirc-send-string process "CAP" "END")))) + +(defun rcirc-handler-TAGMSG (process sender _args _text) + "Handle a empty tag message from SENDER. +PROCESS is the process object for the current connection." + (dolist (tag rcirc-message-tags) + (when-let ((handler (intern-soft (concat "rcirc-tag-handler-" (car tag)))) + ((fboundp handler))) + (funcall handler process sender (cdr tag))))) + +(defun rcirc-handler-BATCH (process _sender args _text) + "Open or close a batch. +ARGS should have the form (tag type . parameters) when starting a +batch, or (tag) when closing a batch. PROCESS is the process +object for the current connection." + (with-rcirc-process-buffer process + (let ((type (cadr args)) + (id (substring (car args) 1))) + (cond + ((= (aref (car args) 0) ?+) ;start a new batch + (when (assoc id rcirc-batch-attributes) + (error "Starting batch with already used ID")) + (setf (alist-get id rcirc-batch-attributes nil nil #'string=) + (cons type (cddr args)))) + ((= (aref (car args) 0) ?-) ;close a batch + (unless (assoc id rcirc-batch-attributes) + (error "Closing a unknown batch")) + (let ((type (car (alist-get id rcirc-batch-attributes + nil nil #'string=)))) + (when (eq (car (alist-get type rcirc-supported-batch-types + nil nil #'string=)) + 'deferred) + (let ((messages (alist-get id rcirc-batched-messages + nil nil #'string=)) + (bhandler (intern-soft (concat "rcirc-batch-handler-" type)))) + (if (fboundp bhandler) + (funcall bhandler process id (nreverse messages)) + (dolist (message (nreverse messages)) + (let ((cmd (nth 0 message)) + (process (nth 1 message)) + (sender (nth 2 message)) + (args (nth 3 message)) + (text (nth 4 message)) + (rcirc-message-tags (nth 5 message))) + (if-let (handler (intern-soft (concat "rcirc-handler-" cmd))) + (funcall handler process sender args text) + (rcirc-handler-generic process cmd sender args text)))))))) + (setq rcirc-batch-attributes + (delq (assoc id rcirc-batch-attributes) + rcirc-batch-attributes) + rcirc-batched-messages + (delq (assoc id rcirc-batched-messages) + rcirc-batched-messages))))))) + +(defun rcirc-handler-AUTHENTICATE (process _cmd _args _text) + "Respond to authentication request. +PROCESS is the process object for the current connection." + (rcirc-send-string + process + "AUTHENTICATE" + (base64-encode-string + ;; use connection user-name + (concat "\0" (nth 3 rcirc-connection-info) + "\0" (rcirc-get-server-password rcirc-server))))) + +(defun rcirc-handler-900 (process sender args _text) + "Respond to a successful authentication response." + (rcirc-handler-generic process "900" sender args nil) + (when (not rcirc-finished-sasl) + (setq-local rcirc-finished-sasl t) + (rcirc-send-string process "CAP" "END")) + (rcirc-join-channels-post-auth process)) + (defgroup rcirc-faces nil "Faces for rcirc." :group 'rcirc :group 'faces) +(defface rcirc-monospace-text + '((t :family "Monospace")) + "Face used for monospace text in messages.") + (defface rcirc-my-nick ; font-lock-function-name-face '((((class color) (min-colors 88) (background light)) :foreground "Blue1") (((class color) (min-colors 88) (background dark)) :foreground "LightSkyBlue") @@ -3086,11 +3651,12 @@ Passwords are stored in `rcirc-authinfo' (which see)." ;; When using M-x flyspell-mode, only check words after the prompt (put 'rcirc-mode 'flyspell-mode-predicate 'rcirc-looking-at-input) (defun rcirc-looking-at-input () - "Return true if point is past the input marker." + "Return non-nil if point is past the input marker." (>= (point) rcirc-prompt-end-marker)) (defun rcirc-server-parameter-value (parameter) + "Traverse `rcirc-server-parameters' for PARAMETER." (cl-loop for elem in rcirc-server-parameters for setting = (split-string elem "=") when (and (= (length setting) 2) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index ad271679618..4102b9d322a 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -643,7 +643,7 @@ starting with a colon. Example: The object labels of the found items are returned as list." (mapcar (lambda (item-path) (secrets-get-item-property item-path "Label")) - (apply 'secrets-search-item-paths collection attributes))) + (apply #'secrets-search-item-paths collection attributes))) (defun secrets-create-item (collection item password &rest attributes) "Create a new item in COLLECTION with label ITEM and password PASSWORD. @@ -780,9 +780,9 @@ ITEM can also be an object path, which is used if contained in COLLECTION." (defvar secrets-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map (make-composed-keymap special-mode-map widget-keymap)) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "z" 'kill-current-buffer) + (define-key map "n" #'next-line) + (define-key map "p" #'previous-line) + (define-key map "z" #'kill-current-buffer) map) "Keymap used in `secrets-mode' buffers.") @@ -859,7 +859,7 @@ to their attributes." ;; padding is needed to format attribute names. (padding (apply - 'max + #'max (cons (1+ (length "password")) (mapcar @@ -957,3 +957,5 @@ to their attributes." ;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be ;; used for the transfer of the secrets. Currently, we use the ;; plain algorithm. + +;;; secrets.el ends here diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index ac1f701fd37..eb78a259a8c 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -36,14 +36,12 @@ (defcustom shr-color-visible-luminance-min 40 "Minimum luminance distance between two colors to be considered visible. Must be between 0 and 100." - :group 'shr-color :type 'number) (defcustom shr-color-visible-distance-min 5 "Minimum color distance between two colors to be considered visible. This value is used to compare result for `ciede2000'. It's an absolute value without any unit." - :group 'shr-color :type 'integer) (defconst shr-color-html-colors-alist @@ -332,8 +330,8 @@ color will be adapted to be visible on BG." (if (or (null fg-norm) (null bg-norm)) (list bg fg) - (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm)) - (bg-lab (apply 'color-srgb-to-lab bg-norm)) + (let* ((fg-lab (apply #'color-srgb-to-lab fg-norm)) + (bg-lab (apply #'color-srgb-to-lab bg-norm)) ;; Compute color distance using CIE DE 2000 (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) ;; Compute luminance distance (subtract L component) @@ -351,12 +349,12 @@ color will be adapted to be visible on BG." (list (if fixed-background bg - (apply 'format "#%02x%02x%02x" + (apply #'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'color-lab-to-srgb bg-lab)))) - (apply 'format "#%02x%02x%02x" + (apply #'color-lab-to-srgb bg-lab)))) + (apply #'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'color-lab-to-srgb fg-lab)))))))))) + (apply #'color-lab-to-srgb fg-lab)))))))))) (provide 'shr-color) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 9c3740fccc9..85d81b6bbcc 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -183,8 +183,37 @@ temporarily blinks with this face." "Face for <abbr> elements." :version "27.1") -(defvar shr-inhibit-images nil - "If non-nil, inhibit loading images.") +(defface shr-h1 + '((t :height 1.3 :weight bold)) + "Face for <h1> elements." + :version "28.1") + +(defface shr-h2 + '((t :weight bold)) + "Face for <h2> elements." + :version "28.1") + +(defface shr-h3 + '((t :slant italic)) + "Face for <h3> elements." + :version "28.1") + +(defface shr-h4 nil + "Face for <h4> elements." + :version "28.1") + +(defface shr-h5 nil + "Face for <h5> elements." + :version "28.1") + +(defface shr-h6 nil + "Face for <h6> elements." + :version "28.1") + +(defcustom shr-inhibit-images nil + "If non-nil, inhibit loading images." + :version "28.1" + :type 'boolean) (defvar shr-external-rendering-functions nil "Alist of tag/function pairs used to alter how shr renders certain tags. @@ -220,20 +249,20 @@ and other things: (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 "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) + (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-image-map @@ -313,6 +342,12 @@ DOM should be a parse tree as generated by (* (frame-char-width) 2)) 1)))) (max-specpdl-size max-specpdl-size) + ;; `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 + ;; paragraph, when a long line has been continued, and for + ;; most scripts the character metrics don't change when they + ;; are reordered, so... this is the best we could do :-( bidi-display-reordering) ;; Adjust for max width specification. (when (and shr-max-width @@ -434,6 +469,7 @@ Value is a pair of positions (START . END) if there is a non-nil (defun shr-show-alt-text () "Show the ALT text of the image under point." + (declare (completion (lambda (_ b) (command-completion-button-p 'shr b)))) (interactive) (let ((text (get-text-property (point) 'shr-alt))) (if (not text) @@ -1248,20 +1284,20 @@ Return a string with image data." CONTENT-FUNCTION is a function to retrieve an image for a cid url that is an argument. The function to be returned takes three arguments URL, START, and END. Note that START and END should be markers." - `(lambda (url start end) - (when url - (if (string-match "\\`cid:" url) - ,(when content-function - `(let ((image (funcall ,content-function - (substring url (match-end 0))))) - (when image - (goto-char start) - (funcall shr-put-image-function - image (buffer-substring start end)) - (delete-region (point) end)))) - (url-retrieve url #'shr-image-fetched - (list (current-buffer) start end) - t t))))) + (lambda (url start end) + (when url + (if (string-match "\\`cid:" url) + (when content-function + (let ((image (funcall content-function + (substring url (match-end 0))))) + (when image + (goto-char start) + (funcall shr-put-image-function + image (buffer-substring start end)) + (delete-region (point) end)))) + (url-retrieve url #'shr-image-fetched + (list (current-buffer) start end) + t t))))) (defun shr-heading (dom &rest types) (shr-ensure-paragraph) @@ -1930,24 +1966,22 @@ BASE is the URL of the HTML being rendered." (shr-generic dom)) (defun shr-tag-h1 (dom) - (shr-heading dom (if shr-use-fonts - '(variable-pitch (:height 1.3 :weight bold)) - 'bold))) + (shr-heading dom 'shr-h1)) (defun shr-tag-h2 (dom) - (shr-heading dom 'bold)) + (shr-heading dom 'shr-h2)) (defun shr-tag-h3 (dom) - (shr-heading dom 'italic)) + (shr-heading dom 'shr-h3)) (defun shr-tag-h4 (dom) - (shr-heading dom)) + (shr-heading dom 'shr-h4)) (defun shr-tag-h5 (dom) - (shr-heading dom)) + (shr-heading dom 'shr-h5)) (defun shr-tag-h6 (dom) - (shr-heading dom)) + (shr-heading dom 'shr-h6)) (defun shr-tag-hr (_dom) (shr-ensure-newline) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index c4d6ec4b6cc..1f08a15e570 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -89,18 +89,15 @@ (defcustom sieve-manage-log "*sieve-manage-log*" "Name of buffer for managesieve session trace." - :type 'string - :group 'sieve-manage) + :type 'string) (defcustom sieve-manage-server-eol "\r\n" "The EOL string sent from the server." - :type 'string - :group 'sieve-manage) + :type 'string) (defcustom sieve-manage-client-eol "\r\n" "The EOL string we send to the server." - :type 'string - :group 'sieve-manage) + :type 'string) (defcustom sieve-manage-authenticators '(digest-md5 cram-md5 @@ -112,8 +109,7 @@ ;; FIXME Improve this. It's not `set'. ;; It's like (repeat (choice (const ...))), where each choice can ;; only appear once. - :type '(repeat symbol) - :group 'sieve-manage) + :type '(repeat symbol)) (defcustom sieve-manage-authenticator-alist '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth) @@ -130,26 +126,22 @@ NAME names the authenticator. CHECK is a function returning non-nil if the server support the authenticator and AUTHENTICATE is a function for doing the actual authentication." :type '(repeat (list (symbol :tag "Name") (function :tag "Check function") - (function :tag "Authentication function"))) - :group 'sieve-manage) + (function :tag "Authentication function")))) (defcustom sieve-manage-default-port "sieve" "Default port number or service name for managesieve protocol." :type '(choice integer string) - :version "24.4" - :group 'sieve-manage) + :version "24.4") (defcustom sieve-manage-default-stream 'network "Default stream type to use for `sieve-manage'." :version "24.1" - :type 'symbol - :group 'sieve-manage) + :type 'symbol) (defcustom sieve-manage-ignore-starttls nil "Ignore STARTTLS even if STARTTLS capability is provided." :version "26.1" - :type 'boolean - :group 'sieve-manage) + :type 'boolean) ;; Internal variables: @@ -247,7 +239,7 @@ Return the buffer associated with the connection." (sasl-read-passphrase ;; We *need* to copy the password, because sasl will modify it ;; somehow. - `(lambda (prompt) ,(copy-sequence user-password))) + (lambda (_prompt) (copy-sequence user-password))) (step (sasl-next-step client nil)) (_tag (sieve-manage-send (concat @@ -580,4 +572,4 @@ to local variable `sieve-manage-capability'." (provide 'sieve-manage) -;; sieve-manage.el ends here +;;; sieve-manage.el ends here diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 7bc1d16122d..0e8fdc0a905 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -139,9 +139,9 @@ (defvar sieve-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-l" 'sieve-upload) - (define-key map "\C-c\C-c" 'sieve-upload-and-kill) - (define-key map "\C-c\C-m" 'sieve-manage) + (define-key map "\C-c\C-l" #'sieve-upload) + (define-key map "\C-c\C-c" #'sieve-upload-and-kill) + (define-key map "\C-c\C-m" #'sieve-manage) map) "Key map used in sieve mode.") @@ -206,4 +206,4 @@ Turning on Sieve mode runs `sieve-mode-hook'." (provide 'sieve-mode) -;; sieve-mode.el ends here +;;; sieve-mode.el ends here diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index ca100267f67..6d571a0a30f 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -1,4 +1,4 @@ -;;; sieve.el --- Utilities to manage sieve scripts +;;; sieve.el --- Utilities to manage sieve scripts -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -69,13 +69,11 @@ (defcustom sieve-new-script "<new script>" "Name of name script indicator." - :type 'string - :group 'sieve) + :type 'string) (defcustom sieve-buffer "*sieve*" "Name of sieve management buffer." - :type 'string - :group 'sieve) + :type 'string) (defcustom sieve-template "\ require \"fileinto\"; @@ -91,8 +89,7 @@ require \"fileinto\"; # } " "Template sieve script." - :type 'string - :group 'sieve) + :type 'string) ;; Internal variables: @@ -104,31 +101,36 @@ require \"fileinto\"; ;; Sieve-manage mode: +;; This function is defined by `easy-menu-define' but it's only done +;; at run time and the compiler is not aware of it. +;; FIXME: This is arguably a bug/problem in `easy-menu-define'. +(declare-function sieve-manage-mode-menu "sieve") + (defvar sieve-manage-mode-map (let ((map (make-sparse-keymap))) ;; various - (define-key map "?" 'sieve-help) - (define-key map "h" 'sieve-help) + (define-key map "?" #'sieve-help) + (define-key map "h" #'sieve-help) ;; activating - (define-key map "m" 'sieve-activate) - (define-key map "u" 'sieve-deactivate) - (define-key map "\M-\C-?" 'sieve-deactivate-all) + (define-key map "m" #'sieve-activate) + (define-key map "u" #'sieve-deactivate) + (define-key map "\M-\C-?" #'sieve-deactivate-all) ;; navigation keys - (define-key map "\C-p" 'sieve-prev-line) - (define-key map [up] 'sieve-prev-line) - (define-key map "\C-n" 'sieve-next-line) - (define-key map [down] 'sieve-next-line) - (define-key map " " 'sieve-next-line) - (define-key map "n" 'sieve-next-line) - (define-key map "p" 'sieve-prev-line) - (define-key map "\C-m" 'sieve-edit-script) - (define-key map "f" 'sieve-edit-script) - (define-key map "o" 'sieve-edit-script-other-window) - (define-key map "r" 'sieve-remove) - (define-key map "q" 'sieve-bury-buffer) - (define-key map "Q" 'sieve-manage-quit) - (define-key map [(down-mouse-2)] 'sieve-edit-script) - (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu) + (define-key map "\C-p" #'sieve-prev-line) + (define-key map [up] #'sieve-prev-line) + (define-key map "\C-n" #'sieve-next-line) + (define-key map [down] #'sieve-next-line) + (define-key map " " #'sieve-next-line) + (define-key map "n" #'sieve-next-line) + (define-key map "p" #'sieve-prev-line) + (define-key map "\C-m" #'sieve-edit-script) + (define-key map "f" #'sieve-edit-script) + ;; (define-key map "o" #'sieve-edit-script-other-window) + (define-key map "r" #'sieve-remove) + (define-key map "q" #'sieve-bury-buffer) + (define-key map "Q" #'sieve-manage-quit) + (define-key map [(down-mouse-2)] #'sieve-edit-script) + (define-key map [(down-mouse-3)] #'sieve-manage-mode-menu) map) "Keymap for `sieve-manage-mode'.") @@ -159,8 +161,8 @@ require \"fileinto\"; (interactive) (bury-buffer)) -(defun sieve-activate (&optional pos) - (interactive "d") +(defun sieve-activate (&optional _pos) + (interactive) (let ((name (sieve-script-at-point)) err) (when (or (null name) (string-equal name sieve-new-script)) (error "No sieve script at point")) @@ -171,20 +173,20 @@ require \"fileinto\"; (message "Activating script %s...done" name) (message "Activating script %s...failed: %s" name (nth 2 err))))) -(defun sieve-deactivate-all (&optional pos) - (interactive "d") - (let ((name (sieve-script-at-point)) err) - (message "Deactivating scripts...") - (setq err (sieve-manage-setactive "" sieve-manage-buffer)) +(defun sieve-deactivate-all (&optional _pos) + (interactive) + (message "Deactivating scripts...") + (let (;; (name (sieve-script-at-point)) + (err (sieve-manage-setactive "" sieve-manage-buffer))) (sieve-refresh-scriptlist) (if (sieve-manage-ok-p err) (message "Deactivating scripts...done") (message "Deactivating scripts...failed: %s" (nth 2 err))))) -(defalias 'sieve-deactivate 'sieve-deactivate-all) +(defalias 'sieve-deactivate #'sieve-deactivate-all) -(defun sieve-remove (&optional pos) - (interactive "d") +(defun sieve-remove (&optional _pos) + (interactive) (let ((name (sieve-script-at-point)) err) (when (or (null name) (string-equal name sieve-new-script)) (error "No sieve script at point")) @@ -195,8 +197,8 @@ require \"fileinto\"; (sieve-refresh-scriptlist) (message "Removing sieve script %s...done" name))) -(defun sieve-edit-script (&optional pos) - (interactive "d") +(defun sieve-edit-script (&optional _pos) + (interactive) (let ((name (sieve-script-at-point))) (unless name (error "No sieve script at point")) @@ -224,11 +226,11 @@ require \"fileinto\"; (defmacro sieve-change-region (&rest body) "Turns off sieve-region before executing BODY, then re-enables it after. Used to bracket operations which move point in the sieve-buffer." + (declare (indent 0) (debug t)) `(progn (sieve-highlight nil) ,@body (sieve-highlight t))) -(put 'sieve-change-region 'lisp-indent-function 0) (defun sieve-next-line (&optional arg) (interactive) @@ -377,4 +379,4 @@ Used to bracket operations which move point in the sieve-buffer." (provide 'sieve) -;; sieve.el ends here +;;; sieve.el ends here diff --git a/lisp/net/snmp-mode.el b/lisp/net/snmp-mode.el index 983e6d92ee0..ae878ef3a51 100644 --- a/lisp/net/snmp-mode.el +++ b/lisp/net/snmp-mode.el @@ -1,4 +1,4 @@ -;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode +;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode -*- lexical-binding: t -*- ;; Copyright (C) 1995, 1998, 2001-2021 Free Software Foundation, Inc. @@ -69,16 +69,6 @@ ;; Once the template is done, you can use C-cC-f and C-cC-b to move back ;; and forth between the Tempo sequence points to fill in the rest of ;; the information. -;; -;; Font Lock -;; ------------ -;; -;; If you want font-lock in your MIB buffers, add this: -;; -;; (add-hook 'snmp-common-mode-hook 'turn-on-font-lock) -;; -;; Enabling global-font-lock-mode is also sufficient. -;; ;;; Code: @@ -101,42 +91,35 @@ (defcustom snmp-special-indent t "If non-nil, use a simple heuristic to try to guess the right indentation. If nil, then no special indentation is attempted." - :type 'boolean - :group 'snmp) + :type 'boolean) (defcustom snmp-indent-level 4 "Indentation level for SNMP MIBs." - :type 'integer - :group 'snmp) + :type 'integer) (defcustom snmp-tab-always-indent nil "Non-nil means TAB should always reindent the current line. A value of nil means reindent if point is within the initial line indentation; otherwise insert a TAB." - :type 'boolean - :group 'snmp) + :type 'boolean) (defcustom snmp-completion-ignore-case t "Non-nil means that case differences are ignored during completion. A value of nil means that case is significant. This is used during Tempo template completion." - :type 'boolean - :group 'snmp) + :type 'boolean) (defcustom snmp-common-mode-hook nil "Hook(s) evaluated when a buffer enters either SNMP or SNMPv2 mode." - :type 'hook - :group 'snmp) + :type 'hook) (defcustom snmp-mode-hook nil "Hook(s) evaluated when a buffer enters SNMP mode." - :type 'hook - :group 'snmp) + :type 'hook) (defcustom snmpv2-mode-hook nil "Hook(s) evaluated when a buffer enters SNMPv2 mode." - :type 'hook - :group 'snmp) + :type 'hook) (defvar snmp-tempo-tags nil "Tempo tags for SNMP mode.") @@ -291,7 +274,7 @@ This is used during Tempo template completion." ;; Set up the stuff that's common between snmp-mode and snmpv2-mode ;; -(defun snmp-common-mode (name mode abbrev font-keywords imenu-index tempo-tags) +(defun snmp-common-mode (name mode abbrev font-keywords imenu-index mode-tempo-tags) (kill-all-local-variables) ;; Become the current major mode @@ -326,7 +309,7 @@ This is used during Tempo template completion." (setq-local imenu-create-index-function imenu-index) ;; Tempo - (tempo-use-tag-list tempo-tags) + (tempo-use-tag-list mode-tempo-tags) (setq-local tempo-match-finder "\\b\\(.+\\)\\=") (setq-local tempo-interactive t) @@ -338,6 +321,7 @@ This is used during Tempo template completion." ;; ;;;###autoload (defun snmp-mode () + ;; FIXME: Use define-derived-mode. "Major mode for editing SNMP MIBs. Expression and list commands understand all C brackets. Tab indents for C code. @@ -370,6 +354,7 @@ Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then ;;;###autoload (defun snmpv2-mode () + ;; FIXME: Use define-derived-mode. "Major mode for editing SNMPv2 MIBs. Expression and list commands understand all C brackets. Tab indents for C code. @@ -474,13 +459,11 @@ lines for the purposes of this function." (index-table-alist '()) (index-trap-alist '()) (case-fold-search nil) ; keywords must be uppercase - prev-pos token end) + token end) (goto-char (point-min)) - (imenu-progress-message prev-pos 0) ;; Search for a useful MIB item (that's not in a comment) (save-match-data (while (re-search-forward snmp-clause-regexp nil t) - (imenu-progress-message prev-pos) (setq end (match-end 0) token (cons (match-string 1) @@ -498,7 +481,6 @@ lines for the purposes of this function." (push token index-tc-alist))) (goto-char end))) ;; Create the menu - (imenu-progress-message prev-pos 100) (setq index-alist (nreverse index-alist)) (and index-tc-alist (push (cons "Textual Conventions" (nreverse index-tc-alist)) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 3cc5569b55c..de1cd9d320f 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -10,6 +10,7 @@ ;; Package: soap-client ;; Homepage: https://github.com/alex-hhh/emacs-soap-client ;; Package-Requires: ((cl-lib "0.6.1")) +;;FIXME: Put in `Package-Requires:' the Emacs version we expect. ;; This file is part of GNU Emacs. @@ -658,7 +659,7 @@ representing leap seconds." (if second (if second-fraction (let* ((second-fraction-significand - (replace-regexp-in-string "\\." "" second-fraction)) + (string-replace "." "" second-fraction)) (hertz (expt 10 (length second-fraction-significand))) (ticks (+ (* hertz (string-to-number second)) @@ -771,6 +772,8 @@ This is a specialization of `soap-decode-type' for (Array (soap-decode-array node)))))) (defalias 'soap-type-of + ;; FIXME: Once we drop support for Emacs<25, use generic functions + ;; via `cl-defmethod' instead of our own ad-hoc version of it. (if (eq 'soap-xs-basic-type (type-of (make-soap-xs-basic-type))) ;; `type-of' in Emacs ≥ 26 already does what we need. #'type-of @@ -1263,7 +1266,7 @@ See also `soap-wsdl-resolve-references'." (soap-l2wk (xml-node-name node))) (setf (soap-xs-simple-type-base type) - (mapcar 'soap-l2fq + (mapcar #'soap-l2fq (split-string (or (xml-get-attribute-or-nil node 'memberTypes) "")))) @@ -1343,7 +1346,7 @@ See also `soap-wsdl-resolve-references'." (soap-validate-xs-basic-type value base)))) (error (push (cadr error-object) messages)))) (when messages - (error (mapconcat 'identity (nreverse messages) "; and: ")))) + (error (mapconcat #'identity (nreverse messages) "; and: ")))) (cl-labels ((fail-with-message (format value) (push (format format value) messages) (throw 'invalid nil))) @@ -1935,7 +1938,7 @@ This is a specialization of `soap-decode-type' for (e-name (soap-xs-element-name element)) ;; Heuristic: guess if we need to decode using local ;; namespaces. - (use-fq-names (string-match ":" (symbol-name (car node)))) + (use-fq-names (string-search ":" (symbol-name (car node)))) (children (if e-name (if use-fq-names ;; Find relevant children @@ -2345,8 +2348,8 @@ See also `soap-resolve-references' and (when (= (length (soap-operation-parameter-order operation)) 0) (setf (soap-operation-parameter-order operation) - (mapcar 'car (soap-message-parts - (cdr (soap-operation-input operation)))))) + (mapcar #'car (soap-message-parts + (cdr (soap-operation-input operation)))))) (setf (soap-operation-parameter-order operation) (mapcar (lambda (p) @@ -2391,13 +2394,13 @@ See also `soap-wsdl-resolve-references'." ;; Install resolvers for our types (progn (put (soap-type-of (make-soap-message)) 'soap-resolve-references - 'soap-resolve-references-for-message) + #'soap-resolve-references-for-message) (put (soap-type-of (make-soap-operation)) 'soap-resolve-references - 'soap-resolve-references-for-operation) + #'soap-resolve-references-for-operation) (put (soap-type-of (make-soap-binding)) 'soap-resolve-references - 'soap-resolve-references-for-binding) + #'soap-resolve-references-for-binding) (put (soap-type-of (make-soap-port)) 'soap-resolve-references - 'soap-resolve-references-for-port)) + #'soap-resolve-references-for-port)) (defun soap-wsdl-resolve-references (wsdl) "Resolve all references inside the WSDL structure. @@ -2511,7 +2514,7 @@ Build on WSDL if it is provided." (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl)) wsdl)) -(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl) +(defalias 'soap-load-wsdl-from-url #'soap-load-wsdl) (defun soap-parse-wsdl-phase-validate-node (node) "Assert that NODE is valid." @@ -2884,7 +2887,7 @@ decode function to perform the actual decoding." (if (fboundp 'define-error) (define-error 'soap-error "SOAP error") - ;; Support older Emacs versions that do not have define-error, so + ;; Support Emacs<24.4 that do not have define-error, so ;; that soap-client can remain unchanged in GNU ELPA. (put 'soap-error 'error-conditions @@ -3123,8 +3126,7 @@ http://schemas.xmlsoap.org/soap/encoding/\"\n")) (defcustom soap-debug nil "When t, enable some debugging facilities." - :type 'boolean - :group 'soap-client) + :type 'boolean) (defun soap-find-port (wsdl service) "Return the WSDL port having SERVICE name. diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el index 9d4e440719d..6f9ce6a2d69 100644 --- a/lisp/net/soap-inspect.el +++ b/lisp/net/soap-inspect.el @@ -109,7 +109,7 @@ soap-xs-attribute objects." This is a specialization of `soap-sample-value' for `soap-xs-simple-type' objects." (append - (mapcar 'soap-sample-value-for-xs-attribute + (mapcar #'soap-sample-value-for-xs-attribute (soap-xs-type-attributes type)) (cond ((soap-xs-simple-type-enumeration type) @@ -143,7 +143,7 @@ This is a specialization of `soap-sample-value' for This is a specialization of `soap-sample-value' for `soap-xs-complex-type' objects." (append - (mapcar 'soap-sample-value-for-xs-attribute + (mapcar #'soap-sample-value-for-xs-attribute (soap-xs-type-attributes type)) (cl-case (soap-xs-complex-type-indicator type) (array @@ -176,31 +176,31 @@ This is a specialization of `soap-sample-value' for ;; Install soap-sample-value methods for our types (put (soap-type-of (make-soap-xs-basic-type)) 'soap-sample-value - 'soap-sample-value-for-xs-basic-type) + #'soap-sample-value-for-xs-basic-type) (put (soap-type-of (make-soap-xs-element)) 'soap-sample-value - 'soap-sample-value-for-xs-element) + #'soap-sample-value-for-xs-element) (put (soap-type-of (make-soap-xs-attribute)) 'soap-sample-value - 'soap-sample-value-for-xs-attribute) + #'soap-sample-value-for-xs-attribute) (put (soap-type-of (make-soap-xs-attribute)) 'soap-sample-value - 'soap-sample-value-for-xs-attribute-group) + #'soap-sample-value-for-xs-attribute-group) (put (soap-type-of (make-soap-xs-simple-type)) 'soap-sample-value - 'soap-sample-value-for-xs-simple-type) + #'soap-sample-value-for-xs-simple-type) (put (soap-type-of (make-soap-xs-complex-type)) 'soap-sample-value - 'soap-sample-value-for-xs-complex-type) + #'soap-sample-value-for-xs-complex-type) (put (soap-type-of (make-soap-message)) 'soap-sample-value - 'soap-sample-value-for-message)) + #'soap-sample-value-for-message)) @@ -437,7 +437,7 @@ TYPE is a `soap-xs-complex-type'." (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation)))) (let ((sample-invocation - (append funcall (mapcar 'cdr sample-message-value)))) + (append funcall (mapcar #'cdr sample-message-value)))) (pp sample-invocation (current-buffer))))) (defun soap-inspect-port-type (port-type) @@ -460,7 +460,7 @@ TYPE is a `soap-xs-complex-type'." collect o)) op-name-width) - (setq operations (sort operations 'string<)) + (setq operations (sort operations #'string<)) (setq op-name-width (cl-loop for o in operations maximizing (length o))) @@ -504,39 +504,39 @@ TYPE is a `soap-xs-complex-type'." ;; Install the soap-inspect methods for our types (put (soap-type-of (make-soap-xs-basic-type)) 'soap-inspect - 'soap-inspect-xs-basic-type) + #'soap-inspect-xs-basic-type) (put (soap-type-of (make-soap-xs-element)) 'soap-inspect - 'soap-inspect-xs-element) + #'soap-inspect-xs-element) (put (soap-type-of (make-soap-xs-simple-type)) 'soap-inspect - 'soap-inspect-xs-simple-type) + #'soap-inspect-xs-simple-type) (put (soap-type-of (make-soap-xs-complex-type)) 'soap-inspect - 'soap-inspect-xs-complex-type) + #'soap-inspect-xs-complex-type) (put (soap-type-of (make-soap-xs-attribute)) 'soap-inspect - 'soap-inspect-xs-attribute) + #'soap-inspect-xs-attribute) (put (soap-type-of (make-soap-xs-attribute-group)) 'soap-inspect - 'soap-inspect-xs-attribute-group) + #'soap-inspect-xs-attribute-group) (put (soap-type-of (make-soap-message)) 'soap-inspect - 'soap-inspect-message) + #'soap-inspect-message) (put (soap-type-of (make-soap-operation)) 'soap-inspect - 'soap-inspect-operation) + #'soap-inspect-operation) (put (soap-type-of (make-soap-port-type)) 'soap-inspect - 'soap-inspect-port-type) + #'soap-inspect-port-type) (put (soap-type-of (make-soap-binding)) 'soap-inspect - 'soap-inspect-binding) + #'soap-inspect-binding) (put (soap-type-of (make-soap-port)) 'soap-inspect - 'soap-inspect-port) + #'soap-inspect-port) (put (soap-type-of (soap-make-wsdl "origin")) 'soap-inspect - 'soap-inspect-wsdl)) + #'soap-inspect-wsdl)) (provide 'soap-inspect) ;;; soap-inspect.el ends here diff --git a/lisp/net/socks.el b/lisp/net/socks.el index 96fafc826b8..78a261fd83e 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -277,7 +277,7 @@ (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) - (if (not (string-match "\r\n\r\n" string)) + (if (not (string-search "\r\n\r\n" string)) nil ; Need to spin some more (process-put proc 'socks-state socks-state-connected) (process-put proc 'socks-reply 0) @@ -390,6 +390,8 @@ proc))) (defun socks-send-command (proc command atype address port) + "Send COMMAND to SOCKS service PROC for proxying ADDRESS and PORT. +When ATYPE indicates an IP, param ADDRESS must be given as raw bytes." (let ((addr (cond ((or (= atype socks-address-type-v4) (= atype socks-address-type-v6)) @@ -528,7 +530,7 @@ (setq host (socks-nslookup-host host)) (if (not (listp host)) (error "Could not get IP address for: %s" host)) - (setq host (apply #'format "%c%c%c%c" host)) + (setq host (apply #'unibyte-string host)) socks-address-type-v4) (t socks-address-type-name)))) diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index 44f535f01c9..bb65ecaa981 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -1,4 +1,4 @@ -;;; telnet.el --- run a telnet session from within an Emacs buffer +;;; telnet.el --- run a telnet session from within an Emacs buffer -*- lexical-binding: t; -*- ;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2021 Free Software ;; Foundation, Inc. @@ -63,11 +63,11 @@ LOGIN-NAME, which is optional, says what to log in as on that machine.") (defvar telnet-new-line "\r") (defvar telnet-mode-map (let ((map (nconc (make-sparse-keymap) comint-mode-map))) - (define-key map "\C-m" 'telnet-send-input) - ;; (define-key map "\C-j" 'telnet-send-input) - (define-key map "\C-c\C-q" 'send-process-next-char) - (define-key map "\C-c\C-c" 'telnet-interrupt-subjob) - (define-key map "\C-c\C-z" 'telnet-c-z) + (define-key map "\C-m" #'telnet-send-input) + ;; (define-key map "\C-j" #'telnet-send-input) + (define-key map "\C-c\C-q" #'send-process-next-char) + (define-key map "\C-c\C-c" #'telnet-interrupt-subjob) + (define-key map "\C-c\C-z" #'telnet-c-z) map)) (defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *") @@ -152,7 +152,7 @@ rejecting one login and prompting again for a username and password.") (t (telnet-check-software-type-initialize string) (telnet-filter proc string) (cond ((> telnet-count telnet-maximum-count) - (set-process-filter proc 'telnet-filter)) + (set-process-filter proc #'telnet-filter)) (t (setq telnet-count (1+ telnet-count))))))))) ;; Identical to comint-simple-send, except that it sends telnet-new-line @@ -227,9 +227,9 @@ Normally input is edited in Emacs and sent a line at a time." (if (and buffer (get-buffer-process buffer)) (switch-to-buffer (concat "*" name "*")) (switch-to-buffer - (apply 'make-comint name telnet-program nil telnet-options)) + (apply #'make-comint name telnet-program nil telnet-options)) (setq process (get-buffer-process (current-buffer))) - (set-process-filter process 'telnet-initial-filter) + (set-process-filter process #'telnet-initial-filter) ;; Don't send the `open' cmd till telnet is ready for it. (accept-process-output process) (erase-buffer) @@ -263,7 +263,7 @@ Normally input is edited in Emacs and sent a line at a time." (require 'shell) (let ((name (concat "rsh-" host ))) (switch-to-buffer (make-comint name remote-shell-program nil host)) - (set-process-filter (get-process name) 'telnet-initial-filter) + (set-process-filter (get-process name) #'telnet-initial-filter) (telnet-mode) (setq-local telnet-connect-command (list 'rsh host)) (setq telnet-count -16))) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 6ec4d1fed38..c16e232c6d5 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -44,7 +44,6 @@ :version "24.4" :type 'string) -;;;###tramp-autoload (defcustom tramp-adb-connect-if-not-connected nil "Try to run `adb connect' if provided device is not connected currently. It is used for TCP/IP devices." @@ -56,7 +55,6 @@ It is used for TCP/IP devices." (defconst tramp-adb-method "adb" "When this method name is used, forward all calls to Android Debug Bridge.") -;;;###tramp-autoload (defcustom tramp-adb-prompt "^[^#$\n\r]*[#$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'regexp @@ -135,6 +133,7 @@ It is used for TCP/IP devices." (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-adb-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-adb-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -161,9 +160,11 @@ It is used for TCP/IP devices." (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-adb-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -182,6 +183,7 @@ It is used for TCP/IP devices." (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-adb-handle-write-region)) @@ -325,9 +327,9 @@ arguments to pass to the OPERATION." v (format "%s -d -a -l %s %s" (tramp-adb-get-ls-command v) (tramp-shell-quote-argument - (concat (file-name-as-directory localname) ".")) + (tramp-compat-file-name-concat localname ".")) (tramp-shell-quote-argument - (concat (file-name-as-directory localname) "..")))) + (tramp-compat-file-name-concat localname "..")))) (widen))) (tramp-adb-sh-fix-ls-output) (let ((result (tramp-do-parse-file-attributes-with-ls @@ -537,7 +539,8 @@ But handle the case, if the \"test\" command is not available." (defun tramp-adb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -546,16 +549,26 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let* ((curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) + (let ((file-locked (eq (file-locked-p lockname) t)) + (curbuf (current-buffer)) + (tmpfile (tramp-compat-make-temp-file filename))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not file-locked)) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) - (tramp-run-real-handler - #'write-region (list start end tmpfile append 'no-message lockname)) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (with-tramp-progress-reporter - v 3 (format-message - "Moving tmp file `%s' to `%s'" tmpfile filename) + v 3 (format-message + "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect (unless (tramp-adb-execute-adb-command v "push" tmpfile (tramp-compat-file-name-unquote localname)) @@ -578,6 +591,11 @@ But handle the case, if the \"test\" command is not available." (file-attributes filename)) (current-time)))) + ;; Unlock file. + (when file-locked + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + ;; The end. (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) @@ -785,7 +803,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let (command input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. (setq command (mapconcat #'tramp-shell-quote-argument @@ -906,7 +924,10 @@ implementation will be used." (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (if (plist-member args :connection-type) + (plist-get args :connection-type) + tramp-process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) @@ -922,7 +943,7 @@ implementation will be used." (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (unless (memq connection-type '(nil pipe t pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) (unless (or (null filter) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) @@ -1047,7 +1068,7 @@ implementation will be used." p)))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 0bbd9271b18..67798e892ab 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -236,6 +236,7 @@ It must be supported by libarchive(3).") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-archive-handle-file-local-copy) + (file-locked-p . ignore) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-archive-handle-file-name-all-completions) ;; `file-name-as-directory' performed by default handler. @@ -262,9 +263,11 @@ It must be supported by libarchive(3).") (insert-directory . tramp-archive-handle-insert-directory) (insert-file-contents . tramp-archive-handle-insert-file-contents) (load . tramp-archive-handle-load) + (lock-file . ignore) (make-auto-save-file-name . ignore) (make-directory . tramp-archive-handle-not-implemented) (make-directory-internal . tramp-archive-handle-not-implemented) + (make-lock-file-name . ignore) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-archive-handle-not-implemented) @@ -283,6 +286,7 @@ It must be supported by libarchive(3).") (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-archive-handle-not-implemented)) @@ -328,6 +332,8 @@ arguments to pass to the OPERATION." ;; `filename' could be a quoted file name. Or the file ;; archive could be a directory, see Bug#30293. (if (or (null archive) + (not (tramp-archive-run-real-handler + #'file-exists-p (list archive))) (tramp-archive-run-real-handler #'file-directory-p (list archive))) (tramp-archive-run-real-handler operation args) @@ -345,8 +351,17 @@ arguments to pass to the OPERATION." (tramp-archive-run-real-handler operation args))))))) ;;;###autoload -(defalias - 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler) +(progn (defun tramp-archive-autoload-file-name-handler (operation &rest args) + "Load Tramp archive file name handler, and perform OPERATION." + (when tramp-archive-enabled + ;; We cannot use `tramp-compat-temporary-file-directory' here due + ;; to autoload. When installing Tramp's GNU ELPA package, there + ;; might be an older, incompatible version active. We try to + ;; overload this. + (let ((default-directory temporary-file-directory) + (tramp-archive-autoload t)) + tramp-archive-autoload ; Silence byte compiler. + (apply #'tramp-autoload-file-name-handler operation args))))) ;;;###autoload (progn (defun tramp-register-archive-file-name-handler () @@ -628,10 +643,8 @@ offered." (let ((result (insert-file-contents (tramp-archive-gvfs-file-name filename) visit beg end replace))) - (prog1 - (list (expand-file-name filename) - (cadr result)) - (when visit (setq buffer-file-name filename))))) + (when visit (setq buffer-file-name filename)) + (cons (expand-file-name filename) (cdr result)))) (defun tramp-archive-handle-load (file &optional noerror nomessage nosuffix must-suffix) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 2b0a4d9cd05..5a00915f4f0 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -49,6 +49,8 @@ ;; 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 @@ -70,7 +72,8 @@ ;; process key retrieved by `tramp-get-process' (the main connection ;; process). Other processes could reuse these properties, avoiding ;; recomputation when a new asynchronous process is created by -;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el). +;; `make-process'. Examples are "unsafe-temporary-file", +;; "remote-path", "device" (tramp-adb.el) or "share" (tramp-gvfs.el). ;;; Code: @@ -122,7 +125,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (puthash key (make-hash-table :test #'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (string-match-p + (when (tramp-compat-string-search (or (nth 0 elt) "") (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) @@ -162,16 +165,20 @@ Return DEFAULT if not set." (tramp-message key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" file property value remote-file-name-inhibit-cache cache-used cached-at) + ;; For analysis purposes, count the number of getting this file attribute. (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) - (val (or (numberp (bound-and-true-p var)) - (progn - (add-hook 'tramp-cache-unload-hook - (lambda () (makunbound var))) - 0)))) + (val (or (and (boundp var) (numberp (symbol-value var)) + (symbol-value var)) + 0))) (set var (1+ val)))) value)) +(add-hook 'tramp-cache-unload-hook + (lambda () + (dolist (var (all-completions "tramp-cache-get-count-" obarray)) + (unintern var obarray)))) + ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. @@ -186,16 +193,20 @@ Return VALUE." ;; We put the timestamp there. (puthash property (cons (current-time) value) hash) (tramp-message key 8 "%s %s %s" file property value) + ;; For analysis purposes, count the number of setting this file attribute. (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) - (val (or (numberp (bound-and-true-p var)) - (progn - (add-hook 'tramp-cache-unload-hook - (lambda () (makunbound var))) - 0)))) + (val (or (and (boundp var) (numberp (symbol-value var)) + (symbol-value var)) + 0))) (set var (1+ val)))) value)) +(add-hook 'tramp-cache-unload-hook + (lambda () + (dolist (var (all-completions "tramp-cache-set-count-" obarray)) + (unintern var obarray)))) + ;;;###tramp-autoload (defun tramp-flush-file-property (key file property) "Remove PROPERTY of FILE in the cache context of KEY." @@ -229,8 +240,7 @@ Return VALUE." ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." - (let* ((file (tramp-run-real-handler - #'directory-file-name (list file))) + (let* ((file (tramp-run-real-handler #'directory-file-name (list file))) (truename (tramp-get-file-property key file "file-truename" nil))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) @@ -258,8 +268,8 @@ Remove also properties of all files in subdirectories." (dolist (key (hash-table-keys tramp-cache-data)) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) + (tramp-compat-string-search + directory (tramp-file-name-localname key))) (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) @@ -463,11 +473,11 @@ used to cache connection properties of the local machine." ;; don't save either, because all other properties might ;; depend on the login name, and we want to give the ;; possibility to use another login name later on. Key - ;; "started" exists for the "ftp" method only, which must be + ;; "started" exists for the "ftp" method only, which must not ;; be kept persistent. (maphash (lambda (key value) - (if (and (tramp-file-name-p key) value + (if (and (tramp-file-name-p key) (hash-table-p value) (not (string-equal (tramp-file-name-method key) tramp-archive-method)) (not (tramp-file-name-localname key)) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 097f25ea85e..6278fd302af 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -57,7 +57,9 @@ SYNTAX can be one of the symbols `default' (default), (all-completions "*tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))) (all-completions - "*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))))) + "*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))) + (all-completions + "*trace tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))))) (defun tramp-list-remote-buffers () "Return a list of all buffers with remote `default-directory'." @@ -144,11 +146,18 @@ When called interactively, a Tramp connection has to be selected." ;;;###tramp-autoload (defun tramp-cleanup-this-connection () "Flush all connection related objects of the current buffer's connection." + ;; (declare (completion tramp-command-completion-p))) (interactive) (and (tramp-tramp-file-p default-directory) (tramp-cleanup-connection (tramp-dissect-file-name default-directory 'noexpand)))) +;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. +;;;###tramp-autoload +(function-put + #'tramp-cleanup-this-connection 'completion-predicate + #'tramp-command-completion-p) + ;;;###tramp-autoload (defvar tramp-cleanup-all-connections-hook nil "List of functions to be called after all Tramp connections are cleaned up.") @@ -201,7 +210,6 @@ This includes password cache, file cache, connection cache, buffers." (dolist (name (tramp-list-remote-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) -;;;###tramp-autoload (defcustom tramp-default-rename-alist nil "Default target for renaming remote buffer file names. This is an alist of cons cells (SOURCE . TARGET). The first @@ -224,7 +232,6 @@ expression which always matches." :type '(repeat (cons (choice :tag "Source regexp" regexp sexp) (choice :tag "Target name" string (const nil))))) -;;;###tramp-autoload (defcustom tramp-confirm-rename-file-names t "Whether renaming a buffer file name must be confirmed." :group 'tramp @@ -243,7 +250,7 @@ function returns nil" (host (or (file-remote-p string 'host) "")) item result) (while (setq item (pop tdra)) - (when (string-match-p (or (eval (car item)) "") string) + (when (string-match-p (or (eval (car item) t) "") string) (setq tdra nil result (format-spec @@ -431,6 +438,7 @@ Interactively, TARGET is selected from `tramp-default-rename-alist' without confirmation if the prefix argument is non-nil. For details, see `tramp-rename-files'." + ;; (declare (completion tramp-command-completion-p)) (interactive (let ((source default-directory) target @@ -461,11 +469,59 @@ For details, see `tramp-rename-files'." (tramp-rename-files default-directory target)) +;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. +;;;###tramp-autoload +(function-put + #'tramp-rename-these-files 'completion-predicate #'tramp-command-completion-p) + +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +;;;###tramp-autoload +(defun tramp-recompile-elpa-command-completion-p (_symbol _buffer) + "A predicate for `tramp-recompile-elpa'. +It is completed by \"M-x TAB\" only if package.el is loaded, and +Tramp is an installed ELPA package." + ;; We cannot apply `package-installed-p', this would also return the + ;; builtin package. + (and (assq 'tramp (bound-and-true-p package-alist)) + (tramp-compat-funcall 'package--user-installed-p 'tramp))) + +;;;###tramp-autoload +(defun tramp-recompile-elpa () + "Recompile the installed Tramp ELPA package. +This is needed if there are compatibility problems." + ;; (declare (completion tramp-recompile-elpa-command-completion-p)) + (interactive) + ;; We expect just one Tramp package is installed. + (when-let + ((dir (tramp-compat-funcall + 'package-desc-dir + (car (alist-get 'tramp (bound-and-true-p package-alist)))))) + (dolist (elc (directory-files dir 'full "\\.elc\\'")) + (delete-file elc)) + (with-current-buffer (get-buffer-create byte-compile-log-buffer) + (let ((inhibit-read-only t)) + (compilation-mode) + (goto-char (point-max)) + (insert "\f\n") + (call-process + (expand-file-name invocation-name invocation-directory) nil t t + "-Q" "-batch" "-L" dir + "--eval" (format "(byte-recompile-directory %S 0 t)" dir)) + (message "Package `tramp' recompiled."))))) + +;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. +;;;###tramp-autoload +(function-put + #'tramp-recompile-elpa 'completion-predicate + #'tramp-recompile-elpa-command-completion-p) + ;; Tramp version is useful in a number of situations. ;;;###tramp-autoload (defun tramp-version (arg) - "Print version number of tramp.el in minibuffer or current buffer." + "Print version number of tramp.el in echo area or current buffer." (interactive "P") (if arg (insert tramp-version) (message tramp-version))) @@ -616,7 +672,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (string-match-p "tramp" x) (insert x "\n"))) + (lambda (x) (when (tramp-compat-string-search "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 27461e6917c..b713d5eae82 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -63,14 +63,12 @@ `(when (functionp ,function) (with-no-warnings (funcall ,function ,@arguments)))) -(put #'tramp-compat-funcall 'tramp-suppress-trace t) - (defsubst tramp-compat-temporary-file-directory () "Return name of directory for temporary files. It is the default value of `temporary-file-directory'." ;; We must return a local directory. If it is remote, we could run ;; into an infloop. - (eval (car (get 'temporary-file-directory 'standard-value)))) + (eval (car (get 'temporary-file-directory 'standard-value)) t)) (defsubst tramp-compat-make-temp-name () "Generate a local temporary file name (compat function)." @@ -353,7 +351,44 @@ A nil value for either argument stands for the current time." (if (fboundp 'string-replace) #'string-replace (lambda (fromstring tostring instring) - (replace-regexp-in-string (regexp-quote fromstring) tostring instring)))) + (let ((case-fold-search nil)) + (replace-regexp-in-string + (regexp-quote fromstring) tostring instring t t))))) + +;; Function `string-search' is new in Emacs 28.1. +(defalias 'tramp-compat-string-search + (if (fboundp 'string-search) + #'string-search + (lambda (needle haystack &optional start-pos) + (let ((case-fold-search nil)) + (string-match-p (regexp-quote needle) haystack start-pos))))) + +;; Function `make-lock-file-name' is new in Emacs 28.1. +(defalias 'tramp-compat-make-lock-file-name + (if (fboundp 'make-lock-file-name) + #'make-lock-file-name + (lambda (filename) + (expand-file-name + (concat + ".#" (file-name-nondirectory filename)) + (file-name-directory filename))))) + +;; Function `file-name-concat' is new in Emacs 28.1. +(defalias 'tramp-compat-file-name-concat + (if (fboundp 'file-name-concat) + #'file-name-concat + (lambda (directory &rest components) + (unless (null directory) + (let ((components (delq nil components)) + file-name-handler-alist) + (if (null components) + directory + (tramp-compat-file-name-concat + (concat (file-name-as-directory directory) (car components)) + (cdr components)))))))) + +(dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) + (put (intern elt) 'tramp-suppress-trace t)) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index f8de7085e25..fdb2907ec32 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -112,6 +112,18 @@ initializing a new crypted remote directory." "Non-nil when encryption support is available.") (setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program)) +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-crypt-command-completion-p (symbol _buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only when encryption support is enabled." + (and tramp-crypt-enabled + ;; `tramp-crypt-remove-directory' needs to be completed only in + ;; case we have already crypted directories. + (or (not (eq symbol #'tramp-crypt-remove-directory)) + tramp-crypt-directories))) + ;;;###tramp-autoload (defconst tramp-crypt-encfs-config ".encfs6.xml" "Encfs configuration file name.") @@ -170,6 +182,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-crypt-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-crypt-handle-file-name-all-completions) ;; `file-name-as-directory' performed by default handler. @@ -196,9 +209,11 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (insert-directory . tramp-crypt-handle-insert-directory) ;; `insert-file-contents' performed by default handler. (load . tramp-handle-load) + (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-crypt-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -217,6 +232,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; `tramp-get-remote-uid' performed by default handler. (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-crypt-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -481,10 +497,17 @@ directory. File names will be also encrypted." (setq tramp-crypt-directories (cons name tramp-crypt-directories))) (tramp-register-file-name-handlers)) +;; `tramp-crypt-command-completion-p' is not autoloaded, and this +;; setting isn't either. +(function-put + #'tramp-crypt-add-directory 'completion-predicate + #'tramp-crypt-command-completion-p) + (defun tramp-crypt-remove-directory (name) "Unmark remote directory NAME for encryption. Existing files in that directory and its subdirectories will be kept in their encrypted form." + ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) @@ -498,6 +521,11 @@ kept in their encrypted form." (setq tramp-crypt-directories (delete name tramp-crypt-directories)) (tramp-register-file-name-handlers))) +;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. +(function-put + #'tramp-crypt-remove-directory 'completion-predicate + #'tramp-crypt-command-completion-p) + ;; `auth-source' requires a user. (defun tramp-crypt-dissect-file-name (name) "Return a `tramp-file-name' structure for NAME. @@ -710,6 +738,11 @@ absolute file names." (let (tramp-crypt-enabled) (file-executable-p (tramp-crypt-encrypt-file-name filename)))) +(defun tramp-crypt-handle-file-locked-p (filename) + "Like `file-locked-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-locked-p (tramp-crypt-encrypt-file-name filename)))) + (defun tramp-crypt-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (all-completions @@ -773,6 +806,13 @@ WILDCARD is not supported." (delete-region (prop-match-beginning match) (prop-match-end match)) (insert (propertize string 'dired-filename t))))))) +(defun tramp-crypt-handle-lock-file (filename) + "Like `lock-file' for Tramp files." + (let (tramp-crypt-enabled) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall + 'lock-file (tramp-crypt-encrypt-file-name filename)))) + (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." (with-parsed-tramp-file-name (expand-file-name dir) nil @@ -824,6 +864,13 @@ WILDCARD is not supported." (tramp-set-file-uid-gid (tramp-crypt-encrypt-file-name filename) uid gid)))) +(defun tramp-crypt-handle-unlock-file (filename) + "Like `unlock-file' for Tramp files." + (let (tramp-crypt-enabled) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall + 'unlock-file (tramp-crypt-encrypt-file-name filename)))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-crypt 'force))) diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el new file mode 100644 index 00000000000..93b184a36c2 --- /dev/null +++ b/lisp/net/tramp-fuse.el @@ -0,0 +1,214 @@ +;;; tramp-fuse.el --- Tramp access functions for FUSE mounts -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; These are helper functions for FUSE file systems. + +;;; Code: + +(require 'tramp) + +;; File name primitives. + +(defun tramp-fuse-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (tramp-flush-directory-properties v localname) + (delete-directory (tramp-fuse-local-file-name directory) recursive trash))) + +(defun tramp-fuse-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (delete-file (tramp-fuse-local-file-name filename) trash) + (tramp-flush-file-properties v localname))) + +(defun tramp-fuse-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)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (with-parsed-tramp-file-name directory nil + (let ((result + (tramp-compat-directory-files + (tramp-fuse-local-file-name directory) full match nosort count))) + ;; Massage the result. + (when full + (let ((local (concat "^" (regexp-quote (tramp-fuse-mount-point v)))) + (remote (directory-file-name + (funcall + (if (tramp-compat-file-name-quoted-p directory) + #'tramp-compat-file-name-quote #'identity) + (file-remote-p directory))))) + (setq result + (mapcar + (lambda (x) (replace-regexp-in-string local remote x)) + result)))) + ;; Some storage systems do not return "." and "..". + (dolist (item '(".." ".")) + (when (and (string-match-p (or match (regexp-quote item)) item) + (not + (member (if full (setq item (concat directory item)) item) + result))) + (setq result (cons item result)))) + ;; Return result. + (if nosort result (sort result #'string<)))))) + +(defun tramp-fuse-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (file-attributes (tramp-fuse-local-file-name filename) id-format)))) + +(defun tramp-fuse-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-executable-p" + (file-executable-p (tramp-fuse-local-file-name filename))))) + +(defun tramp-fuse-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (delete-dups + (append + (file-name-all-completions + filename (tramp-fuse-local-file-name directory)) + ;; Some storage systems do not return "." and "..". + (let (result) + (dolist (item '(".." ".") result) + (when (string-prefix-p filename item) + (catch 'match + (dolist (elt completion-regexp-list) + (unless (string-match-p elt item) (throw 'match nil))) + (setq result (cons (concat item "/") result)))))))))) + +(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) + "Like `insert-directory' for Tramp files." + (insert-directory + (tramp-fuse-local-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-fuse-local-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-fuse-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (make-directory (tramp-fuse-local-file-name dir) parents) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole file cache. + (tramp-flush-file-properties v localname) + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))))) + + +;; File name helper functions. + +(defun tramp-fuse-mount-spec (vec) + "Return local mount spec of VEC." + (if-let ((host (tramp-file-name-host vec)) + (user (tramp-file-name-user vec))) + (format "%s@%s:/" user host) + (format "%s:/" host))) + +(defun tramp-fuse-mount-point (vec) + "Return local mount point of VEC." + (or (tramp-get-connection-property vec "mount-point" nil) + (expand-file-name + (concat + tramp-temp-name-prefix + (tramp-file-name-method vec) "." + (when (tramp-file-name-user vec) + (concat (tramp-file-name-user-domain vec) "@")) + (tramp-file-name-host-port vec)) + (tramp-compat-temporary-file-directory)))) + +(defun tramp-fuse-mounted-p (vec) + "Check, whether fuse volume determined by VEC is mounted." + (when (tramp-get-connection-process vec) + ;; We cannot use `with-connection-property', because we don't want + ;; to cache a nil result. + (or (tramp-get-connection-property + (tramp-get-connection-process vec) "mounted" nil) + (let* ((default-directory (tramp-compat-temporary-file-directory)) + (command (format "mount -t fuse.%s" (tramp-file-name-method vec))) + (mount (shell-command-to-string command))) + (tramp-message vec 6 "%s\n%s" command mount) + (tramp-set-connection-property + (tramp-get-connection-process vec) "mounted" + (when (string-match + (format + "^\\(%s\\)\\s-" (regexp-quote (tramp-fuse-mount-spec vec))) + mount) + (match-string 1 mount))))))) + +(defun tramp-fuse-unmount (vec) + "Unmount fuse volume determined by VEC." + (let ((default-directory (tramp-compat-temporary-file-directory)) + (command (format "fusermount3 -u %s" (tramp-fuse-mount-point vec)))) + (tramp-message vec 6 "%s\n%s" command (shell-command-to-string command)) + (tramp-flush-connection-property + (tramp-get-connection-process vec) "mounted") + ;; Give the caches a chance to expire. + (sleep-for 1))) + +(defun tramp-fuse-local-file-name (filename) + "Return local mount name of FILENAME." + (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (with-parsed-tramp-file-name filename nil + ;; As long as we call `tramp-*-maybe-open-connection' here, + ;; we cache the result. + (with-tramp-file-property v localname "local-file-name" + (funcall + (intern + (format "tramp-%s-maybe-open-connection" (tramp-file-name-method v))) + v) + (let ((quoted (tramp-compat-file-name-quoted-p localname)) + (localname (tramp-compat-file-name-unquote localname))) + (funcall + (if quoted #'tramp-compat-file-name-quote #'identity) + (expand-file-name + (if (file-name-absolute-p localname) + (substring localname 1) localname) + (tramp-fuse-mount-point v))))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-fuse 'force))) + +(provide 'tramp-fuse) + +;;; tramp-fuse.el ends here diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index e946d73e66c..e4f54cf4c46 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -175,7 +175,6 @@ They are checked during start up via (dbus-list-known-names :session)) (setq tramp-media-methods (delete method tramp-media-methods))))) -;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" "Zeroconf domain to be used for discovering services, like host names." :group 'tramp @@ -775,6 +774,7 @@ It has been changed in GVFS 1.14.") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -801,9 +801,11 @@ It has been changed in GVFS 1.14.") (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-gvfs-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -822,6 +824,7 @@ It has been changed in GVFS 1.14.") (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -1090,7 +1093,7 @@ file names." 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) (tramp-run-real-handler - 'copy-file + #'copy-file (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) @@ -1139,7 +1142,7 @@ file names." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name nil)) @@ -1172,6 +1175,9 @@ file names." ;; There might be a double slash. Remove this. (while (string-match "//" localname) (setq localname (replace-match "/" t t localname))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name @@ -1395,7 +1401,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (string-match-p "/" filename) + (unless (tramp-compat-string-search "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1627,8 +1633,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." ID-FORMAT valid values are `string' and `integer'." (if (equal id-format 'string) (tramp-file-name-user vec) - (when-let - ((localname (tramp-get-connection-property vec "default-location" nil))) + (when-let ((localname + (tramp-get-connection-property + (tramp-get-process vec) "share" + (tramp-get-connection-property vec "default-location" nil)))) (tramp-compat-file-attribute-user-id (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) @@ -1636,8 +1644,10 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-gvfs-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (when-let - ((localname (tramp-get-connection-property vec "default-location" nil))) + (when-let ((localname + (tramp-get-connection-property + (tramp-get-process vec) "share" + (tramp-get-connection-property vec "default-location" nil)))) (tramp-compat-file-attribute-group-id (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) @@ -1991,6 +2001,9 @@ a downcased host name only." (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property vec "default-location" default-location) + (when share + (tramp-set-connection-property + (tramp-get-process vec) "share" (concat "/" share))) (throw 'mounted t))))))) (defun tramp-gvfs-unmount (vec) @@ -2142,6 +2155,9 @@ 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 64b5b48e7d4..17264193fd6 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -42,6 +42,8 @@ (declare-function tramp-dissect-file-name "tramp") (declare-function tramp-file-name-equal-p "tramp") (declare-function tramp-tramp-file-p "tramp") +(declare-function tramp-rename-files "tramp-cmds") +(declare-function tramp-rename-these-files "tramp-cmds") (defvar eshell-path-env) (defvar ido-read-file-name-non-ido) (defvar info-lookup-alist) @@ -49,6 +51,7 @@ (defvar recentf-exclude) (defvar tramp-current-connection) (defvar tramp-postfix-host-format) +(defvar tramp-use-ssh-controlmaster-options) ;;; Fontification of `read-file-name': @@ -183,14 +186,14 @@ NAME must be equal to `tramp-current-connection'." ;;; Integration of ido.el: (with-eval-after-load 'ido - (add-to-list 'ido-read-file-name-non-ido 'tramp-rename-files) - (add-to-list 'ido-read-file-name-non-ido 'tramp-these-rename-files) + (add-to-list 'ido-read-file-name-non-ido #'tramp-rename-files) + (add-to-list 'ido-read-file-name-non-ido #'tramp-rename-these-files) (add-hook 'tramp-integration-unload-hook (lambda () (setq ido-read-file-name-non-ido - (delq 'tramp-these-rename-files ido-read-file-name-non-ido) + (delq #'tramp-rename-these-files ido-read-file-name-non-ido) ido-read-file-name-non-ido - (delq 'tramp-rename-files ido-read-file-name-non-ido))))) + (delq #'tramp-rename-files ido-read-file-name-non-ido))))) ;;; Integration of ivy.el: @@ -198,17 +201,17 @@ NAME must be equal to `tramp-current-connection'." (add-to-list 'ivy-completing-read-handlers-alist '(tramp-rename-files . completing-read-default)) (add-to-list 'ivy-completing-read-handlers-alist - '(tramp-these-rename-files . completing-read-default)) + '(tramp-rename-these-files . completing-read-default)) (add-hook 'tramp-integration-unload-hook (lambda () (setq ivy-completing-read-handlers-alist (delete - (assq 'tramp-these-rename-files ivy-completing-read-handlers-alist) + (assq #'tramp-rename-these-files ivy-completing-read-handlers-alist) ivy-completing-read-handlers-alist) ivy-completing-read-handlers-alist (delete - (assq 'tramp-rename-files ivy-completing-read-handlers-alist) + (assq #'tramp-rename-files ivy-completing-read-handlers-alist) ivy-completing-read-handlers-alist))))) ;;; Integration of info-look.el: @@ -231,7 +234,7 @@ NAME must be equal to `tramp-current-connection'." (delete (info-lookup->mode-cache 'symbol 'tramp-info-lookup-mode) (info-lookup->topic-cache 'symbol))))) - (dolist (mode (mapcar 'car (info-lookup->topic-value 'symbol))) + (dolist (mode (mapcar #'car (info-lookup->topic-value 'symbol))) ;; Add `tramp-info-lookup-mode' to `other-modes' for either ;; `emacs-lisp-mode' itself, or to modes which use ;; `emacs-lisp-mode' as `other-modes'. Reset `info-lookup-cache'. @@ -261,6 +264,23 @@ NAME must be equal to `tramp-current-connection'." (delete (info-lookup->mode-cache 'symbol ',mode) (info-lookup->topic-cache 'symbol)))))))) +;;; Integration of compile.el: + +;; Compilation processes use `accept-process-output' such a way that +;; Tramp's parallel `accept-process-output' blocks. See last part of +;; Bug#45518. So we don't use ssh ControlMaster options. +(defun tramp-compile-disable-ssh-controlmaster-options () + "Don't allow ssh ControlMaster while compiling." + (setq-local tramp-use-ssh-controlmaster-options nil)) + +(with-eval-after-load 'compile + (add-hook 'compilation-mode-hook + #'tramp-compile-disable-ssh-controlmaster-options) + (add-hook 'tramp-integration-unload-hook + (lambda () + (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. @@ -277,7 +297,7 @@ NAME must be equal to `tramp-current-connection'." (tramp-compat-funcall 'connection-local-set-profiles - `(:application tramp) + '(:application tramp) 'tramp-connection-local-default-system-profile) (defconst tramp-connection-local-default-shell-variables @@ -293,7 +313,7 @@ NAME must be equal to `tramp-current-connection'." (with-eval-after-load 'shell (tramp-compat-funcall 'connection-local-set-profiles - `(:application tramp) + '(:application tramp) 'tramp-connection-local-default-shell-profile)) (add-hook 'tramp-unload-hook diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 96f7d9a89b9..49e366c01c6 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -35,14 +35,13 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (require 'tramp) +(require 'tramp-fuse) ;;;###tramp-autoload (defconst tramp-rclone-method "rclone" "When this method name is used, forward all calls to rclone mounts.") -;;;###tramp-autoload (defcustom tramp-rclone-program "rclone" "Name of the rclone program." :group 'tramp @@ -53,7 +52,12 @@ (tramp--with-startup (add-to-list 'tramp-methods `(,tramp-rclone-method - (tramp-mount-args nil) + ;; Be careful changing "--dir-cache-time", this could + ;; delay visibility of files. Since we use Tramp's + ;; internal cache for file attributes, there shouldn't + ;; be serious performance penalties when set to 0. + (tramp-mount-args + ("--no-unicode-normalization" "--dir-cache-time" "0s")) (tramp-copyto-args nil) (tramp-moveto-args nil) (tramp-about-args ("--full")))) @@ -72,11 +76,11 @@ ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) (copy-file . tramp-rclone-handle-copy-file) - (delete-directory . tramp-rclone-handle-delete-directory) - (delete-file . tramp-rclone-handle-delete-file) + (delete-directory . tramp-fuse-handle-delete-directory) + (delete-file . tramp-fuse-handle-delete-file) ;; `diff-latest-backup-file' performed by default handler. (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-rclone-handle-directory-files) + (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) @@ -85,15 +89,16 @@ (expand-file-name . tramp-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) - (file-attributes . tramp-rclone-handle-file-attributes) + (file-attributes . tramp-fuse-handle-file-attributes) (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) - (file-executable-p . tramp-rclone-handle-file-executable-p) + (file-executable-p . tramp-fuse-handle-file-executable-p) (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) - (file-name-all-completions . tramp-rclone-handle-file-name-all-completions) + (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) (file-name-completion . tramp-handle-file-name-completion) @@ -105,7 +110,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-rclone-handle-file-readable-p) + (file-readable-p . tramp-fuse-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) @@ -118,9 +123,11 @@ (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) - (make-directory . tramp-rclone-handle-make-directory) + (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -139,6 +146,7 @@ (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -247,24 +255,13 @@ file names." "Error %s `%s' `%s'" msg-operation filename newname))) (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties v1 v1-localname) - (when (tramp-rclone-file-name-p filename) - (tramp-rclone-flush-directory-cache v1) - ;; The mount point's directory cache might need time - ;; to flush. - (while (file-exists-p filename) - (tramp-flush-file-properties v1 v1-localname))))) + (while (file-exists-p filename) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname)))) (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties v2 v2-localname) - (when (tramp-rclone-file-name-p newname) - (tramp-rclone-flush-directory-cache v2) - ;; The mount point's directory cache might need time - ;; to flush. - (while (not (file-exists-p newname)) - (tramp-flush-file-properties v2 v2-localname)))))))))) + (tramp-flush-file-properties v2 v2-localname)))))))) (defun tramp-rclone-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -283,88 +280,6 @@ file names." (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) -(defun tramp-rclone-handle-delete-directory - (directory &optional recursive trash) - "Like `delete-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name directory) nil - (tramp-flush-directory-properties v localname) - (tramp-rclone-flush-directory-cache v) - (delete-directory (tramp-rclone-local-file-name directory) recursive trash))) - -(defun tramp-rclone-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-rclone-flush-directory-cache v) - (delete-file (tramp-rclone-local-file-name filename) trash) - (tramp-flush-file-properties v localname))) - -(defun tramp-rclone-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)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (with-parsed-tramp-file-name directory nil - (let ((result - (tramp-compat-directory-files - (tramp-rclone-local-file-name directory) full match nosort count))) - ;; Massage the result. - (when full - (let ((local (concat "^" (regexp-quote (tramp-rclone-mount-point v)))) - (remote (funcall (if (tramp-compat-file-name-quoted-p directory) - #'tramp-compat-file-name-quote #'identity) - (file-remote-p directory)))) - (setq result - (mapcar - (lambda (x) (replace-regexp-in-string local remote x)) - result)))) - ;; Some storage systems do not return "." and "..". - (dolist (item '(".." ".")) - (when (and (string-match-p (or match (regexp-quote item)) item) - (not - (member (if full (setq item (concat directory item)) item) - result))) - (setq result (cons item result)))) - ;; Return result. - (if nosort result (sort result #'string<)))))) - -(defun tramp-rclone-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (file-attributes (tramp-rclone-local-file-name filename) id-format)))) - -(defun tramp-rclone-handle-file-executable-p (filename) - "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-executable-p" - (file-executable-p (tramp-rclone-local-file-name filename))))) - -(defun tramp-rclone-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (delete-dups - (append - (file-name-all-completions - filename (tramp-rclone-local-file-name directory)) - ;; Some storage systems do not return "." and "..". - (let (result) - (dolist (item '(".." ".") result) - (when (string-prefix-p filename item) - (catch 'match - (dolist (elt completion-regexp-list) - (unless (string-match-p elt item) (throw 'match nil))) - (setq result (cons (concat item "/") result)))))))))) - -(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-rclone-local-file-name filename))))) - (defun tramp-rclone-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors @@ -392,37 +307,6 @@ file names." (when (and total free) (list total free (- total free)))))))) -(defun tramp-rclone-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." - (insert-directory - (tramp-rclone-local-file-name filename) switches wildcard full-directory-p) - (goto-char (point-min)) - (while (search-forward (tramp-rclone-local-file-name filename) nil 'noerror) - (replace-match filename))) - -(defun tramp-rclone-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (let ((result - (insert-file-contents - (tramp-rclone-local-file-name filename) visit beg end replace))) - (prog1 - (list (expand-file-name filename) (cadr result)) - (when visit (setq buffer-file-name filename))))) - -(defun tramp-rclone-handle-make-directory (dir &optional parents) - "Like `make-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name dir) nil - (make-directory (tramp-rclone-local-file-name dir) parents) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole file cache. - (tramp-flush-file-properties v localname) - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))) - (tramp-rclone-flush-directory-cache v))) - (defun tramp-rclone-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." @@ -440,83 +324,6 @@ file names." ;; File name conversions. -(defun tramp-rclone-mount-point (vec) - "Return local mount point of VEC." - (expand-file-name - (concat - tramp-temp-name-prefix (tramp-file-name-method vec) - "." (tramp-file-name-host vec)) - (tramp-compat-temporary-file-directory))) - -(defun tramp-rclone-mounted-p (vec) - "Check, whether storage system determined by VEC is mounted." - (when (tramp-get-connection-process vec) - ;; We cannot use `with-connection-property', because we don't want - ;; to cache a nil result. - (or (tramp-get-connection-property - (tramp-get-connection-process vec) "mounted" nil) - (let* ((default-directory (tramp-compat-temporary-file-directory)) - (mount (shell-command-to-string "mount -t fuse.rclone"))) - (tramp-message vec 6 "%s" "mount -t fuse.rclone") - (tramp-message vec 6 "\n%s" mount) - (tramp-set-connection-property - (tramp-get-connection-process vec) "mounted" - (when (string-match - (format - "^\\(%s:\\S-*\\)" (regexp-quote (tramp-file-name-host vec))) - mount) - (match-string 1 mount))))))) - -(defun tramp-rclone-flush-directory-cache (vec) - "Flush directory cache of VEC mount." - (let ((rclone-pid - ;; Identify rclone process. - (when (tramp-get-connection-process vec) - (with-tramp-connection-property - (tramp-get-connection-process vec) "rclone-pid" - (catch 'pid - (dolist - (pid - ;; Until Emacs 25, `process-attributes' could - ;; crash Emacs for some processes. So we use - ;; "pidof", which might not work everywhere. - (if (<= emacs-major-version 25) - (let ((default-directory - (tramp-compat-temporary-file-directory))) - (mapcar - #'string-to-number - (split-string - (shell-command-to-string "pidof rclone")))) - (list-system-processes))) - (and (string-match-p - (regexp-quote - (format "rclone mount %s:" (tramp-file-name-host vec))) - (or (cdr (assoc 'args (process-attributes pid))) "")) - (throw 'pid pid)))))))) - ;; Send a SIGHUP in order to flush directory cache. - (when rclone-pid - (tramp-message - vec 6 "Send SIGHUP %d: %s" - rclone-pid (cdr (assoc 'args (process-attributes rclone-pid)))) - (signal-process rclone-pid 'SIGHUP)))) - -(defun tramp-rclone-local-file-name (filename) - "Return local mount name of FILENAME." - (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) - (with-parsed-tramp-file-name filename nil - ;; As long as we call `tramp-rclone-maybe-open-connection' here, - ;; we cache the result. - (with-tramp-file-property v localname "local-file-name" - (tramp-rclone-maybe-open-connection v) - (let ((quoted (tramp-compat-file-name-quoted-p localname)) - (localname (tramp-compat-file-name-unquote localname))) - (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) - (expand-file-name - (if (file-name-absolute-p localname) - (substring localname 1) localname) - (tramp-rclone-mount-point v))))))) - (defun tramp-rclone-remote-file-name (filename) "Return FILENAME as used in the `rclone' command." (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) @@ -529,7 +336,7 @@ file names." ;; TODO: This shall be handled by `expand-file-name'. (setq localname (replace-regexp-in-string "^\\." "" (or localname ""))) - (format "%s%s" (tramp-rclone-mounted-p v) localname))) + (format "%s%s" (tramp-fuse-mounted-p v) localname))) ;; It is a local file name. filename)) @@ -555,24 +362,26 @@ 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))) ;; Create directory. - (unless (file-directory-p (tramp-rclone-mount-point vec)) - (make-directory (tramp-rclone-mount-point vec) 'parents)) + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) ;; Mount. This command does not return, so we use 0 as ;; DESTINATION of `tramp-call-process'. - (unless (tramp-rclone-mounted-p vec) + (unless (tramp-fuse-mounted-p vec) (apply #'tramp-call-process vec tramp-rclone-program nil 0 nil - (delq nil - `("mount" ,(concat host ":/") - ,(tramp-rclone-mount-point vec) - ;; This could be nil. - ,(tramp-get-method-parameter vec 'tramp-mount-args)))) + "mount" (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-get-method-parameter vec 'tramp-mount-args)) (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) (tramp-cleanup-connection vec 'keep-debug 'keep-password)) @@ -607,9 +416,4 @@ The command is the list of strings ARGS." (provide 'tramp-rclone) -;;; TODO: - -;; * If possible, get rid of "rclone mount". Maybe it is more -;; performant then. - ;;; tramp-rclone.el ends here diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index bcdc014daba..f00434c1468 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -46,7 +46,6 @@ (defconst tramp-default-remote-shell "/bin/sh" "The default remote shell Tramp applies.") -;;;###tramp-autoload (defcustom tramp-inline-compress-start-size 4096 "The minimum size of compressing where inline transfer. When inline transfer, compress transferred data of file whose @@ -56,23 +55,12 @@ If it is nil, no compression at all will be applied." :group 'tramp :type '(choice (const nil) integer)) -;;;###tramp-autoload (defcustom tramp-copy-size-limit 10240 "Maximum file size where inline copying is preferred to an out-of-the-band copy. If it is nil, out-of-the-band copy will be used without a check." :group 'tramp :type '(choice (const nil) integer)) -;;;###tramp-autoload -(defcustom tramp-terminal-type "dumb" - "Value of TERM environment variable for logging in to remote host. -Because Tramp wants to parse the output of the remote shell, it is easily -confused by ANSI color escape sequences and suchlike. Often, shell init -files conditionalize this setup based on the TERM environment variable." - :group 'tramp - :type 'string) - -;;;###tramp-autoload (defcustom tramp-histfile-override "~/.tramp_history" "When invoking a shell, override the HISTFILE with this value. When setting to a string, it redirects the shell history to that @@ -115,13 +103,12 @@ detected as prompt when being sent on echoing hosts, therefore.") (defconst tramp-end-of-heredoc (md5 tramp-end-of-output) "String used to recognize end of heredoc strings.") -;;;###tramp-autoload -(defcustom tramp-use-ssh-controlmaster-options t +(defcustom tramp-use-ssh-controlmaster-options (not (eq system-type 'windows-nt)) "Whether to use `tramp-ssh-controlmaster-options'. Set it to nil, if you use Control* or Proxy* options in your ssh configuration." :group 'tramp - :version "24.4" + :version "28.1" :type 'boolean) (defvar tramp-ssh-controlmaster-options nil @@ -138,6 +125,15 @@ depends on the installed local ssh version. The string is used in `tramp-methods'.") +(defvar tramp-scp-strict-file-name-checking nil + "Which scp strict file name checking argument to use. + +It is the string \"-T\" if supported by the local scp (since +release 8.0), otherwise the string \"\". If it is nil, it will +be auto-detected by Tramp. + +The string is used in `tramp-methods'.") + ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload (tramp--with-startup @@ -173,8 +169,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") - ("-r") ("%c"))) + (tramp-copy-args (("-P" "%p") ("-p" "%k") + ("%x") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -182,14 +178,15 @@ The string is used in `tramp-methods'.") (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("-t" "-t") - ("-o" "RemoteCommand='%l'") ("%h"))) + ("-o" "RemoteCommand=\"%l\"") + ("%h"))) (tramp-async-args (("-q"))) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("-q") ("-r") ("%c"))) + ("%x") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -238,7 +235,8 @@ The string is used in `tramp-methods'.") (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("-t" "-t") - ("-o" "RemoteCommand='%l'") ("%h"))) + ("-o" "RemoteCommand=\"%l\"") + ("%h"))) (tramp-async-args (("-q"))) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) @@ -412,16 +410,34 @@ The string is used in `tramp-methods'.") ;;;###tramp-autoload (defconst tramp-completion-function-alist-ssh - '((tramp-parse-rhosts "/etc/hosts.equiv") + `((tramp-parse-rhosts "/etc/hosts.equiv") (tramp-parse-rhosts "/etc/shosts.equiv") - (tramp-parse-shosts "/etc/ssh_known_hosts") - (tramp-parse-sconfig "/etc/ssh_config") + ;; On W32 systems, the ssh directory is located somewhere else. + (tramp-parse-shosts ,(expand-file-name + "ssh/ssh_known_hosts" + (or (and (eq system-type 'windows-nt) + (getenv "ProgramData")) + "/etc/"))) + (tramp-parse-sconfig ,(expand-file-name + "ssh/ssh_config" + (or (and (eq system-type 'windows-nt) + (getenv "ProgramData")) + "/etc/"))) (tramp-parse-shostkeys "/etc/ssh2/hostkeys") (tramp-parse-sknownhosts "/etc/ssh2/knownhosts") (tramp-parse-rhosts "~/.rhosts") (tramp-parse-rhosts "~/.shosts") - (tramp-parse-shosts "~/.ssh/known_hosts") - (tramp-parse-sconfig "~/.ssh/config") + ;; On W32 systems, the .ssh directory is located somewhere else. + (tramp-parse-shosts ,(expand-file-name + ".ssh/known_hosts" + (or (and (eq system-type 'windows-nt) + (getenv "USERPROFILE")) + "~/"))) + (tramp-parse-sconfig ,(expand-file-name + ".ssh/config" + (or (and (eq system-type 'windows-nt) + (getenv "USERPROFILE")) + "~/"))) (tramp-parse-shostkeys "~/.ssh2/hostkeys") (tramp-parse-sknownhosts "~/.ssh2/knownhosts")) "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.") @@ -444,7 +460,7 @@ The string is used in `tramp-methods'.") ;;;###tramp-autoload (defconst tramp-completion-function-alist-putty `((tramp-parse-putty - ,(if (memq system-type '(windows-nt)) + ,(if (eq system-type 'windows-nt) "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions" "~/.putty/sessions"))) "Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.") @@ -477,70 +493,6 @@ The string is used in `tramp-methods'.") (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh) (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)) -;; "getconf PATH" yields: -;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin -;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin -;; GNU/Linux (Debian, Suse, RHEL): /bin:/usr/bin -;; FreeBSD, DragonFly: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! -;; FreeBSD 12.1, Darwin: /usr/bin:/bin:/usr/sbin:/sbin -;; IRIX64: /usr/bin -;; QNAP QTS: --- -;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin -;;;###tramp-autoload -(defcustom tramp-remote-path - '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" - "/usr/local/bin" "/usr/local/sbin" "/local/bin" "/local/freeware/bin" - "/local/gnu/bin" "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin" - "/opt/bin" "/opt/sbin" "/opt/local/bin") - "List of directories to search for executables on remote host. -For every remote host, this variable will be set buffer local, -keeping the list of existing directories on that host. - -You can use \"~\" in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with \"~\" will be ignored. - -`Default Directories' represent the list of directories given by -the command \"getconf PATH\". It is recommended to use this -entry on head of this list, because these are the default -directories for POSIX compatible commands. On remote hosts which -do not offer the getconf command (like cygwin), the value -\"/bin:/usr/bin\" is used instead. This entry is represented in -the list by the special value `tramp-default-remote-path'. - -`Private Directories' are the settings of the $PATH environment, -as given in your `~/.profile'. This entry is represented in -the list by the special value `tramp-own-remote-path'." - :group 'tramp - :type '(repeat (choice - (const :tag "Default Directories" tramp-default-remote-path) - (const :tag "Private Directories" tramp-own-remote-path) - (string :tag "Directory")))) - -;;;###tramp-autoload -(defcustom tramp-remote-process-environment - '("ENV=''" "TMOUT=0" "LC_CTYPE=''" - "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat" - "autocorrect=" "correct=") - "List of environment variables to be set on the remote host. - -Each element should be a string of the form ENVVARNAME=VALUE. An -entry ENVVARNAME= disables the corresponding environment variable, -which might have been set in the init files like ~/.profile. - -Special handling is applied to some environment variables, -which should not be set here: - -The PATH environment variable should be set via `tramp-remote-path'. - -The TERM environment variable should be set via `tramp-terminal-type'. - -The INSIDE_EMACS environment variable will automatically be set -based on the Tramp and Emacs versions, and should not be set here." - :group 'tramp - :version "26.1" - :type '(repeat string)) - -;;;###tramp-autoload (defcustom tramp-sh-extra-args '(("/bash\\'" . "-noediting -norc -noprofile") ("/zsh\\'" . "-f +Z -V")) @@ -567,6 +519,7 @@ shell from reading its init file." (tramp-yn-prompt-regexp tramp-action-yn) (tramp-terminal-prompt-regexp tramp-action-terminal) (tramp-antispoof-regexp tramp-action-confirm-message) + (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-process-alive)) "List of pattern/action pairs. Whenever a pattern matches, the corresponding action is performed. @@ -584,6 +537,7 @@ corresponding PATTERN matches, the ACTION function is called.") '((tramp-password-prompt-regexp tramp-action-password) (tramp-wrong-passwd-regexp tramp-action-permission-denied) (tramp-copy-failed-regexp tramp-action-permission-denied) + (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-out-of-band)) "List of pattern/action pairs. This list is used for copying/renaming with out-of-band methods. @@ -1010,6 +964,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (file-exists-p . tramp-sh-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-sh-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-sh-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -1018,7 +973,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (file-name-directory . tramp-handle-file-name-directory) (file-name-nondirectory . tramp-handle-file-name-nondirectory) ;; `file-name-sans-versions' performed by default handler. - (file-newer-than-file-p . tramp-sh-handle-file-newer-than-file-p) + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) (file-notify-add-watch . tramp-sh-handle-file-notify-add-watch) (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) (file-notify-valid-p . tramp-handle-file-notify-valid-p) @@ -1036,9 +991,11 @@ Format specifiers \"%s\" are replaced before the script is used.") (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sh-handle-make-directory) ;; `make-directory-internal' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) @@ -1057,6 +1014,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . tramp-sh-handle-vc-registered) (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime) (write-region . tramp-sh-handle-write-region)) @@ -1626,49 +1584,6 @@ ID-FORMAT valid values are `string' and `integer'." (or (tramp-check-cached-permissions v ?r) (tramp-run-test "-r" filename))))) -;; When the remote shell is started, it looks for a shell which groks -;; tilde expansion. Here, we assume that all shells which grok tilde -;; expansion will also provide a `test' command which groks `-nt' (for -;; newer than). If this breaks, tell me about it and I'll try to do -;; something smarter about it. -(defun tramp-sh-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond ((not (file-exists-p file1)) nil) - ((not (file-exists-p file2)) t) - (t ;; We are sure both files exist at this point. We try to - ;; get the mtime of both files. If they are not equal to - ;; the "dont-know" value, then we subtract the times and - ;; obtain the result. - (let ((fa1 (file-attributes file1)) - (fa2 (file-attributes file2))) - (if (and - (not - (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time fa1) - tramp-time-dont-know)) - (not - (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time fa2) - tramp-time-dont-know))) - (time-less-p - (tramp-compat-file-attribute-modification-time fa2) - (tramp-compat-file-attribute-modification-time fa1)) - ;; If one of them is the dont-know value, then we can - ;; still try to run a shell command on the remote host. - ;; However, this only works if both files are Tramp - ;; files and both have the same method, same user, same - ;; host. - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "Files %s and %s must have same method, user, host" - file1 file2))) - (with-parsed-tramp-file-name file1 nil - (tramp-run-test2 - (tramp-get-test-nt-command v) file1 file2))))))) - ;; Functions implemented using the basic functions above. (defun tramp-sh-handle-file-directory-p (filename) @@ -1825,7 +1740,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; files. (defun tramp-sh-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (string-match-p "/" filename) + (unless (tramp-compat-string-search "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1934,7 +1849,7 @@ ID-FORMAT valid values are `string' and `integer'." 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) (tramp-run-real-handler - 'copy-file + #'copy-file (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) @@ -1975,7 +1890,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory + #'copy-directory (list dirname newname keep-date parents copy-contents))) ;; When newname did exist, we have wrong cached values. @@ -2031,7 +1946,7 @@ file names." (length (tramp-compat-file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes - (apply #'file-extended-attributes (list filename)))) + (file-extended-attributes filename))) (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil @@ -2107,7 +2022,7 @@ file names." ;; errors, because ACL strings could be incompatible. (when attributes (ignore-errors - (apply #'set-file-extended-attributes (list newname attributes)))) + (set-file-extended-attributes newname attributes))) ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) @@ -2318,7 +2233,7 @@ The method used must be an out-of-band method." (t2 (tramp-tramp-file-p newname)) (orig-vec (tramp-dissect-file-name (if t1 filename newname))) copy-program copy-args copy-env copy-keep-date listener spec - options source target remote-copy-program remote-copy-args) + options source target remote-copy-program remote-copy-args p) (with-parsed-tramp-file-name (if t1 filename newname) nil (if (and t1 t2) @@ -2353,10 +2268,10 @@ The method used must be an out-of-band method." #'identity) (if t1 (tramp-make-copy-program-file-name v) - (tramp-unquote-shell-quote-argument filename))) + (tramp-compat-file-name-unquote filename))) target (if t2 (tramp-make-copy-program-file-name v) - (tramp-unquote-shell-quote-argument newname))) + (tramp-compat-file-name-unquote newname))) ;; Check for user. There might be an interactive setting. (setq user (or (tramp-file-name-user v) @@ -2370,53 +2285,38 @@ The method used must be an out-of-band method." (setq listener (number-to-string (+ 50000 (random 10000)))))) ;; Compose copy command. - (setq host (or host "") - user (or user "") - port (or port "") - spec (format-spec-make - ?t (tramp-get-connection-property - (tramp-get-connection-process v) "temp-file" "")) - options (format-spec (tramp-ssh-controlmaster-options v) spec) - spec (format-spec-make - ?h host ?u user ?p port ?r listener ?c options - ?k (if keep-date " " "") - ?n (concat "2>" (tramp-get-remote-null-device v))) + (setq options + (format-spec + (tramp-ssh-controlmaster-options v) + (format-spec-make + ?t (tramp-get-connection-property + (tramp-get-connection-process v) "temp-file" ""))) + spec (list + ?h (or host "") ?u (or user "") ?p (or port "") + ?r listener ?c options ?k (if keep-date " " "") + ?n (concat "2>" (tramp-get-remote-null-device v)) + ?x (tramp-scp-strict-file-name-checking v)) copy-program (tramp-get-method-parameter v 'tramp-copy-program) copy-keep-date (tramp-get-method-parameter v 'tramp-copy-keep-date) - copy-args - (delete - ;; " " has either been a replacement of "%k" (when - ;; keep-date argument is non-nil), or a replacement - ;; for the whole keep-date sublist. - " " - (dolist - (x (tramp-get-method-parameter v 'tramp-copy-args) copy-args) - (setq copy-args - (append - copy-args - (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) - (if (member "" y) '(" ") y)))))) - - copy-env - (delq - nil + ;; " " has either been a replacement of "%k" (when + ;; keep-date argument is non-nil), or a replacement for + ;; the whole keep-date sublist. + (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) + ;; `tramp-ssh-controlmaster-options' is a string instead + ;; of a list. Unflatten it. + copy-args + (tramp-compat-flatten-tree (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (string-join x " "))) - (tramp-get-method-parameter v 'tramp-copy-env))) - + (lambda (x) (if (tramp-compat-string-search " " x) + (split-string x) x)) + copy-args)) + copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) remote-copy-program - (tramp-get-method-parameter v 'tramp-remote-copy-program)) - - (dolist (x (tramp-get-method-parameter v 'tramp-remote-copy-args)) - (setq remote-copy-args - (append - remote-copy-args - (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) - (if (member "" y) '(" ") y))))) + (tramp-get-method-parameter v 'tramp-remote-copy-program) + remote-copy-args + (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) ;; Check for local copy program. (unless (executable-find copy-program) @@ -2462,41 +2362,38 @@ The method used must be an out-of-band method." v "process-name" (buffer-name (current-buffer))) (tramp-set-connection-property v "process-buffer" (current-buffer)) - (while copy-env + (when copy-env (tramp-message - orig-vec 6 "%s=\"%s\"" (car copy-env) (cadr copy-env)) - (setenv (pop copy-env) (pop copy-env))) + orig-vec 6 "%s=\"%s\"" + (car copy-env) (string-join (cdr copy-env) " ")) + (setenv (car copy-env) (string-join (cdr copy-env) " "))) (setq copy-args (append copy-args (if remote-copy-program (list (if t1 (concat ">" target) (concat "<" source))) - (list source target)))) - - ;; Use an asynchronous process. By this, password can - ;; be handled. We don't set a timeout, because the - ;; copying of large files can last longer than 60 secs. - (let* ((command - (mapconcat - #'identity (append (list copy-program) copy-args) - " ")) - (p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (start-process-shell-command - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - command)))) - (tramp-message orig-vec 6 "%s" command) - (process-put p 'vector orig-vec) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) - - ;; We must adapt `tramp-local-end-of-line' for - ;; sending the password. - (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) - (tramp-process-actions - p v nil tramp-actions-copy-out-of-band)))) + (list source target))) + ;; Use an asynchronous process. By this, password + ;; can be handled. We don't set a timeout, because + ;; the copying of large files can last longer than 60 + ;; secs. + p (let ((default-directory (tramp-compat-temporary-file-directory))) + (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program copy-args))) + (tramp-message orig-vec 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector orig-vec) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + + ;; We must adapt `tramp-local-end-of-line' for + ;; sending the password. + (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) + (tramp-process-actions + p v nil tramp-actions-copy-out-of-band))) ;; Reset the transfer process properties. (tramp-flush-connection-property v "process-name") @@ -2684,12 +2581,9 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Check for "--dired" output. - (forward-line -2) - (when (looking-at-p "//SUBDIRED//") - (forward-line -1)) - (when (looking-at "//DIRED//\\s-+") - (let ((beg (match-end 0)) - (end (point-at-eol))) + (when (re-search-backward "^//DIRED//\\s-+\\(.+\\)$" nil 'noerror) + (let ((beg (match-beginning 1)) + (end (match-end 0))) ;; Now read the numeric positions of file names. (goto-char beg) (while (< (point) end) @@ -2699,7 +2593,7 @@ The method used must be an out-of-band method." ;; End is followed by \n or by " -> ". (put-text-property start end 'dired-filename t)))))) ;; Remove trailing lines. - (goto-char (point-at-bol)) + (beginning-of-line) (while (looking-at "//") (forward-line 1) (delete-region (match-beginning 0) (point)))) @@ -2709,8 +2603,8 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Some busyboxes are reluctant to discard colors. - (unless - (string-match-p "color" (tramp-get-connection-property v "ls" "")) + (unless (tramp-compat-string-search + "color" (tramp-get-connection-property v "ls" "")) (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) (replace-match ""))) @@ -2780,66 +2674,75 @@ the result will be a local, non-Tramp, file name." (setq dir (or dir default-directory "/")) ;; Handle empty NAME. (when (zerop (length name)) (setq name ".")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory 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 - (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) - (setq localname (concat "~/" localname))) - ;; Tilde expansion if necessary. This needs a shell which - ;; groks tilde expansion! The function `tramp-find-shell' is - ;; supposed to find such a shell on the remote host. Please - ;; tell me about it when this doesn't work on your system. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - ;; We cannot simply apply "~/", because under sudo "~/" is - ;; expanded to the local user home directory but to the - ;; root home directory. On the other hand, using always - ;; the default user name for tilde expansion is not - ;; appropriate either, because ssh and companions might - ;; use a user name from the config file. - (when (and (string-equal uname "~") - (string-match-p "\\`su\\(do\\)?\\'" method)) - (setq uname (concat uname user))) - (setq uname - (with-tramp-connection-property v uname - (tramp-send-command - v (format "cd %s && pwd" (tramp-shell-quote-argument uname))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring (point) (point-at-eol))))) - (setq localname (concat uname fname)))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). - ;; `default-directory' is bound, because on Windows there would - ;; be problems with UNC shares or Cygwin mounts. - (let ((default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - v (tramp-drop-volume-letter - (tramp-run-real-handler - #'expand-file-name (list localname)))))))) + ;; On MS Windows, some special file names are not returned properly + ;; by `file-name-absolute-p'. + (if (and (eq system-type 'windows-nt) + (string-match-p + (concat "^\\([[:alpha:]]:\\|" null-device "$\\)") name)) + (tramp-run-real-handler #'expand-file-name (list name dir)) + ;; 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 + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) + (setq localname (concat "~/" localname))) + ;; Tilde expansion if necessary. This needs a shell which + ;; groks tilde expansion! The function `tramp-find-shell' is + ;; supposed to find such a shell on the remote host. Please + ;; tell me about it when this doesn't work on your system. + (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname))) + ;; We cannot simply apply "~/", because under sudo "~/" is + ;; expanded to the local user home directory but to the + ;; root home directory. On the other hand, using always + ;; the default user name for tilde expansion is not + ;; appropriate either, because ssh and companions might + ;; use a user name from the config file. + (when (and (string-equal uname "~") + (string-match-p "\\`su\\(do\\)?\\'" method)) + (setq uname (concat uname user))) + (setq uname + (with-tramp-connection-property v uname + (tramp-send-command + v + (format "cd %s && pwd" (tramp-shell-quote-argument uname))) + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))))) + (setq localname (concat uname fname)))) + ;; There might be a double slash, for example when "~/" + ;; expands to "/". Remove this. + (while (string-match "//" localname) + (setq localname (replace-match "/" t t localname))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) + ;; No tilde characters in file name, do normal + ;; `expand-file-name' (this does "/./" and "/../"). + ;; `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))))))))) ;;; Remote commands: ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. -;; The complete STDERR buffer is available only when the process has -;; terminated. (defun tramp-sh-handle-make-process (&rest args) "Like `make-process' for Tramp files. -STDERR can also be a file name. If method parameter `tramp-direct-async' -and connection property \"direct-async-process\" are non-nil, an -alternative implementation will be used." +STDERR can also be a remote file name. If method parameter +`tramp-direct-async' and connection property +\"direct-async-process\" are non-nil, an alternative +implementation will be used." (if (tramp-direct-async-process-p args) (apply #'tramp-handle-make-process args) (when args @@ -2849,7 +2752,10 @@ alternative implementation will be used." (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (if (plist-member args :connection-type) + (plist-get args :connection-type) + tramp-process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) @@ -2865,7 +2771,7 @@ alternative implementation will be used." (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (unless (memq connection-type '(nil pipe t pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) (unless (or (null filter) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) @@ -2873,7 +2779,7 @@ alternative implementation will be used." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'bufferp stderr))) - (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (when (and (stringp stderr) (not (tramp-equal-remote default-directory stderr))) (signal 'file-error (list "Wrong stderr" stderr))) @@ -2885,9 +2791,9 @@ alternative implementation will be used." ;; STDERR can also be a file name. (tmpstderr (and stderr - (if (and (stringp stderr) (tramp-tramp-file-p stderr)) - (tramp-unquote-file-local-name stderr) - (tramp-make-tramp-temp-file v)))) + (tramp-unquote-file-local-name + (if (stringp stderr) + stderr (tramp-make-tramp-temp-name v))))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) @@ -2896,7 +2802,8 @@ alternative implementation will be used." ;; "-c", it might be that the arguments exceed the ;; command line length. Therefore, we modify the ;; command. - (heredoc (and (stringp program) + (heredoc (and (not (bufferp stderr)) + (stringp program) (string-match-p "sh$" program) (= (length args) 2) (string-equal "-c" (car args)) @@ -2925,18 +2832,13 @@ alternative implementation will be used." (env (dolist (elt (cons prompt process-environment) env) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) + (if (tramp-compat-string-search "=" elt) (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv))))))) + (setq uenv (cons elt uenv)))))) + (env (setenv-internal + env "INSIDE_EMACS" (tramp-inside-emacs) 'keep)) (command (when (stringp program) - (setenv-internal - env "INSIDE_EMACS" - (concat (or (getenv "INSIDE_EMACS") emacs-version) - ",tramp:" tramp-version) - 'keep) (format "cd %s && %s exec %s %s env %s %s" (tramp-shell-quote-argument localname) (if uenv @@ -2965,6 +2867,23 @@ alternative implementation will be used." tramp-current-connection p) + ;; Handle error buffer. + (when (bufferp stderr) + (with-current-buffer stderr + (setq buffer-read-only nil)) + ;; Create named pipe. + (tramp-send-command v (format "mknod %s p" tmpstderr)) + ;; Create stderr process. + (make-process + :name (buffer-name stderr) + :buffer stderr + :command `("cat" ,tmpstderr) + :coding coding + :noquery t + :filter nil + :sentinel #'ignore + :file-handler t)) + (while (get-process name1) ;; NAME must be unique as process name. (setq i (1+ i) @@ -2993,16 +2912,16 @@ alternative implementation will be used." (if (symbolp coding) coding (cdr coding)))) (clear-visited-file-modtime) (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. (catch 'suppress - (tramp-maybe-open-connection v) - (setq p (tramp-get-connection-process v)) ;; Set the pid of the remote shell. This is ;; needed when sending signals remotely. (let ((pid (tramp-send-command-and-read v "echo $$"))) + (setq p (tramp-get-connection-process v)) (process-put p 'remote-pid pid) (tramp-set-connection-property p "remote-pid" pid)) + ;; Disable carriage return to newline translation. + (when (memq connection-type '(nil pipe)) + (tramp-send-command v "stty -icrnl")) ;; `tramp-maybe-open-connection' and ;; `tramp-send-command-and-read' could have ;; trashed the connection buffer. Remove this. @@ -3030,40 +2949,22 @@ alternative implementation will be used." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) - ;; We must flush them here already; otherwise - ;; `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Provide error buffer. This shows only - ;; initial error messages; messages arriving - ;; later on will be inserted when the process - ;; is deleted. The temporary file will exist - ;; until the process is deleted. + ;; Kill stderr process delete and named pipe. (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally remote-tmpstderr)) - ;; Delete tmpstderr file. (add-function :after (process-sentinel p) (lambda (_proc _msg) - (when (file-exists-p remote-tmpstderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr nil nil nil 'replace)) + (ignore-errors + (while (accept-process-output + (get-buffer-process stderr) 0 nil t)) + (delete-process (get-buffer-process stderr))) + (ignore-errors (delete-file remote-tmpstderr))))) ;; Return process. p))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer p nil) (kill-buffer (current-buffer))) @@ -3137,7 +3038,7 @@ alternative implementation will be used." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let (command env uenv input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. (setq command (mapconcat #'tramp-shell-quote-argument @@ -3145,16 +3046,10 @@ alternative implementation will be used." ;; We use as environment the difference to toplevel `process-environment'. (dolist (elt process-environment) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) + (if (tramp-compat-string-search "=" elt) (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv)))))) - (setenv-internal - env "INSIDE_EMACS" - (concat (or (getenv "INSIDE_EMACS") emacs-version) - ",tramp:" tramp-version) - 'keep) + (setq uenv (cons elt uenv))))) + (setenv-internal env "INSIDE_EMACS" (tramp-inside-emacs) 'keep) (when env (setq command (format @@ -3350,11 +3245,11 @@ alternative implementation will be used." (run-hooks 'tramp-handle-file-local-copy-hook) tmpfile))) -;; CCC grok LOCKNAME (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -3363,25 +3258,31 @@ alternative implementation will be used." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((uid (or (tramp-compat-file-attribute-user-id + (let ((file-locked (eq (file-locked-p lockname) t)) + (uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) (gid (or (tramp-compat-file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not file-locked)) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (if (and (tramp-local-host-p v) ;; `file-writable-p' calls `file-expand-file-name'. We ;; cannot use `tramp-run-real-handler' therefore. - (let (file-name-handler-alist) - (and - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))))) + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))) ;; Short track: if we are on the local host, we can run directly. - (tramp-run-real-handler - #'write-region - (list start end localname append 'no-message lockname)) + (let ((create-lockfiles (not file-locked))) + (write-region start end localname append 'no-message lockname)) (let* ((modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) @@ -3414,13 +3315,11 @@ alternative implementation will be used." ;; file. We call `set-visited-file-modtime' ourselves later ;; on. We must ensure that `file-coding-system-alist' ;; matches `tmpfile'. - (let (file-name-handler-alist - (file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile))) + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist filename tmpfile)) + create-lockfiles) (condition-case err - (tramp-run-real-handler - #'write-region - (list start end tmpfile append 'no-message lockname)) + (write-region start end tmpfile append 'no-message) ((error quit) (setq tramp-temp-buffer-file-name nil) (delete-file tmpfile) @@ -3589,6 +3488,12 @@ alternative implementation will be used." ;; Set the ownership. (when need-chown (tramp-set-file-uid-gid filename uid gid)) + + ;; Unlock file. + (when file-locked + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) (tramp-message v 0 "Wrote %s" filename)) @@ -3762,6 +3667,8 @@ Fall back to normal file name handler if no Tramp handler exists." (setq file-name (expand-file-name file-name)) (with-parsed-tramp-file-name file-name nil (let ((default-directory (file-name-directory file-name)) + (process-environment + (cons "GIO_USE_FILE_MONITOR=help" process-environment)) command events filter p sequence) (cond ;; "inotifywait". @@ -3794,18 +3701,6 @@ Fall back to normal file name handler if no Tramp handler exists." '(created changed changes-done-hint moved deleted)) ((memq 'attribute-change flags) '(attribute-changed))) sequence `(,command "monitor" ,localname))) - ;; "gvfs-monitor-dir". - ((setq command (tramp-get-remote-gvfs-monitor-dir v)) - (setq filter #'tramp-sh-gvfs-monitor-dir-process-filter - events - (cond - ((and (memq 'change flags) (memq 'attribute-change flags)) - '(created changed changes-done-hint moved deleted - attribute-changed)) - ((memq 'change flags) - '(created changed changes-done-hint moved deleted)) - ((memq 'attribute-change flags) '(attribute-changed))) - sequence `(,command ,localname))) ;; None. (t (tramp-error v 'file-notify-error @@ -3838,10 +3733,6 @@ Fall back to normal file name handler if no Tramp handler exists." (unless (process-live-p p) (tramp-error p 'file-notify-error "Monitoring not supported for `%s'" file-name)) - ;; Set "gio-file-monitor" property if needed. - (when (string-equal (file-name-nondirectory command) "gio") - (tramp-set-connection-property - p "gio-file-monitor" (tramp-get-remote-gio-file-monitor v))) p)))) (defun tramp-sh-gio-monitor-process-filter (proc string) @@ -3850,7 +3741,8 @@ Fall back to normal file name handler if no Tramp handler exists." (remote-prefix (with-current-buffer (process-buffer proc) (file-remote-p default-directory))) - (rest-string (process-get proc 'rest-string))) + (rest-string (process-get proc 'rest-string)) + pos) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) (tramp-message proc 6 "%S\n%s" proc string) @@ -3862,93 +3754,72 @@ Fall back to normal file name handler if no Tramp handler exists." "changes done" "changes-done-hint" string) string (tramp-compat-string-replace "renamed to" "moved" string)) - ;; https://bugs.launchpad.net/bugs/1742946 - (when - (string-match-p "Monitoring not supported\\|No locations given" string) - (delete-process proc)) - - ;; Delete empty lines. - (setq string (tramp-compat-string-replace "\n\n" "\n" string)) - - (while (string-match - (eval-when-compile - (concat "^[^:]+:" - "[[:space:]]\\([^:]+\\):" - "[[:space:]]" (regexp-opt tramp-gio-events t) - "\\([[:space:]]\\([^:]+\\)\\)?$")) - string) - - (let* ((file (match-string 1 string)) - (file1 (match-string 4 string)) - (object - (list - proc - (list - (intern-soft (match-string 2 string))) - ;; File names are returned as absolute paths. We must - ;; add the remote prefix. - (concat remote-prefix file) - (when file1 (concat remote-prefix file1))))) - (setq string (replace-match "" nil nil string)) - ;; Usually, we would add an Emacs event now. Unfortunately, - ;; `unread-command-events' does not accept several events at - ;; once. Therefore, we apply the handler directly. - (when (member (cl-caadr object) events) - (tramp-compat-funcall - (lookup-key special-event-map [file-notify]) - `(file-notify ,object file-notify-callback))))) - ;; Save rest of the string. - (when (zerop (length string)) (setq string nil)) - (when string (tramp-message proc 10 "Rest string:\n%s" string)) - (process-put proc 'rest-string string))) - -(defun tramp-sh-gvfs-monitor-dir-process-filter (proc string) - "Read output from \"gvfs-monitor-dir\" 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))) - (rest-string (process-get proc 'rest-string))) - (when rest-string - (tramp-message proc 10 "Previous string:\n%s" rest-string)) - (tramp-message proc 6 "%S\n%s" proc string) - (setq string (concat rest-string string) - ;; Attribute change is returned in unused wording. - string (tramp-compat-string-replace - "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - - (while (string-match - (concat "^[\n\r]*" - "Directory Monitor Event:[\n\r]+" - "Child = \\([^\n\r]+\\)[\n\r]+" - "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" - "Event = \\([^[:blank:]]+\\)[\n\r]+") - string) - (let* ((file (match-string 1 string)) - (file1 (match-string 3 string)) - (object - (list - proc - (list - (intern-soft - (tramp-compat-string-replace - "_" "-" (downcase (match-string 4 string))))) - ;; File names are returned as absolute paths. We must - ;; add the remote prefix. - (concat remote-prefix file) - (when file1 (concat remote-prefix file1))))) - (setq string (replace-match "" nil nil string)) - ;; Usually, we would add an Emacs event now. Unfortunately, - ;; `unread-command-events' does not accept several events at - ;; once. Therefore, we apply the handler directly. - (when (member (cl-caadr object) events) - (tramp-compat-funcall - (lookup-key special-event-map [file-notify]) - `(file-notify ,object file-notify-callback))))) + (catch 'doesnt-work + ;; https://bugs.launchpad.net/bugs/1742946 + (when + (string-match-p "Monitoring not supported\\|No locations given" string) + (delete-process proc) + (throw 'doesnt-work nil)) + + ;; Determine monitor name. + (unless (tramp-connection-property-p proc "gio-file-monitor") + (tramp-set-connection-property + proc "gio-file-monitor" + (cond + ;; We have seen this on cygwin gio and on emba. Let's make + ;; some assumptions. + ((string-match + "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string) + (setq pos (match-end 0)) + (cond + ((getenv "EMACS_EMBA_CI") 'GInotifyFileMonitor) + ((eq system-type 'cygwin) 'GPollFileMonitor) + (t nil))) + ;; TODO: What happens, if several monitor names are reported? + ((string-match "\ +Supported arguments for GIO_USE_FILE_MONITOR environment variable: +\\s-*\\([[:alpha:]]+\\) - 20" string) + (setq pos (match-end 0)) + (intern + (format "G%sFileMonitor" (capitalize (match-string 1 string))))) + (t (setq pos (length string)) nil))) + (setq string (substring string pos))) + + ;; Delete empty lines. + (setq string (tramp-compat-string-replace "\n\n" "\n" string)) + + (while (string-match + (eval-when-compile + (concat "^[^:]+:" + "[[:space:]]\\([^:]+\\):" + "[[:space:]]" (regexp-opt tramp-gio-events t) + "\\([[:space:]]\\([^:]+\\)\\)?$")) + string) + + (let* ((file (match-string 1 string)) + (file1 (match-string 4 string)) + (object + (list + proc + (list + (intern-soft (match-string 2 string))) + ;; File names are returned as absolute paths. We + ;; must add the remote prefix. + (concat remote-prefix file) + (when file1 (concat remote-prefix file1))))) + (setq string (replace-match "" nil nil string)) + ;; Usually, we would add an Emacs event now. Unfortunately, + ;; `unread-command-events' does not accept several events at + ;; once. Therefore, we apply the handler directly. + (when (member (cl-caadr object) events) + (tramp-compat-funcall + (lookup-key special-event-map [file-notify]) + `(file-notify ,object file-notify-callback)))))) ;; Save rest of the string. + (while (string-match "^\n" string) + (setq string (replace-match "" nil nil string))) (when (zerop (length string)) (setq string nil)) (when string (tramp-message proc 10 "Rest string:\n%s" string)) (process-put proc 'rest-string string))) @@ -4098,24 +3969,6 @@ Returns the exit code of the `test' program." switch (tramp-shell-quote-argument localname))))) -(defun tramp-run-test2 (format-string file1 file2) - "Run `test'-like program on the remote system, given FILE1, FILE2. -FORMAT-STRING contains the program name, switches, and place holders. -Returns the exit code of the `test' program. Barfs if the methods, -hosts, or files, disagree." - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "tramp-run-test2 only implemented for same method, user, host"))) - (with-parsed-tramp-file-name file1 v1 - (with-parsed-tramp-file-name file1 v2 - (tramp-send-command-and-check - v1 - (format format-string - (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname)))))) - (defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) "Regexp to determine remote SunOS.") @@ -4307,10 +4160,9 @@ file exists and nonzero exit status otherwise." (tramp-send-command vec (format (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "exec env TERM='%s' INSIDE_EMACS='%s' " "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i") - tramp-terminal-type - (or (getenv "INSIDE_EMACS") emacs-version) tramp-version + tramp-terminal-type (tramp-inside-emacs) (or (getenv-internal "ENV" tramp-remote-process-environment) "") (if (stringp tramp-histfile-override) (format "HISTFILE=%s" @@ -4463,7 +4315,7 @@ process to set up. VEC specifies the connection." ;; Use MULE to select the right EOL convention for communicating ;; with the process. (let ((cs (or (and (memq 'utf-8-hfs (coding-system-list)) - (string-match-p "^Darwin" uname) + (string-prefix-p "Darwin" uname) (cons 'utf-8-hfs 'utf-8-hfs)) (and (memq 'utf-8 (coding-system-list)) (string-match-p "utf-?8" (tramp-get-remote-locale vec)) @@ -4476,7 +4328,7 @@ process to set up. VEC specifies the connection." cs-encode (or (cdr cs) 'undecided) cs-encode (coding-system-change-eol-conversion - cs-encode (if (string-match-p "^Darwin" uname) 'mac 'unix))) + cs-encode (if (string-prefix-p "Darwin" uname) 'mac 'unix))) (tramp-send-command vec "(echo foo ; echo bar)" t) (goto-char (point-min)) (when (search-forward "\r" nil t) @@ -4526,7 +4378,7 @@ process to set up. VEC specifies the connection." ;; IRIX64 bash expands "!" even when in single quotes. This ;; destroys our shell functions, we must disable it. See ;; <https://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. - (when (string-match-p "^IRIX64" uname) + (when (string-prefix-p "IRIX64" uname) (tramp-send-command vec "set +H" t)) ;; Disable tab expansion. @@ -4782,12 +4634,12 @@ means standard output and thus the current buffer), or nil (which means discard it)." (tramp-call-process nil tramp-encoding-shell - (when (and input (not (string-match-p "%s" cmd))) input) + (when (and input (not (tramp-compat-string-search "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (string-match-p "%s" cmd) (format cmd input) cmd) + (if (tramp-compat-string-search "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -4918,6 +4770,33 @@ Goes through the list `tramp-inline-compress-commands'." " -o ControlPersist=no"))))))))) tramp-ssh-controlmaster-options))) +(defun tramp-scp-strict-file-name-checking (vec) + "Return the strict file name checking argument of the local scp." + (cond + ;; No options to be computed. + ((null (assoc "%x" (tramp-get-method-parameter vec 'tramp-copy-args))) + "") + + ;; There is already a value to be used. + ((stringp tramp-scp-strict-file-name-checking) + tramp-scp-strict-file-name-checking) + + ;; Determine the options. + (t (setq tramp-scp-strict-file-name-checking "") + (let ((case-fold-search t)) + (ignore-errors + (when (executable-find "scp") + (with-tramp-progress-reporter + vec 4 "Computing strict file name argument" + (with-temp-buffer + (tramp-call-process vec "scp" nil t nil "-T") + (goto-char (point-min)) + (unless + (search-forward-regexp + "\\(illegal\\|unknown\\) option -- T" nil t) + (setq tramp-scp-strict-file-name-checking "-T"))))))) + tramp-scp-strict-file-name-checking))) + (defun tramp-timeout-session (vec) "Close the connection VEC after a session timeout. If there is just some editing, retry it after 5 seconds." @@ -4927,7 +4806,7 @@ If there is just some editing, retry it after 5 seconds." (progn (tramp-message vec 5 "Cannot timeout session, trying it again in %s seconds." 5) - (run-at-time 5 nil 'tramp-timeout-session vec)) + (run-at-time 5 nil #'tramp-timeout-session vec)) (tramp-message vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes))) @@ -4982,10 +4861,12 @@ connection if a previous connection has died for some reason." (with-tramp-progress-reporter vec 3 (if (zerop (length (tramp-file-name-user vec))) - (format "Opening connection for %s using %s" + (format "Opening connection %s for %s using %s" + process-name (tramp-file-name-host vec) (tramp-file-name-method vec)) - (format "Opening connection for %s@%s using %s" + (format "Opening connection %s for %s@%s using %s" + process-name (tramp-file-name-user vec) (tramp-file-name-host vec) (tramp-file-name-method vec))) @@ -5058,19 +4939,17 @@ connection if a previous connection has died for some reason." (l-domain (tramp-file-name-domain hop)) (l-host (tramp-file-name-host hop)) (l-port (tramp-file-name-port hop)) - (login-program - (tramp-get-method-parameter hop 'tramp-login-program)) - (login-args - (tramp-get-method-parameter hop 'tramp-login-args)) (remote-shell (tramp-get-method-parameter hop 'tramp-remote-shell)) (extra-args (tramp-get-sh-extra-args remote-shell)) (async-args - (tramp-get-method-parameter hop 'tramp-async-args)) + (tramp-compat-flatten-tree + (tramp-get-method-parameter hop 'tramp-async-args))) (connection-timeout (tramp-get-method-parameter hop 'tramp-connection-timeout)) - (command login-program) + (command + (tramp-get-method-parameter hop 'tramp-login-program)) ;; We don't create the temporary file. In ;; fact, it is just a prefix for the ;; ControlPath option of ssh; the real @@ -5084,11 +4963,7 @@ connection if a previous connection has died for some reason." (with-tramp-connection-property (tramp-get-process vec) "temp-file" (tramp-compat-make-temp-name))) - spec r-shell) - - ;; Add arguments for asynchronous processes. - (when (and process-name async-args) - (setq login-args (append async-args login-args))) + r-shell) ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) @@ -5113,31 +4988,24 @@ connection if a previous connection has died for some reason." ;; Replace `login-args' place holders. (setq - l-host (or l-host "") - l-user (or l-user "") - l-port (or l-port "") - spec (format-spec-make ?t tmpfile) - options (format-spec options spec) - spec (format-spec-make - ?h l-host ?u l-user ?p l-port ?c options - ?l (concat remote-shell " " extra-args " -i")) command - (concat - ;; We do not want to see the trailing local - ;; prompt in `start-file-process'. - (unless r-shell "exec ") - command " " - (mapconcat - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (string-join x " "))) - login-args " ") - ;; Local shell could be a Windows COMSPEC. It - ;; doesn't know the ";" syntax, but we must exit - ;; always for `start-file-process'. It could - ;; also be a restricted shell, which does not - ;; allow "exec". - (when r-shell " && exit || exit"))) + (mapconcat + #'identity + (append + ;; We do not want to see the trailing local + ;; prompt in `start-file-process'. + (unless r-shell '("exec")) + `(,command) + ;; Add arguments for asynchronous processes. + (when process-name async-args) + (tramp-expand-args + hop 'tramp-login-args + ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") + ?c (format-spec options (format-spec-make ?t tmpfile)) + ?l (concat remote-shell " " extra-args " -i")) + ;; A restricted shell does not allow "exec". + (when r-shell '("&&" "exit" "||" "exit"))) + " ")) ;; Send the command. (tramp-message vec 3 "Sending command `%s'" command) @@ -5158,7 +5026,7 @@ connection if a previous connection has died for some reason." (when (tramp-get-connection-property p "session-timeout" nil) (run-at-time (tramp-get-connection-property p "session-timeout" nil) nil - 'tramp-timeout-session vec)) + #'tramp-timeout-session vec)) ;; Make initial shell settings. (tramp-open-connection-setup-interactive-shell p vec) @@ -5361,7 +5229,7 @@ Return ATTR." (when (stringp (car attr)) (aset (nth 8 attr) 0 ?l))) ;; Convert directory indication bit. - (when (string-match-p "^d" (nth 8 attr)) + (when (string-prefix-p "d" (nth 8 attr)) (setcar attr t)) ;; Convert symlink from `tramp-do-file-attributes-with-stat'. ;; Decode also multibyte string. @@ -5423,15 +5291,16 @@ Return ATTR." (directory-file-name (tramp-file-name-unquote-localname vec)))) (when (string-match-p tramp-ipv6-regexp host) (setq host (format "[%s]" host))) + ;; This does not work for MS Windows scp, if there are characters + ;; to be quoted. OpenSSH 8 supports disabling of strict file name + ;; checking in scp, we use it when available. (unless (string-match-p "ftp$" method) - (setq localname (tramp-shell-quote-argument localname))) + (setq localname (tramp-unquote-shell-quote-argument localname))) (cond ((tramp-get-method-parameter vec 'tramp-remote-copy-program) localname) - ((not (zerop (length user))) - (format - "%s@%s:%s" user host (tramp-unquote-shell-quote-argument localname))) - (t (format "%s:%s" host (tramp-unquote-shell-quote-argument localname)))))) + ((zerop (length user)) (format "%s:%s" host localname)) + (t (format "%s@%s:%s" user host localname))))) (defun tramp-method-out-of-band-p (vec size) "Return t if this is an out-of-band method, nil otherwise." @@ -5459,8 +5328,7 @@ Nonexistent directories are removed from spec." ;; cache the result for the session only. Otherwise, the ;; result is cached persistently. (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-process vec) - vec) + (tramp-get-process vec) vec) "remote-path" (let* ((remote-path (copy-tree tramp-remote-path)) (elt1 (memq 'tramp-default-remote-path remote-path)) @@ -5478,7 +5346,7 @@ Nonexistent directories are removed from spec." (progn (tramp-message vec 3 - "`getconf PATH' not successful, using default value \"%s\"." + "`getconf PATH' not successful, using default value \"%s\"." "/bin:/usr/bin") "/bin:/usr/bin")))) (own-remote-path @@ -5682,15 +5550,15 @@ Nonexistent directories are removed from spec." ;; Check whether stat(1) returns usable syntax. "%s" does not ;; work on older AIX systems. Recent GNU stat versions ;; (8.24?) use shell quoted format for "%N", we check the - ;; boundaries "`" and "'", therefore. See Bug#23422 in - ;; coreutils. Since GNU stat 8.26, environment variable - ;; QUOTING_STYLE is supported. + ;; boundaries "`" and "'" and their localized variants, + ;; therefore. See Bug#23422 in coreutils. Since GNU stat + ;; 8.26, environment variable QUOTING_STYLE is supported. (when result (setq result (concat "env QUOTING_STYLE=locale " result) tmp (tramp-send-command-and-read vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror)) (unless (and (listp tmp) (stringp (car tmp)) - (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp)) + (string-match-p "^[\"`‘„”«「]/[\"'’“”»」]$" (car tmp)) (integerp (cadr tmp))) (setq result nil))) result)))) @@ -5765,42 +5633,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-message vec 5 "Finding a suitable `gio-monitor' command") (tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t))) -(defun tramp-get-remote-gio-file-monitor (vec) - "Determine remote GFileMonitor." - (with-tramp-connection-property vec "gio-file-monitor" - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 5 "Finding the used GFileMonitor") - (when-let ((gio (tramp-get-remote-gio-monitor vec))) - ;; Search for the used FileMonitor. There is no known way to - ;; get this information directly from gio, so we check for - ;; linked libraries of libgio. - (when (tramp-send-command-and-check vec (concat "ldd " gio)) - (goto-char (point-min)) - (when (re-search-forward "\\S-+/libgio\\S-+") - (when (tramp-send-command-and-check - vec (concat "strings " (match-string 0))) - (goto-char (point-min)) - (re-search-forward - (format - "^%s$" - (regexp-opt - '("GFamFileMonitor" "GFenFileMonitor" - "GInotifyFileMonitor" "GKqueueFileMonitor"))) - nil 'noerror) - (intern (match-string 0))))))))) - -(defun tramp-get-remote-gvfs-monitor-dir (vec) - "Determine remote `gvfs-monitor-dir' command." - (with-tramp-connection-property vec "gvfs-monitor-dir" - (tramp-message vec 5 "Finding a suitable `gvfs-monitor-dir' command") - ;; We distinguish "gvfs-monitor-dir.exe" from cygwin in order to - ;; establish better timeouts in filenotify-tests.el. Any better - ;; distinction approach would be welcome! - (or (tramp-find-executable - vec "gvfs-monitor-dir.exe" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "gvfs-monitor-dir" (tramp-get-remote-path vec) t t)))) - (defun tramp-get-remote-inotifywait (vec) "Determine remote `inotifywait' command." (with-tramp-connection-property vec "inotifywait" @@ -5945,16 +5777,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile))) (delete-file tmpfile))))) -(defun tramp-get-env-with-u-option (vec) - "Check, whether the remote `env' command supports the -u option." - (with-tramp-connection-property vec "env-u-option" - (tramp-message vec 5 "Checking, whether `env -u' works") - ;; Option "-u" is a GNU extension. - (tramp-send-command-and-check - vec (format "env FOO=foo env -u FOO 2>%s | grep -qv FOO" - (tramp-get-remote-null-device vec)) - t))) - ;; Some predefined connection properties. (defun tramp-get-inline-compress (vec prop size) "Return the compress command related to PROP. @@ -5987,12 +5809,13 @@ function cell is returned to be applied on a buffer." (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-process vec) prop nil))) - (prop1 (if (string-match-p "encoding" prop) + (prop1 (if (tramp-compat-string-search "encoding" prop) "inline-compress" "inline-decompress")) compress) ;; The connection property might have been cached. So we must ;; send the script to the remote side - maybe. - (when (and coding (symbolp coding) (string-match-p "remote" prop)) + (when (and coding (symbolp coding) + (tramp-compat-string-search "remote" prop)) (let ((name (symbol-name coding))) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) @@ -6004,7 +5827,7 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (string-match-p "decompress" prop1) + (if (tramp-compat-string-search "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) @@ -6023,16 +5846,16 @@ function cell is returned to be applied on a buffer." (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (string-match-p "decoding" prop)) + ((and compress (tramp-compat-string-search "decoding" prop)) (format ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. (cond - ((and (string-match-p "local" prop) - (memq system-type '(windows-nt))) + ((and (tramp-compat-string-search "local" prop) + (eq system-type 'windows-nt)) "(%s | \"%s\")") - ((string-match-p "local" prop) "(%s | %s)") + ((tramp-compat-string-search "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -6040,14 +5863,14 @@ function cell is returned to be applied on a buffer." ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. - (if (and (string-match-p "local" prop) - (memq system-type '(windows-nt))) + (if (and (tramp-compat-string-search "local" prop) + (eq system-type 'windows-nt)) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((string-match-p "decoding" prop) + ((tramp-compat-string-search "decoding" prop) (cond - ((string-match-p "local" prop) (format "%s" coding)) + ((tramp-compat-string-search "local" prop) (format "%s" coding)) (t (format "%s >%%s" coding)))) (t (format "%s <%%s" coding))))))) @@ -6143,8 +5966,6 @@ function cell is returned to be applied on a buffer." ;; session could be reused after a connection loss. Use dtach, or ;; screen, or tmux, or mosh. ;; -;; * Implement `:stderr' of `make-process' as pipe process. - ;; * One interesting solution (with other applications as well) would ;; be to stipulate, as a directory or connection-local variable, an ;; additional rc file on the remote machine that is sourced every diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 26ec910ecc8..69372449172 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -60,20 +60,17 @@ tramp-smb-method '((tramp-parse-netrc "~/.netrc")))) -;;;###tramp-autoload (defcustom tramp-smb-program "smbclient" "Name of SMB client to run." :group 'tramp :type 'string) -;;;###tramp-autoload (defcustom tramp-smb-acl-program "smbcacls" "Name of SMB acls to run." :group 'tramp :type 'string :version "24.4") -;;;###tramp-autoload (defcustom tramp-smb-conf null-device "Path of the \"smb.conf\" file. If it is nil, no \"smb.conf\" will be added to the `tramp-smb-program' @@ -81,7 +78,6 @@ call, letting the SMB client use the default one." :group 'tramp :type '(choice (const nil) (file :must-match t))) -;;;###tramp-autoload (defcustom tramp-smb-options nil "List of additional options. They are added to the `tramp-smb-program' call via \"--option '...'\". @@ -251,6 +247,7 @@ See `tramp-actions-before-shell' for more info.") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-smb-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-smb-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -277,9 +274,11 @@ See `tramp-actions-before-shell' for more info.") (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) @@ -298,6 +297,7 @@ See `tramp-actions-before-shell' for more info.") (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-smb-handle-write-region)) @@ -305,7 +305,6 @@ See `tramp-actions-before-shell' for more info.") Operations not mentioned here will be handled by the default Emacs primitives.") ;; Options for remote processes via winexe. -;;;###tramp-autoload (defcustom tramp-smb-winexe-program "winexe" "Name of winexe client to run. If it isn't found in the local $PATH, the absolute path of winexe @@ -314,7 +313,6 @@ shall be given. This is needed for remote processes." :type 'string :version "24.3") -;;;###tramp-autoload (defcustom tramp-smb-winexe-shell-command "powershell.exe" "Shell to be used for processes on remote machines. This must be Powershell V2 compatible." @@ -322,7 +320,6 @@ This must be Powershell V2 compatible." :type 'string :version "24.3") -;;;###tramp-autoload (defcustom tramp-smb-winexe-shell-command-switch "-file -" "Command switch used together with `tramp-smb-winexe-shell-command'. This can be used to disable echo etc." @@ -539,7 +536,7 @@ arguments to pass to the OPERATION." (tramp-process-actions p v nil tramp-smb-actions-with-tar) (while (process-live-p p) - (sit-for 0.1)) + (sleep-for 0.1)) (tramp-message v 6 "\n%s" (buffer-string)))) ;; Reset the transfer process properties. @@ -725,7 +722,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name nil)) @@ -743,6 +740,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Make the file name absolute. (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name @@ -849,7 +849,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (string-match-p "d" (nth 1 entry)) + (list (and (tramp-compat-string-search "d" (nth 1 entry)) t) ;0 file type -1 ;1 link count uid ;2 uid @@ -982,7 +982,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (mapcar (lambda (x) (list - (if (string-match-p "d" (nth 1 x)) + (if (tramp-compat-string-search "d" (nth 1 x)) (file-name-as-directory (nth 0 x)) (nth 0 x)))) (tramp-smb-get-file-entries directory))))))) @@ -1021,7 +1021,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) - (string-match-p + (tramp-compat-string-search "w" (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) @@ -1076,9 +1076,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match-p - (format "^%s" base) (nth 0 x)) - x)) + (when (string-match-p (format "^%s" base) (nth 0 x)) x)) entries) ;; We just need the only and only entry FILENAME. (list (assoc base entries))))) @@ -1088,14 +1086,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (string-match-p "t" switches) + (if (tramp-compat-string-search "t" switches) ;; Sort by date. (time-less-p (nth 3 y) (nth 3 x)) ;; Sort by name. (string-lessp (nth 0 x) (nth 0 y)))))) ;; Handle "-F" switch. - (when (string-match-p "F" switches) + (when (tramp-compat-string-search "F" switches) (mapc (lambda (x) (unless (zerop (length (car x))) @@ -1124,7 +1122,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (nth 0 x) (file-name-directory filename)) 'string))))) - (when (string-match-p "l" switches) + (when (tramp-compat-string-search "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1153,7 +1151,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (put-text-property start (point) 'dired-filename t)) ;; Insert symlink. - (when (and (string-match-p "l" switches) + (when (and (tramp-compat-string-search "l" switches) (stringp (tramp-compat-file-attribute-type attr))) (insert " -> " (tramp-compat-file-attribute-type attr)))) @@ -1259,7 +1257,7 @@ component is used as the target of the symlink." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let* ((name (file-name-nondirectory program)) (name1 name) (i 0) @@ -1551,7 +1549,7 @@ component is used as the target of the symlink." ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (tramp-compat-string-search tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) @@ -1579,7 +1577,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (defun tramp-smb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -1588,15 +1587,25 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((curbuf (current-buffer)) + (let ((file-locked (eq (file-locked-p lockname) t)) + (curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not file-locked)) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (tramp-run-real-handler - #'write-region (list start end tmpfile append 'no-message lockname)) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (with-tramp-progress-reporter v 3 (format "Moving tmp file %s to %s" tmpfile filename) @@ -1623,6 +1632,11 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (file-attributes filename)) (current-time)))) + ;; Unlock file. + (when file-locked + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + ;; The end. (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) @@ -1841,10 +1855,12 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." mode (or (match-string 1 line) "") mode (format "%s%s" - (if (string-match-p "D" mode) "d" "-") + (if (tramp-compat-string-search "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (concat "r" (if (string-match-p "R" mode) "-" "w") "x"))) + (format + "r%sx" + (if (tramp-compat-string-search "R" mode) "-" "w")))) line (substring line 0 -6)) (cl-return)) @@ -1925,7 +1941,7 @@ If ARGUMENT is non-nil, use it as argument for ;; Check whether we still have the same smbclient version. ;; Otherwise, we must delete the connection cache, because - ;; capabilities migh have changed. + ;; capabilities might have changed. (unless (or argument (processp p)) (let ((default-directory (tramp-compat-temporary-file-directory)) (command (concat tramp-smb-program " -V"))) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el new file mode 100644 index 00000000000..c5b84a6e4e4 --- /dev/null +++ b/lisp/net/tramp-sshfs.el @@ -0,0 +1,391 @@ +;;; tramp-sshfs.el --- Tramp access functions via sshfs -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; sshfs is a program to mount a virtual file system, based on an sftp +;; connection. Tramp uses its mount utility to access files and +;; directories there. + +;; A remote file under sshfs control has the form +;; "/sshfs:user@host#port:/path/to/file". User name and port number +;; are optional. + +;;; Code: + +(require 'tramp) +(require 'tramp-fuse) + +;;;###tramp-autoload +(defconst tramp-sshfs-method "sshfs" + "Tramp method for sshfs mounts.") + +(defcustom tramp-sshfs-program "sshfs" + "The sshfs mount command." + :group 'tramp + :version "28.1" + :type 'string) + +;;;###tramp-autoload +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-sshfs-method + (tramp-mount-args (("-C") ("-p" "%p") + ("-o" "idmap=user,reconnect"))) + ;; These are for remote processes. + (tramp-login-program "ssh") + (tramp-login-args (("-q")("-l" "%u") ("-p" "%p") + ("-e" "none") ("%h") ("%l"))) + (tramp-direct-async t) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + + (add-to-list 'tramp-connection-properties + `(,(format "/%s:" tramp-sshfs-method) "direct-async-process" t)) + + (tramp-set-completion-function + tramp-sshfs-method tramp-completion-function-alist-ssh)) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-sshfs-file-name-handler-alist + '((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) + (copy-file . tramp-sshfs-handle-copy-file) + (delete-directory . tramp-fuse-handle-delete-directory) + (delete-file . tramp-fuse-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-handle-directory-file-name) + (directory-files . tramp-fuse-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . tramp-sshfs-handle-exec-path) + (expand-file-name . tramp-handle-expand-file-name) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-fuse-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-fuse-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) + (file-name-completion . tramp-handle-file-name-completion) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-fuse-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) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-sshfs-handle-file-system-info) + (file-truename . tramp-handle-file-truename) + (file-writable-p . tramp-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-handle-insert-directory) + (insert-file-contents . tramp-sshfs-handle-insert-file-contents) + (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-fuse-handle-make-directory) + (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . tramp-handle-make-process) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-file . tramp-sshfs-handle-process-file) + (rename-file . tramp-sshfs-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . tramp-sshfs-handle-set-file-modes) + (set-file-selinux-context . ignore) + (set-file-times . ignore) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-handle-shell-command) + (start-file-process . tramp-handle-start-file-process) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) + (tramp-set-file-uid-gid . ignore) + (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-sshfs-handle-write-region)) +"Alist of handler functions for Tramp SSHFS method. +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))) + +;;;###tramp-autoload +(defun tramp-sshfs-file-name-handler (operation &rest args) + "Invoke the sshfs handler for OPERATION and ARGS. +First arg specifies the OPERATION, second arg is a list of +arguments to pass to the OPERATION." + (if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) + +;;;###tramp-autoload +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-sshfs-file-name-p #'tramp-sshfs-file-name-handler)) + + +;; File name primitives. + +(defun tramp-sshfs-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + (if (file-directory-p filename) + (copy-directory filename newname keep-date t) + (copy-file + (if (tramp-sshfs-file-name-p filename) + (tramp-fuse-local-file-name filename) filename) + (if (tramp-sshfs-file-name-p newname) + (tramp-fuse-local-file-name newname) newname) + ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (when (tramp-sshfs-file-name-p newname) + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname))))) + +(defun tramp-sshfs-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (with-parsed-tramp-file-name default-directory nil + (with-tramp-connection-property (tramp-get-process v) "remote-path" + (with-temp-buffer + (process-file "getconf" nil t nil "PATH") + (split-string + (progn + ;; Read the expression. + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))) + ":" 'omit)))) + ;; The equivalent to `exec-directory'. + `(,(tramp-file-local-name (expand-file-name default-directory))))) + +(defun tramp-sshfs-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + ;;`file-system-info' exists since Emacs 27.1. + (tramp-compat-funcall 'file-system-info (tramp-fuse-local-file-name filename))) + +(defun tramp-sshfs-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for Tramp files." + (let ((result + (insert-file-contents + (tramp-fuse-local-file-name filename) visit beg end replace))) + (when visit (setq buffer-file-name filename)) + (cons (expand-file-name filename) (cdr result)))) + +(defun tramp-sshfs-handle-process-file + (program &optional infile destination display &rest args) + "Like `process-file' for Tramp files." + ;; The implementation is not complete yet. + (when (and (numberp destination) (zerop destination)) + (error "Implementation does not handle immediate return")) + + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((command + (format + "cd %s && exec %s" + localname + (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))) + (unwind-protect + (apply + #'tramp-call-process + v (tramp-get-method-parameter v 'tramp-login-program) + infile destination display + (tramp-expand-args + v 'tramp-login-args + ?h (or (tramp-file-name-host v) "") + ?u (or (tramp-file-name-user v) "") + ?p (or (tramp-file-name-port v) "") + ?l command)) + + (unless process-file-side-effects + (tramp-flush-directory-properties v "")))))) + +(defun tramp-sshfs-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + (rename-file + (if (tramp-sshfs-file-name-p filename) + (tramp-fuse-local-file-name filename) filename) + (if (tramp-sshfs-file-name-p newname) + (tramp-fuse-local-file-name newname) newname) + ok-if-already-exists) + (when (tramp-sshfs-file-name-p filename) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname))) + (when (tramp-sshfs-file-name-p newname) + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))) + +(defun tramp-sshfs-handle-set-file-modes (filename mode &optional flag) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (tramp-compat-set-file-modes + (tramp-fuse-local-file-name filename) mode flag)))) + +(defun tramp-sshfs-handle-write-region + (start end filename &optional append visit lockname mustbenew) + "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) + (with-parsed-tramp-file-name filename nil + (when (and mustbenew (file-exists-p filename) + (or (eq mustbenew 'excl) + (not + (y-or-n-p + (format "File %s exists; overwrite anyway? " filename))))) + (tramp-error v 'file-already-exists filename)) + + (let ((file-locked (eq (file-locked-p lockname) t))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not file-locked)) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + + (let (create-lockfiles) + (write-region + start end (tramp-fuse-local-file-name filename) append 'nomessage) + (tramp-flush-file-properties v localname)) + + ;; Unlock file. + (when file-locked + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) + + +;; File name conversions. + +(defun tramp-sshfs-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + ;; During completion, don't reopen a new connection. + (unless (tramp-connectable-p vec) + (throw 'non-essential 'non-essential)) + + ;; We need a process bound to the connection buffer. Therefore, we + ;; create a dummy process. Maybe there is a better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil) + + ;; 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) + + ;; Create directory. + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) + + (unless + (or (tramp-fuse-mounted-p vec) + (with-temp-buffer + (zerop + (apply + #'tramp-call-process + vec tramp-sshfs-program nil t nil + (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-expand-args + vec 'tramp-mount-args + ?p (or (tramp-file-name-port vec) ""))))) + (tramp-error + vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec)))) + + ;; Mark it as connected. + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t))) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-sshfs 'force))) + +(provide 'tramp-sshfs) + +;;; tramp-sshfs.el ends here diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 0a60b791822..5895f1d25b5 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -88,6 +88,7 @@ See `tramp-actions-before-shell' for more info.") (file-exists-p . tramp-sudoedit-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-sudoedit-handle-file-name-all-completions) @@ -115,9 +116,11 @@ See `tramp-actions-before-shell' for more info.") (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sudoedit-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) @@ -136,6 +139,7 @@ See `tramp-actions-before-shell' for more info.") (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-sudoedit-handle-write-region)) @@ -233,7 +237,7 @@ absolute file names." (file-attributes filename))) (file-modes (tramp-default-file-modes filename)) (attributes (and preserve-extended-attributes - (apply #'file-extended-attributes (list filename)))) + (file-extended-attributes filename))) (sudoedit-operation (cond ((and (eq op 'copy) preserve-uid-gid) '("cp" "-f" "-p")) @@ -289,7 +293,7 @@ absolute file names." ;; errors, because ACL strings could be incompatible. (when attributes (ignore-errors - (apply #'set-file-extended-attributes (list newname attributes)))) + (set-file-extended-attributes newname attributes))) (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 @@ -349,7 +353,7 @@ the result will be a local, non-Tramp, file name." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) (with-parsed-tramp-file-name name nil ;; Tilde expansion if necessary. We cannot accept "~/", because ;; under sudo "~/" is expanded to the local user home directory @@ -364,6 +368,9 @@ the result will be a local, non-Tramp, file name." (when (string-equal uname "~") (setq uname (concat uname user))) (setq localname (concat uname fname)))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) ;; Do normal `expand-file-name' (this does "~user/", "/./" and "/../"). (tramp-make-tramp-file-name v (expand-file-name localname)))) @@ -647,7 +654,7 @@ component is used as the target of the symlink." 'rename filename newname ok-if-already-exists 'keep-date 'preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list filename newname ok-if-already-exists)))) + #'rename-file (list filename newname ok-if-already-exists)))) (defun tramp-sudoedit-handle-set-file-acl (filename acl-string) "Like `set-file-acl' for Tramp files." @@ -710,6 +717,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil (let* ((uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) @@ -718,13 +726,14 @@ ID-FORMAT valid values are `string' and `integer'." (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer))) (flag (and (eq mustbenew 'excl) 'nofollow)) - (modes (tramp-default-file-modes filename flag))) + (modes (tramp-default-file-modes filename flag)) + (attributes (file-extended-attributes filename))) (prog1 (tramp-handle-write-region start end filename append visit lockname mustbenew) - ;; Set the ownership and modes. This is not performed in - ;; `tramp-handle-write-region'. + ;; Set the ownership, modes and extended attributes. This is + ;; not performed in `tramp-handle-write-region'. (unless (and (= (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) uid) @@ -732,7 +741,12 @@ ID-FORMAT valid values are `string' and `integer'." (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) - (tramp-compat-set-file-modes filename modes flag))))) + (tramp-compat-set-file-modes filename modes flag) + ;; We ignore possible errors, because ACL strings could be + ;; incompatible. + (when attributes + (ignore-errors + (set-file-extended-attributes filename attributes))))))) ;; Internal functions. @@ -773,6 +787,9 @@ 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) @@ -788,24 +805,21 @@ in case of error, t otherwise." (tramp-sudoedit-maybe-open-connection vec) (with-current-buffer (tramp-get-connection-buffer vec) (erase-buffer) - (let* ((login (tramp-get-method-parameter vec 'tramp-sudo-login)) - (host (or (tramp-file-name-host vec) "")) - (user (or (tramp-file-name-user vec) "")) - (spec (format-spec-make ?h host ?u user)) - (args (append - (tramp-compat-flatten-tree - (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) x)) - login)) - (tramp-compat-flatten-tree (delq nil args)))) - (delete-exited-processes t) + (let* ((delete-exited-processes t) (process-connection-type tramp-process-connection-type) (p (apply #'start-process - (tramp-get-connection-name vec) (current-buffer) args)) + (tramp-get-connection-name vec) (current-buffer) + (append + (tramp-expand-args + vec 'tramp-sudo-login + ?h (or (tramp-file-name-host vec) "") + ?u (or (tramp-file-name-user vec) "")) + (tramp-compat-flatten-tree args)))) ;; We suppress the messages `Waiting for prompts from remote shell'. (tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose)) + ;; The password shall be cached also in case of "emacs -Q". + ;; See `tramp-process-actions'. + (tramp-cache-read-persistent-data t) ;; We do not want to save the password. auth-source-save-behavior) (tramp-message vec 6 "%s" (string-join (process-command p) " ")) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 690dd99ae55..83df05c24b7 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -64,6 +64,10 @@ (declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) +;; Reload `tramp-compat' when we reload `tramp-autoloads' of the GNU ELPA package. +;;;###autoload (when (featurep 'tramp-compat) +;;;###autoload (load "tramp-compat" 'noerror 'nomessage)) + ;;; User Customizable Internal Variables: (defgroup tramp nil @@ -105,7 +109,8 @@ Any level x includes messages for all levels 1 .. x-1. The levels are 7 file caching 8 connection properties 9 test commands -10 traces (huge)." +10 traces (huge) +11 call traces (maintainer only)." :type 'integer) (defcustom tramp-debug-to-file nil @@ -248,6 +253,8 @@ pair of the form (KEY VALUE). The following KEYs are defined: - \"%c\" adds additional `tramp-ssh-controlmaster-options' options for the first hop. - \"%n\" expands to \"2>/dev/null\". + - \"%x\" is replaced by the `tramp-scp-strict-file-name-checking' + argument if it is supported. The existence of `tramp-login-args', combined with the absence of `tramp-copy-args', is an indication that the @@ -354,12 +361,13 @@ Notes: All these arguments can be overwritten by connection properties. See Info node `(tramp) Predefined connection information'. -When using `su' or `sudo' the phrase \"open connection to a remote -host\" sounds strange, but it is used nevertheless, for consistency. -No connection is opened to a remote host, but `su' or `sudo' is -started on the local host. You should specify a remote host -`localhost' or the name of the local host. Another host name is -useful only in combination with `tramp-default-proxies-alist'.") +When using `su', `sudo' or `doas' the phrase \"open connection to +a remote host\" sounds strange, but it is used nevertheless, for +consistency. No connection is opened to a remote host, but `su', +`sudo' or `doas' is started on the local host. You should +specify a remote host `localhost' or the name of the local host. +Another host name is useful only in combination with +`tramp-default-proxies-alist'.") (defcustom tramp-default-method ;; An external copy method seems to be preferred, because it performs @@ -386,6 +394,8 @@ Also see `tramp-default-method-alist'." :type 'string) (defcustom tramp-default-method-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Default method to use for specific host/user pairs. This is an alist of items (HOST USER METHOD). The first matching item specifies the method to use for a file name which does not specify a @@ -413,6 +423,8 @@ This variable is regarded as obsolete, and will be removed soon." :type '(choice (const nil) string)) (defcustom tramp-default-user-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item specifies the user to use for a file name which does not specify a @@ -432,6 +444,8 @@ Useful for su and sudo methods mostly." :type 'string) (defcustom tramp-default-host-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Default host to use for specific method/user pairs. This is an alist of items (METHOD USER HOST). The first matching item specifies the host to use for a file name which does not specify a @@ -447,6 +461,8 @@ empty string for the method name." (choice :tag " Host name" string (const nil))))) (defcustom tramp-default-proxies-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Route to be followed for specific host/user pairs. This is an alist of items (HOST USER PROXY). The first matching item specifies the proxy to be passed for a file name located on @@ -479,7 +495,7 @@ interpreted as a regular expression which always matches." ;; either lower case or upper case letters. See ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38079#20>. (defcustom tramp-restricted-shell-hosts-alist - (when (memq system-type '(windows-nt)) + (when (eq system-type 'windows-nt) (list (format "\\`\\(%s\\|%s\\)\\'" (regexp-quote (downcase tramp-system-name)) (regexp-quote (upcase tramp-system-name))))) @@ -549,7 +565,7 @@ usually suffice.") the remote shell.") (defcustom tramp-local-end-of-line - (if (memq system-type '(windows-nt)) "\r\n" "\n") + (if (eq system-type 'windows-nt) "\r\n" "\n") "String used for end of line in local processes." :version "24.1" :type 'string) @@ -570,8 +586,7 @@ Sometimes the prompt is reported to look like \"login as:\"." (defcustom tramp-shell-prompt-pattern ;; Allow a prompt to start right after a ^M since it indeed would be - ;; displayed at the beginning of the line (and Zsh uses it). This - ;; regexp works only for GNU Emacs. + ;; displayed at the beginning of the line (and Zsh uses it). ;; Allow also [] style prompts. They can appear only during ;; connection initialization; Tramp redefines the prompt afterwards. (concat "\\(?:^\\|\r\\)" @@ -652,6 +667,14 @@ The regexp should match at end of buffer. See also `tramp-yesno-prompt-regexp'." :type 'regexp) +(defcustom tramp-terminal-type "dumb" + "Value of TERM environment variable for logging in to remote host. +Because Tramp wants to parse the output of the remote shell, it is easily +confused by ANSI color escape sequences and suchlike. Often, shell init +files conditionalize this setup based on the TERM environment variable." + :group 'tramp + :type 'string) + (defcustom tramp-terminal-prompt-regexp (concat "\\(" "TERM = (.*)" @@ -674,6 +697,23 @@ The regexp should match at end of buffer." :version "27.1" :type 'regexp) +;; A security key requires the user physically to touch the device +;; with their finger. We must tell it to the user. +;; Added in OpenSSH 8.2. I've tested it with yubikey. +(defcustom tramp-security-key-confirm-regexp + "^\r*Confirm user presence for key .*[\r\n]*" + "Regular expression matching security key confirmation message. +The regexp should match at end of buffer." + :version "28.1" + :type 'regexp) + +(defcustom tramp-security-key-confirmed-regexp + "^\r*User presence confirmed[\r\n]*" + "Regular expression matching security key confirmation message. +The regexp should match at end of buffer." + :version "28.1" + :type 'regexp) + (defcustom tramp-operation-not-permitted-regexp (concat "\\(" "preserving times.*" "\\|" "set mode" "\\)" ":\\s-*" (regexp-opt '("Operation not permitted") t)) @@ -1061,7 +1101,13 @@ initial value is overwritten by the car of `tramp-file-name-structure'.") (defconst tramp-completion-file-name-regexp-default (concat - "\\`/\\(" + "\\`" + ;; `file-name-completion' uses absolute paths for matching. This + ;; means that on W32 systems, something like "/ssh:host:~/path" + ;; becomes "c:/ssh:host:~/path". See also `tramp-drop-volume-letter'. + (when (eq system-type 'windows-nt) + "\\(?:[[:alpha:]]:\\)?") + "/\\(" ;; Optional multi hop. "\\([^/|:]+:[^/|:]*|\\)*" ;; Last hop. @@ -1080,7 +1126,13 @@ On W32 systems, the volume letter must be ignored.") (defconst tramp-completion-file-name-regexp-simplified (concat - "\\`/\\(" + "\\`" + ;; Allow the volume letter at the beginning of the path. See the + ;; comment in `tramp-completion-file-name-regexp-default' for more + ;; details. + (when (eq system-type 'windows-nt) + "\\(?:[[:alpha:]]:\\)?") + "/\\(" ;; Optional multi hop. "\\([^/|:]*|\\)*" ;; Last hop. @@ -1096,7 +1148,14 @@ See `tramp-file-name-structure' for more explanations. On W32 systems, the volume letter must be ignored.") (defconst tramp-completion-file-name-regexp-separate - "\\`/\\(\\[[^]]*\\)?\\'" + (concat + "\\`" + ;; Allow the volume letter at the beginning of the path. See the + ;; comment in `tramp-completion-file-name-regexp-default' for more + ;; details. + (when (eq system-type 'windows-nt) + "\\(?:[[:alpha:]]:\\)?") + "/\\(\\[[^]]*\\)?\\'") "Value for `tramp-completion-file-name-regexp' for separate remoting. See `tramp-file-name-structure' for more explanations.") @@ -1205,14 +1264,14 @@ this variable to be set as well." :type '(choice (const nil) integer)) ;; Logging in to a remote host normally requires obtaining a pty. But -;; Emacs on macOS has process-connection-type set to nil by default, +;; Emacs on macOS has `process-connection-type' set to nil by default, ;; so on those systems Tramp doesn't obtain a pty. Here, we allow ;; for an override of the system default. (defcustom tramp-process-connection-type t "Overrides `process-connection-type' for connections from Tramp. Tramp binds `process-connection-type' to the value given here before opening a connection to a remote host." - :type '(choice (const nil) (const t) (const pty))) + :type '(choice (const nil) (const t) (const pipe) (const pty))) (defcustom tramp-connection-timeout 60 "Defines the max time to wait for establishing a connection (in seconds). @@ -1235,6 +1294,67 @@ let-bind this variable." :version "24.4" :type '(choice (const nil) integer)) +;; "getconf PATH" yields: +;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin +;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin +;; GNU/Linux (Debian, Suse, RHEL): /bin:/usr/bin +;; FreeBSD, DragonFly: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! +;; FreeBSD 12.1, Darwin: /usr/bin:/bin:/usr/sbin:/sbin +;; IRIX64: /usr/bin +;; QNAP QTS: --- +;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin +(defcustom tramp-remote-path + '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" + "/usr/local/bin" "/usr/local/sbin" "/local/bin" "/local/freeware/bin" + "/local/gnu/bin" "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin" + "/opt/bin" "/opt/sbin" "/opt/local/bin") + "List of directories to search for executables on remote host. +For every remote host, this variable will be set buffer local, +keeping the list of existing directories on that host. + +You can use \"~\" in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with \"~\" will be ignored. + +`Default Directories' represent the list of directories given by +the command \"getconf PATH\". It is recommended to use this +entry on head of this list, because these are the default +directories for POSIX compatible commands. On remote hosts which +do not offer the getconf command (like cygwin), the value +\"/bin:/usr/bin\" is used instead. This entry is represented in +the list by the special value `tramp-default-remote-path'. + +`Private Directories' are the settings of the $PATH environment, +as given in your `~/.profile'. This entry is represented in +the list by the special value `tramp-own-remote-path'." + :group 'tramp + :type '(repeat (choice + (const :tag "Default Directories" tramp-default-remote-path) + (const :tag "Private Directories" tramp-own-remote-path) + (string :tag "Directory")))) + +(defcustom tramp-remote-process-environment + '("ENV=''" "TMOUT=0" "LC_CTYPE=''" + "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat" + "autocorrect=" "correct=") + "List of environment variables to be set on the remote host. + +Each element should be a string of the form ENVVARNAME=VALUE. An +entry ENVVARNAME= disables the corresponding environment variable, +which might have been set in the init files like ~/.profile. + +Special handling is applied to some environment variables, +which should not be set here: + +The PATH environment variable should be set via `tramp-remote-path'. + +The TERM environment variable should be set via `tramp-terminal-type'. + +The INSIDE_EMACS environment variable will automatically be set +based on the Tramp and Emacs versions, and should not be set here." + :group 'tramp + :version "26.1" + :type '(repeat string)) + (defcustom tramp-completion-reread-directory-timeout 10 "Defines seconds since last remote command before rereading a directory. A remote directory might have changed its contents. In order to @@ -1287,6 +1407,14 @@ calling HANDLER.") (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) +(put #'tramp-file-name-method 'tramp-suppress-trace t) +(put #'tramp-file-name-user 'tramp-suppress-trace t) +(put #'tramp-file-name-domain 'tramp-suppress-trace t) +(put #'tramp-file-name-host 'tramp-suppress-trace t) +(put #'tramp-file-name-port 'tramp-suppress-trace t) +(put #'tramp-file-name-localname 'tramp-suppress-trace t) +(put #'tramp-file-name-hop 'tramp-suppress-trace t) + (defun tramp-file-name-user-domain (vec) "Return user and domain components of VEC." (when (or (tramp-file-name-user vec) (tramp-file-name-domain vec)) @@ -1295,6 +1423,8 @@ calling HANDLER.") tramp-prefix-domain-format) (tramp-file-name-domain vec)))) +(put #'tramp-file-name-user-domain 'tramp-suppress-trace t) + (defun tramp-file-name-host-port (vec) "Return host and port components of VEC." (when (or (tramp-file-name-host vec) (tramp-file-name-port vec)) @@ -1303,12 +1433,16 @@ calling HANDLER.") tramp-prefix-port-format) (tramp-file-name-port vec)))) +(put #'tramp-file-name-host-port 'tramp-suppress-trace t) + (defun tramp-file-name-port-or-default (vec) "Return port component of VEC. If nil, return `tramp-default-port'." (or (tramp-file-name-port vec) (tramp-get-method-parameter vec 'tramp-default-port))) +(put #'tramp-file-name-port-or-default 'tramp-suppress-trace t) + ;; Comparison of file names is performed by `tramp-equal-remote'. (defun tramp-file-name-equal-p (vec1 vec2) "Check, whether VEC1 and VEC2 denote the same `tramp-file-name'." @@ -1355,6 +1489,8 @@ entry does not exist, return nil." (string-match-p tramp-file-name-regexp name) t)) +(put #'tramp-tramp-file-p 'tramp-suppress-trace t) + ;; This function bypasses the file name handler approach. It is NOT ;; recommended to use it in any package if not absolutely necessary. ;; However, it is more performant than `file-local-name', and might be @@ -1403,6 +1539,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in result (propertize result 'tramp-default t)))) +(put #'tramp-find-method 'tramp-suppress-trace t) + (defun tramp-find-user (method user host) "Return the right user string to use depending on METHOD and HOST. This is USER, if non-nil. Otherwise, do a lookup in @@ -1424,6 +1562,8 @@ This is USER, if non-nil. Otherwise, do a lookup in result (propertize result 'tramp-default t)))) +(put #'tramp-find-user 'tramp-suppress-trace t) + (defun tramp-find-host (method user host) "Return the right host string to use depending on METHOD and USER. This is HOST, if non-nil. Otherwise, do a lookup in @@ -1445,6 +1585,8 @@ This is HOST, if non-nil. Otherwise, do a lookup in result (propertize result 'tramp-default t)))) +(put #'tramp-find-host 'tramp-suppress-trace t) + (defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure of NAME, a remote file name. The structure consists of method, user, domain, host, port, @@ -1483,7 +1625,8 @@ default values are used." (setq v (tramp-dissect-hop-name hop) hop (and hop (tramp-make-tramp-hop-name v)))) (let ((tramp-default-host - (or (and v (not (string-match-p "%h" (tramp-file-name-host v))) + (or (and v (not (tramp-compat-string-search + "%h" (tramp-file-name-host v))) (tramp-file-name-host v)) tramp-default-host))) (setq method (tramp-find-method method user host) @@ -1509,6 +1652,8 @@ default values are used." (tramp-user-error v "Method `%s' is not supported for multi-hops." method))))))) +(put #'tramp-dissect-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." @@ -1526,6 +1671,8 @@ See `tramp-dissect-file-name' for details." ;; Return result. v)) +(put #'tramp-dissect-hop-name 'tramp-suppress-trace t) + (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." (let ((method (tramp-file-name-method vec)) @@ -1535,6 +1682,8 @@ See `tramp-dissect-file-name' for details." (format "*tramp/%s %s@%s*" method user-domain host-port) (format "*tramp/%s %s*" method host-port)))) +(put #'tramp-buffer-name 'tramp-suppress-trace t) + (defun tramp-make-tramp-file-name (&rest args) "Construct a Tramp file name from ARGS. @@ -1702,6 +1851,8 @@ version, the function does nothing." (format "*debug tramp/%s %s@%s*" method user-domain host-port) (format "*debug tramp/%s %s*" method host-port)))) +(put #'tramp-debug-buffer-name 'tramp-suppress-trace t) + (defconst tramp-debug-outline-regexp (concat "[[:digit:]]+:[[:digit:]]+:[[:digit:]]+\\.[[:digit:]]+ " ;; Timestamp. @@ -1710,6 +1861,10 @@ version, the function does nothing." "Used for highlighting Tramp debug buffers in `outline-mode'.") (defconst tramp-debug-font-lock-keywords + ;; FIXME: Make it a function instead of an ELisp expression, so you + ;; can evaluate it with `funcall' rather than `eval'! + ;; Also, in `font-lock-defaults' you can specify a function name for + ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords! '(list (concat "^\\(?:" tramp-debug-outline-regexp "\\).+") '(1 font-lock-warning-face t t) @@ -1723,10 +1878,13 @@ Point must be at the beginning of a header line. The outline level is equal to the verbosity of the Tramp message." (1+ (string-to-number (match-string 2)))) +(put #'tramp-debug-outline-level 'tramp-suppress-trace t) + (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 @@ -1738,19 +1896,35 @@ The outline level is equal to the verbosity of the Tramp message." (outline-mode)) (setq-local outline-level 'tramp-debug-outline-level) (setq-local font-lock-keywords - `(t (eval ,tramp-debug-font-lock-keywords) - ,(eval tramp-debug-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)) (current-buffer))) +(put #'tramp-get-debug-buffer 'tramp-suppress-trace t) + (defun tramp-get-debug-file-name (vec) - "Get the debug buffer for VEC." + "Get the debug file name for VEC." (expand-file-name (tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec)) (tramp-compat-temporary-file-directory))) -(defsubst tramp-debug-message (vec fmt-string &rest arguments) +(put #'tramp-get-debug-file-name 'tramp-suppress-trace t) + +(defun tramp-trace-buffer-name (vec) + "A name for the trace buffer for VEC." + (tramp-compat-string-replace "debug" "trace" (tramp-debug-buffer-name vec))) + +(put #'tramp-trace-buffer-name 'tramp-suppress-trace t) + +(defvar tramp-trace-functions nil + "A list of non-Tramp functions to be traced with tramp-verbose > 10.") + +(defun tramp-debug-message (vec fmt-string &rest arguments) "Append message to debug buffer of VEC. Message is formatted with FMT-STRING as control string and the remaining ARGUMENTS to actually emit the message (if applicable)." @@ -1760,11 +1934,11 @@ ARGUMENTS to actually emit the message (if applicable)." (with-current-buffer (tramp-get-debug-buffer vec) (goto-char (point-max)) (let ((point (point))) - ;; Headline. (when (bobp) + ;; Headline. (insert (format - ";; Emacs: %s Tramp: %s -*- mode: outline; -*-" + ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-" emacs-version tramp-version)) (when (>= tramp-verbose 10) (let ((tramp-verbose 0)) @@ -1774,6 +1948,15 @@ ARGUMENTS to actually emit the message (if applicable)." (locate-library "tramp") (or tramp-repository-branch "") (or tramp-repository-version ""))))) + ;; Traces. + (when (>= tramp-verbose 11) + (dolist + (elt + (append + (mapcar #'intern (all-completions "tramp-" obarray 'functionp)) + tramp-trace-functions)) + (unless (get elt 'tramp-suppress-trace) + (trace-function-background elt)))) ;; Delete debug file. (when (and tramp-debug-to-file (tramp-get-debug-file-name vec)) (ignore-errors (delete-file (tramp-get-debug-file-name vec))))) @@ -1791,7 +1974,7 @@ ARGUMENTS to actually emit the message (if applicable)." (if (not btf) (setq fn "") (and (symbolp btf) (setq fn (symbol-name btf)) - (or (not (string-match-p "^tramp" fn)) + (or (not (string-prefix-p "tramp" fn)) (get btf 'tramp-suppress-trace)) (setq fn nil)) (setq btn (1+ btn)))) @@ -1882,7 +2065,7 @@ function is meant for debugging purposes." (put #'tramp-backtrace 'tramp-suppress-trace t) -(defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) +(defun tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to @@ -2043,7 +2226,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) (message (aref parameters 3))) - (when (string-match-p message (or (current-message) "")) + (when (tramp-compat-string-search message (or (current-message) "")) (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) @@ -2083,14 +2266,15 @@ without a visible progress reporter." FILE must be a local file name on a connection identified via VEC." (declare (indent 3) (debug t)) `(if (file-name-absolute-p ,file) - (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) - (when (eq value 'undef) - ;; We cannot pass @body as parameter to - ;; `tramp-set-file-property' because it mangles our - ;; debug messages. - (setq value (progn ,@body)) - (tramp-set-file-property ,vec ,file ,property value)) - value) + (let ((value (tramp-get-file-property + ,vec ,file ,property tramp-cache-undefined))) + (when (eq value tramp-cache-undefined) + ;; We cannot pass @body as parameter to + ;; `tramp-set-file-property' because it mangles our debug + ;; messages. + (setq value (progn ,@body)) + (tramp-set-file-property ,vec ,file ,property value)) + value) ,@body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) @@ -2098,14 +2282,15 @@ FILE must be a local file name on a connection identified via VEC." (defmacro with-tramp-connection-property (key property &rest body) "Check in Tramp for property PROPERTY, otherwise execute BODY and set." (declare (indent 2) (debug t)) - `(let ((value (tramp-get-connection-property ,key ,property 'undef))) - (when (eq value 'undef) - ;; We cannot pass ,@body as parameter to - ;; `tramp-set-connection-property' because it mangles our debug - ;; messages. - (setq value (progn ,@body)) - (tramp-set-connection-property ,key ,property value)) - value)) + `(let ((value (tramp-get-connection-property + ,key ,property tramp-cache-undefined))) + (when (eq value tramp-cache-undefined) + ;; We cannot pass ,@body as parameter to + ;; `tramp-set-connection-property' because it mangles our debug + ;; messages. + (setq value (progn ,@body)) + (tramp-set-connection-property ,key ,property value)) + value)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) @@ -2155,7 +2340,7 @@ Example: (unless (and (functionp (nth 0 (car v))) (cond ;; Windows registry. - ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) + ((string-prefix-p "HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process @@ -2287,6 +2472,8 @@ Must be handled by the callers." file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info + ;; Emacs 28+ only. + file-locked-p lock-file make-lock-file-name unlock-file ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) @@ -2459,8 +2646,12 @@ Falls back to normal file name handler if no Tramp file name handler exists." (tramp-unload-file-name-handlers) (when tramp-mode ;; We cannot use `tramp-compat-temporary-file-directory' here due - ;; to autoload. + ;; to autoload. When installing Tramp's GNU ELPA package, there + ;; might be an older, incompatible version active. We try to + ;; overload this. (let ((default-directory temporary-file-directory)) + (when (bound-and-true-p tramp-archive-autoload) + (load "tramp-archive" 'noerror 'nomessage)) (load "tramp" 'noerror 'nomessage))) (apply operation args))) @@ -2472,7 +2663,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." "Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp - 'tramp-autoload-file-name-handler)) + #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t))) ;;;###autoload (tramp-register-autoload-file-name-handlers) @@ -2591,6 +2782,14 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;; File name handler functions for completion mode: +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(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))) + (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 @@ -2676,7 +2875,7 @@ not in completion mode." result1 (ignore-errors (tramp-run-real-handler - 'file-name-all-completions (list filename directory)))))) + #'file-name-all-completions (list filename directory)))))) ;; Method, host name and user name completion for a file. (defun tramp-completion-handle-file-name-completion @@ -2800,8 +2999,7 @@ remote host and localname (filename on remote host)." "Return all method completions for PARTIAL-METHOD." (mapcar (lambda (method) - (and method - (string-match-p (concat "^" (regexp-quote partial-method)) method) + (and method (string-prefix-p partial-method method) (tramp-completion-make-tramp-file-name method nil nil nil))) (mapcar #'car tramp-methods))) @@ -2813,8 +3011,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (cond ((and partial-user partial-host) - (if (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host) + (if (and host (string-prefix-p partial-host host) (string-equal partial-user (or user partial-user))) (setq user partial-user) (setq user nil @@ -2822,16 +3019,12 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (partial-user (setq host nil) - (unless - (and user - (string-match-p (concat "^" (regexp-quote partial-user)) user)) + (unless (and user (string-prefix-p partial-user user)) (setq user nil))) (partial-host (setq user nil) - (unless - (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host)) + (unless (and host (string-prefix-p partial-host host)) (setq host nil))) (t (setq user nil @@ -3025,7 +3218,7 @@ User may be nil." (defun tramp-parse-putty (registry-or-dirname) "Return a list of (user host) tuples allowed to access. User is always nil." - (if (memq system-type '(windows-nt)) + (if (eq system-type 'windows-nt) (with-tramp-connection-property nil "parse-putty" (with-temp-buffer (when (zerop (tramp-call-process @@ -3097,7 +3290,7 @@ User is always nil." (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory + #'copy-directory (list directory newname keep-date parents copy-contents))) (defun tramp-handle-directory-file-name (directory) @@ -3155,7 +3348,7 @@ User is always nil." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name nil)) @@ -3163,6 +3356,9 @@ User is always nil." (with-parsed-tramp-file-name name nil (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) ;; Do normal `expand-file-name' (this does "/./" and "/../"). ;; `default-directory' is bound, because on Windows there would ;; be problems with UNC shares or Cygwin mounts. @@ -3444,6 +3640,11 @@ User is always nil." (and (file-directory-p (file-name-directory filename)) (file-writable-p (file-name-directory filename))))))) +(defcustom tramp-allow-unsafe-temporary-files nil + "Whether root-owned auto-save, backup or lock files can be written to \"/tmp\"." + :version "28.1" + :type 'boolean) + (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -3459,8 +3660,26 @@ User is always nil." (tramp-make-tramp-file-name v (cdr x)) (cdr x)))) tramp-backup-directory-alist) - backup-directory-alist))) - (tramp-run-real-handler #'find-backup-file-name (list filename))))) + backup-directory-alist)) + result) + (prog1 ;; Run plain `find-backup-file-name'. + (setq result + (tramp-run-real-handler + #'find-backup-file-name (list filename))) + ;; Protect against security hole. + (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 + (file-attributes filename 'integer)) + tramp-unknown-id-integer)) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Backup file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe backup file name")))))) (defun tramp-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -3483,7 +3702,7 @@ User is always nil." (list filename switches wildcard full-directory-p)) ;; `ls-lisp' always returns full listings. We must remove ;; superfluous parts. - (unless (string-match-p "l" switches) + (unless (tramp-compat-string-search "l" switches) (save-excursion (goto-char (point-min)) (while (setq start @@ -3597,21 +3816,114 @@ User is always nil." (signal (car err) (cdr err)))))) ;; Save exit. - (progn - (when visit - (setq buffer-file-name filename - buffer-read-only (not (file-writable-p filename))) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - (when (and (stringp local-copy) - (or remote-copy (null tramp-temp-buffer-file-name))) - (delete-file local-copy)) - (when (stringp remote-copy) - (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop))))) + (when visit + (setq buffer-file-name filename + buffer-read-only (not (file-writable-p filename))) + (set-visited-file-modtime) + (set-buffer-modified-p nil)) + (when (and (stringp local-copy) + (or remote-copy (null tramp-temp-buffer-file-name))) + (delete-file local-copy)) + (when (stringp remote-copy) + (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))) ;; Result. - (list (expand-file-name filename) - (cadr result))))) + (cons (expand-file-name filename) (cdr result))))) + +(defun tramp-get-lock-file (file) + "Read lockfile info of FILE. +Return nil when there is no lockfile." + (when-let ((lockname (tramp-compat-make-lock-file-name file))) + (or (file-symlink-p lockname) + (and (file-readable-p lockname) + (with-temp-buffer + (insert-file-contents-literally lockname) + (buffer-string)))))) + +(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)))))) + +(defconst tramp-lock-file-info-regexp + ;; USER@HOST.PID[:BOOT_TIME] + "\\`\\(.+\\)@\\(.+\\)\\.\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\'" + "The format of a lock file.") + +(defun tramp-handle-file-locked-p (file) + "Like `file-locked-p' for Tramp files." + (when-let ((info (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-info-regexp info))) + (or (and (string-equal (match-string 1 info) (user-login-name)) + (string-equal (match-string 2 info) (system-name)) + (string-equal (match-string 3 info) (tramp-get-lock-pid file))) + (match-string 1 info)))) + +(defun tramp-handle-lock-file (file) + "Like `lock-file' for Tramp files." + ;; See if this file is visited and has changed on disk since it + ;; was visited. + (catch 'dont-lock + (unless (eq (file-locked-p file) t) ;; Locked by me. + (when-let ((info (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-info-regexp info))) + (unless (ask-user-about-lock + file (format + "%s@%s (pid %s)" (match-string 1 info) + (match-string 2 info) (match-string 3 info))) + (throw 'dont-lock nil))) + + (when-let ((lockname (tramp-compat-make-lock-file-name file)) + ;; USER@HOST.PID[:BOOT_TIME] + (info + (format + "%s@%s.%s" (user-login-name) (system-name) + (tramp-get-lock-pid file)))) + + ;; Protect against security hole. + (with-parsed-tramp-file-name file nil + (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 + (file-attributes file 'integer)) + tramp-unknown-id-integer)) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Lock file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe lock file name"))) + + ;; Do the lock. + (let (create-lockfiles signal-hook-function) + (condition-case nil + (make-symbolic-link info lockname 'ok-if-already-exists) + (error + (with-file-modes #o0644 + (write-region info nil lockname))))))))) + +(defun tramp-handle-make-lock-file-name (file) + "Like `make-lock-file-name' for Tramp files." + (and create-lockfiles + ;; This variable has been introduced with Emacs 28.1. + (not (bound-and-true-p remote-file-name-inhibit-locks)) + (tramp-run-real-handler 'make-lock-file-name (list file)))) + +(defun tramp-handle-unlock-file (file) + "Like `unlock-file' for Tramp files." + (when-let ((lockname (tramp-compat-make-lock-file-name file))) + (condition-case err + (delete-file lockname) + ;; `userlock--handle-unlock-error' exists since Emacs 28.1. + (error (tramp-compat-funcall 'userlock--handle-unlock-error err))))) (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." @@ -3680,15 +3992,15 @@ User is always nil." (setq choices tramp-default-proxies-alist) (while choices (setq item (pop choices) - proxy (eval (nth 2 item))) + proxy (eval (nth 2 item) t)) (when (and ;; Host. (string-match-p - (or (eval (nth 0 item)) "") + (or (eval (nth 0 item) t) "") (or (tramp-file-name-host-port (car target-alist)) "")) ;; User. (string-match-p - (or (eval (nth 1 item)) "") + (or (eval (nth 1 item) t) "") (or (tramp-file-name-user-domain (car target-alist)) ""))) (if (null proxy) ;; No more hops needed. @@ -3739,6 +4051,22 @@ User is always nil." ;; Result. target-alist)) +(defun tramp-expand-args (vec parameter &rest spec-list) + "Expand login arguments as given by PARAMETER in `tramp-methods'. +PARAMETER is a symbol like `tramp-login-args', denoting a list of +list of strings from `tramp-methods', containing %-sequences for +substitution. SPEC-LIST is a list of char/value pairs used for +`format-spec-make'." + (let ((args (tramp-get-method-parameter vec parameter)) + (spec (apply 'format-spec-make spec-list))) + ;; Expand format spec. + (tramp-compat-flatten-tree + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) x)) + args)))) + (defun tramp-direct-async-process-p (&rest args) "Whether direct async `make-process' can be called." (let ((v (tramp-dissect-file-name default-directory)) @@ -3756,8 +4084,7 @@ User is always nil." (or (not (stringp stderr)) (not (tramp-tramp-file-p stderr)))))) (defun tramp-handle-make-process (&rest args) - "An alternative `make-process' implementation for Tramp files. -It does not support `:stderr'." + "An alternative `make-process' implementation for Tramp files." (when args (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((default-directory (tramp-compat-temporary-file-directory)) @@ -3766,7 +4093,10 @@ It does not support `:stderr'." (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (if (plist-member args :connection-type) + (plist-get args :connection-type) + tramp-process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) @@ -3782,7 +4112,7 @@ It does not support `:stderr'." (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (unless (memq connection-type '(nil pipe t pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) (unless (or (null filter) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) @@ -3798,23 +4128,20 @@ It does not support `:stderr'." (generate-new-buffer tramp-temp-buffer-name))) (env (mapcar (lambda (elt) - (when (string-match-p "=" elt) elt)) + (when (tramp-compat-string-search "=" elt) elt)) tramp-remote-process-environment)) ;; We use as environment the difference to toplevel ;; `process-environment'. (env (dolist (elt process-environment env) (when (and - (string-match-p "=" elt) + (tramp-compat-string-search "=" elt) (not (member elt (default-toplevel-value 'process-environment)))) (setq env (cons elt env))))) (env (setenv-internal - env "INSIDE_EMACS" - (concat (or (getenv "INSIDE_EMACS") emacs-version) - ",tramp:" tramp-version) - 'keep)) + env "INSIDE_EMACS" (tramp-inside-emacs) 'keep)) (env (mapcar #'tramp-shell-quote-argument (delq nil env))) ;; Quote command. (command (mapconcat #'tramp-shell-quote-argument command " ")) @@ -3823,14 +4150,11 @@ It does not support `:stderr'." (append `("cd" ,localname "&&" "(" "env") env `(,command ")")))) ;; Check for `tramp-sh-file-name-handler', because something - ;; is different between tramp-adb.el and tramp-sh.el. + ;; is different between tramp-sh.el, and tramp-adb.el or + ;; tramp-sshfs.el. (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v)) (login-program (tramp-get-method-parameter v 'tramp-login-program)) - (login-args - (tramp-get-method-parameter v 'tramp-login-args)) - (async-args - (tramp-get-method-parameter v 'tramp-async-args)) ;; We don't create the temporary file. In fact, it ;; is just a prefix for the ControlPath option of ;; ssh; the real temporary file has another name, and @@ -3848,29 +4172,23 @@ It does not support `:stderr'." (when sh-file-name-handler-p (tramp-compat-funcall 'tramp-ssh-controlmaster-options v))) - spec p) + login-args p) - ;; Replace `login-args' place holders. + ;; Replace `login-args' place holders. Split + ;; ControlMaster options. (setq - spec (format-spec-make ?t tmpfile) - options (format-spec (or options "") spec) - spec (format-spec-make - ?h (or host "") ?u (or user "") ?p (or port "") - ?c options ?l "") - ;; Add arguments for asynchronous processes. - login-args (append async-args login-args) - ;; Expand format spec. - login-args - (tramp-compat-flatten-tree - (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) x)) - login-args)) - ;; Split ControlMaster options. login-args - (tramp-compat-flatten-tree - (mapcar (lambda (x) (split-string x " ")) login-args)) + (append + (tramp-compat-flatten-tree + (tramp-get-method-parameter v 'tramp-async-args)) + (tramp-compat-flatten-tree + (mapcar + (lambda (x) (split-string x " ")) + (tramp-expand-args + v 'tramp-login-args + ?h (or host "") ?u (or user "") ?p (or port "") + ?c (format-spec (or options "") (format-spec-make ?t tmpfile)) + ?l "")))) p (make-process :name name :buffer buffer :command (append `(,login-program) login-args command) @@ -4151,7 +4469,8 @@ of." (defun tramp-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -4160,7 +4479,8 @@ of." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename)) + (let ((file-locked (eq (file-locked-p lockname) t)) + (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 @@ -4169,6 +4489,15 @@ of." (gid (or (tramp-compat-file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not file-locked)) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -4180,8 +4509,8 @@ of." ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (tramp-run-real-handler - #'write-region (list start end tmpfile append 'no-message lockname)) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (condition-case nil (rename-file tmpfile filename 'ok-if-already-exists) (error @@ -4199,13 +4528,18 @@ of." (current-time)))) ;; Set the ownership. - (tramp-set-file-uid-gid filename uid gid)) + (tramp-set-file-uid-gid filename uid gid) - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))) + ;; Unlock file. + (when file-locked + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) ;; This is used in tramp-sh.el and tramp-sudoedit.el. (defconst tramp-stat-marker "/////" @@ -4261,6 +4595,9 @@ of." ;; prompts from the remote host. See the variable ;; `tramp-actions-before-shell' for usage of these functions. +(defvar tramp-process-action-regexp nil + "The regexp used to invoke an action in `tramp-process-one-action'.") + (defun tramp-action-login (_proc vec) "Send the login name." (let ((user (or (tramp-file-name-user vec) @@ -4286,7 +4623,7 @@ of." (unless (tramp-get-connection-property vec "first-password-request" nil) (tramp-clear-passwd vec)) (goto-char (point-min)) - (tramp-check-for-regexp proc tramp-password-prompt-regexp) + (tramp-check-for-regexp proc tramp-process-action-regexp) (tramp-message vec 3 "Sending %s" (match-string 1)) ;; We don't call `tramp-send-string' in order to hide the ;; password from the debug buffer and the traces. @@ -4351,6 +4688,24 @@ The terminal type can be configured with `tramp-terminal-type'." (tramp-send-string vec tramp-local-end-of-line) t) +(defun tramp-action-show-and-confirm-message (proc vec) + "Show the user a message for confirmation. +Wait, until the connection buffer changes." + (with-current-buffer (process-buffer proc) + (let ((stimers (with-timeout-suspend))) + (tramp-message vec 6 "\n%s" (buffer-string)) + (goto-char (point-min)) + (tramp-check-for-regexp proc tramp-process-action-regexp) + (with-temp-message (replace-regexp-in-string "[\r\n]" "" (match-string 0)) + (redisplay 'force) + ;; Hide message in buffer. + (narrow-to-region (point-max) (point-max)) + ;; Wait for new output. + (tramp-wait-for-regexp proc 30 tramp-security-key-confirmed-regexp)) + ;; Reenable the timers. + (with-timeout-unsuspend stimers))) + t) + (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." (unless (process-live-p proc) @@ -4388,6 +4743,7 @@ The terminal type can be configured with `tramp-terminal-type'." "Wait for output from the shell and perform one action. See `tramp-process-actions' for the format of ACTIONS." (let ((case-fold-search t) + tramp-process-action-regexp found todo item pattern action) (while (not found) ;; Reread output once all actions have been performed. @@ -4396,7 +4752,8 @@ See `tramp-process-actions' for the format of ACTIONS." (setq todo actions) (while todo (setq item (pop todo) - pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item))) + tramp-process-action-regexp (symbol-value (nth 0 item)) + pattern (format "\\(%s\\)\\'" tramp-process-action-regexp) action (nth 1 item)) (tramp-message vec 5 "Looking for regexp \"%s\" from remote shell" pattern) @@ -4870,7 +5227,7 @@ VEC is used for tracing." (let ((candidates '("en_US.utf8" "C.utf8" "en_US.UTF-8")) locale) (with-temp-buffer - (unless (or (memq system-type '(windows-nt)) + (unless (or (eq system-type 'windows-nt) (not (zerop (tramp-call-process nil "locale" nil t nil "-a")))) (while candidates @@ -4961,7 +5318,7 @@ ID-FORMAT valid values are `string' and `integer'." (or (when-let ((handler (find-file-name-handler - (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (tramp-make-tramp-file-name vec) 'tramp-get-remote-gid))) (funcall handler #'tramp-get-remote-gid vec id-format)) ;; Ensure there is a valid result. (and (equal id-format 'integer) tramp-unknown-id-integer) @@ -5041,37 +5398,54 @@ Return the local name of the temporary file." "Like `make-auto-save-file-name' for Tramp files. Returns a file name in `tramp-auto-save-directory' for autosaving this file, if that variable is non-nil." - (when (stringp tramp-auto-save-directory) - (setq tramp-auto-save-directory - (expand-file-name tramp-auto-save-directory))) - ;; Create directory. - (unless (or (null tramp-auto-save-directory) - (file-exists-p tramp-auto-save-directory)) - (make-directory tramp-auto-save-directory t)) - - (let ((system-type - (if (and (stringp tramp-auto-save-directory) - (tramp-tramp-file-p tramp-auto-save-directory)) - 'not-windows - system-type)) - (auto-save-file-name-transforms - (if (null tramp-auto-save-directory) - auto-save-file-name-transforms)) - (buffer-file-name - (if (null tramp-auto-save-directory) - buffer-file-name - (expand-file-name - (tramp-subst-strs-in-string - '(("_" . "|") - ("/" . "_a") - (":" . "_b") - ("|" . "__") - ("[" . "_l") - ("]" . "_r")) - (tramp-compat-file-name-unquote (buffer-file-name))) - tramp-auto-save-directory)))) - ;; Run plain `make-auto-save-file-name'. - (tramp-run-real-handler #'make-auto-save-file-name nil))) + (with-parsed-tramp-file-name buffer-file-name nil + (when (stringp tramp-auto-save-directory) + (setq tramp-auto-save-directory + (expand-file-name tramp-auto-save-directory))) + ;; Create directory. + (unless (or (null tramp-auto-save-directory) + (file-exists-p tramp-auto-save-directory)) + (make-directory tramp-auto-save-directory t)) + + (let ((system-type + (if (and (stringp tramp-auto-save-directory) + (tramp-tramp-file-p tramp-auto-save-directory)) + 'not-windows + system-type)) + (auto-save-file-name-transforms + (if (null tramp-auto-save-directory) + auto-save-file-name-transforms)) + (filename buffer-file-name) + (buffer-file-name + (if (null tramp-auto-save-directory) + buffer-file-name + (expand-file-name + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + (tramp-compat-file-name-unquote (buffer-file-name))) + tramp-auto-save-directory))) + result) + (prog1 ;; Run plain `make-auto-save-file-name'. + (setq result (tramp-run-real-handler #'make-auto-save-file-name nil)) + ;; Protect against security hole. + (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 + (file-attributes filename 'integer)) + tramp-unknown-id-integer)) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Autosave file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe autosave file name")))))) (defun tramp-subst-strs-in-string (alist string) "Replace all occurrences of the string FROM with TO in STRING. @@ -5281,6 +5655,8 @@ Invokes `password-read' if available, `read-passwd' else." ;; Reenable the timers. (with-timeout-unsuspend stimers)))) +(put #'tramp-read-passwd 'tramp-suppress-trace t) + (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) @@ -5295,6 +5671,8 @@ Invokes `password-read' if available, `read-passwd' else." :host ,host-port :port ,method)) (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) +(put #'tramp-clear-passwd 'tramp-suppress-trace t) + (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." @@ -5439,11 +5817,6 @@ BODY is the backend specific code." ;; strange when doing zerop, we should kill the process and start ;; again. (Greg Stark) ;; -;; * I was wondering if it would be possible to use tramp even if I'm -;; actually using sshfs. But when I launch a command I would like -;; to get it executed on the remote machine where the files really -;; are. (Andrea Crotti) -;; ;; * Run emerge on two remote files. Bug is described here: ;; <https://www.mail-archive.com/tramp-devel@nongnu.org/msg01041.html>. ;; (Bug#6850) diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index ced3e93fc09..8ad641ee45b 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.1-pre +;; Version: 2.5.2-pre ;; Package-Requires: ((emacs "25.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.1-pre" +(defconst tramp-version "2.5.2-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -76,10 +76,15 @@ ;; Check for Emacs version. (let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.5.1-pre is not fit for %s" + (format "Tramp 2.5.2-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) +(defun tramp-inside-emacs () + "Version string provided by INSIDE_EMACS enmvironment variable." + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version)) + ;; Tramp versions integrated into Emacs. If a user option declares a ;; `:package-version' which doesn't belong to an integrated Tramp ;; version, it must be added here as well (see `tramp-syntax', for diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 1fa625c3245..4baa657c0a5 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -252,7 +252,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (cond ((not expr) "") ((stringp expr) expr) ((vectorp expr) (webjump-builtin expr name)) - ((listp expr) (eval expr)) + ((listp expr) (eval expr t)) ((symbolp expr) (if (fboundp expr) (funcall expr name) |