commit 623db40dd1cd21623c5cecdc0abbf3ce885f92b1 (HEAD, refs/remotes/origin/master) Author: Juanma Barranquero Date: Thu Nov 17 08:45:57 2022 +0100 ; * lisp/*.el: Fix typos in docstrings * lisp/gnus/nnrss.el (nnrss-use-local, nnrss-fetch, nnrss-find-el): * lisp/leim/quail/japanese.el ("japanese"): * lisp/org/ol.el (org-link-search-must-match-exact-headline): * lisp/org/org-faces.el (org-column): * lisp/progmodes/eglot.el (eglot--stay-out-of-p) (eglot-workspace-configuration, eglot--read-execute-code-action): * lisp/vc/vc.el (vc-clone): Fix typos in docstrings. diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 99e7b2a6f3..66cee52865 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -77,7 +77,7 @@ this variable to the list of fields to be ignored.") "List of RSS addresses.") (defvar nnrss-use-local nil - "If non-nil nnrss will read the feeds from local files in nnrss-directory.") + "If non-nil nnrss will read the feeds from local files in `nnrss-directory'.") (defvar nnrss-description-field 'X-Gnus-Description "Field name used for DESCRIPTION. @@ -398,7 +398,7 @@ otherwise return nil." (declare-function libxml-parse-html-region "xml.c" (start end &optional base-url discard-comments)) (defun nnrss-fetch (url &optional local) - "Fetch URL and put it in a the expected Lisp structure." + "Fetch URL and put it in the expected Lisp structure." (mm-with-unibyte-buffer ;;some versions of url.el need this to close the connection quickly (let (cs xmlform htmlform) @@ -800,7 +800,7 @@ It is useful when `(setq nnrss-use-local t)'." node)) (defun nnrss-find-el (tag data &optional found-list) - "Find the all matching elements in the data. + "Find all the matching elements in the data. Careful with this on large documents!" (when (consp data) (dolist (bit data) diff --git a/lisp/leim/quail/japanese.el b/lisp/leim/quail/japanese.el index df080fc0e8..fb8b9e6166 100644 --- a/lisp/leim/quail/japanese.el +++ b/lisp/leim/quail/japanese.el @@ -359,7 +359,7 @@ input method. The input method `japanese-zenkaku' is used to enter full width JISX0208 characters corresponding to typed ASCII characters. -List of the all key sequences for Roman-Kana transliteration is shown +List of all the key sequences for Roman-Kana transliteration is shown at the tail. :: Kana-Kanji conversion :: diff --git a/lisp/org/ol.el b/lisp/org/ol.el index 4ad1f6d345..108f031cde 100644 --- a/lisp/org/ol.el +++ b/lisp/org/ol.el @@ -339,7 +339,7 @@ another window." (defcustom org-link-search-must-match-exact-headline 'query-to-create "Non-nil means internal fuzzy links can only match headlines. -When nil, the a fuzzy link may point to a target or a named +When nil, the fuzzy link may point to a target or a named construct in the document. When set to the special value `query-to-create', offer to create a new headline when none matched. diff --git a/lisp/org/org-faces.el b/lisp/org/org-faces.el index d96898372f..78148a1b6d 100644 --- a/lisp/org/org-faces.el +++ b/lisp/org/org-faces.el @@ -137,7 +137,7 @@ The following faces apply, with this priority. Since column view works by putting overlays with a display property over individual characters in the buffer, the face of the underlining -character (this might for example be the a TODO keyword) might still +character (this might for example be the TODO keyword) might still shine through in some properties. So when your column view looks funny, with \"random\" colors, weight, strike-through, try to explicitly set the properties in the `org-column' face. For example, set diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 12808e80c4..397c8e0937 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -1688,7 +1688,7 @@ For example, to keep your Company customization, add the symbol `company' to this variable.") (defun eglot--stay-out-of-p (symbol) - "Tell if Eglot should stay of of SYMBOL." + "Tell if Eglot should stay out of SYMBOL." (cl-find (symbol-name symbol) eglot-stay-out-of :test (lambda (s thing) (let ((re (if (symbolp thing) (symbol-name thing) thing))) @@ -2298,8 +2298,7 @@ Instead of a plist, an alist ((SECTION . VALUE) ...) can be used instead, but this variant is less reliable and not recommended. This variable should be set as a directory-local variable. See -See info node `(emacs)Directory Variables' for various ways to to -that. +info node `(emacs)Directory Variables' for various ways to do that. Here's an example value that establishes two sections relevant to the Pylsp and Gopls LSP servers: @@ -3213,7 +3212,7 @@ at point. With prefix argument, prompt for ACTION-KIND." actions))) (defun eglot--read-execute-code-action (actions server &optional action-kind) - "Helper for interactive calls to `eglot-code-actions'" + "Helper for interactive calls to `eglot-code-actions'." (let* ((menu-items (or (cl-loop for a in actions collect (cons (plist-get a :title) a)) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 513fbb23fe..fd59c95fc8 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3567,7 +3567,7 @@ to provide the `find-revision' operation instead." (defun vc-clone (remote &optional backend directory rev) "Use BACKEND to clone REMOTE into DIRECTORY. -If successful, returns the a string with the directory of the +If successful, returns the string with the directory of the checkout. If BACKEND is nil, iterate through every known backend in `vc-handled-backends' until one succeeds. If REV is non-nil, it indicates a specific revision to check out." commit 783c335623c5744ec3eda7913aeccfdd8aef4680 Author: Juri Linkov Date: Thu Nov 17 09:38:59 2022 +0200 * lisp/keymap.el (defvar-keymap): Don't use pcase. diff --git a/lisp/keymap.el b/lisp/keymap.el index 953fb233cb..0285c0571f 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -582,11 +582,11 @@ symbol property on its symbol. (let ((keyword (pop defs))) (unless defs (error "Uneven number of keywords")) - (pcase keyword - (:doc (setq doc (pop defs))) - (:repeat (setq repeat (pop defs))) - (_ (push keyword opts) - (push (pop defs) opts))))) + (cond + ((eq keyword :doc) (setq doc (pop defs))) + ((eq keyword :repeat) (setq repeat (pop defs))) + (t (push keyword opts) + (push (pop defs) opts))))) (unless (zerop (% (length defs) 2)) (error "Uneven number of key/definition pairs: %s" defs)) commit ddbc33343cca8c66d841cc16eac77ea626e50e23 Author: Juri Linkov Date: Thu Nov 17 09:25:42 2022 +0200 * lisp/keymap.el (defvar-keymap): Add support for repeat-mode. Put symbol properties 'repeat-map' on commands from the keymap when a ':repeat' keyword is non-nil. Also include/exclude commands according to ':repeat (:enter (commands ...) :exit (commands ...))'. https://lists.gnu.org/archive/html/emacs-devel/2022-11/msg00968.html diff --git a/etc/NEWS b/etc/NEWS index bb2bd52134..47fc9f1e8e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -4075,6 +4075,10 @@ This function allows defining a number of keystrokes with one form. ** New macro 'defvar-keymap'. This macro allows defining keymap variables more conveniently. +** 'repeat-map' can be defined in the macro 'defvar-keymap'. +This is possible either by using ':repeat t' or more advanced +':repeat (:enter (commands ...) :exit (commands ...))'. + --- ** 'kbd' can now be used in built-in, preloaded libraries. It no longer depends on edmacro.el and cl-lib.el. diff --git a/lisp/keymap.el b/lisp/keymap.el index 107565590c..953fb233cb 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -559,22 +559,37 @@ In addition to the keywords accepted by `define-keymap', this macro also accepts a `:doc' keyword, which (if present) is used as the variable documentation string. -\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" +When a `:repeat' keyword is non-nil, put `repeat-map' symbol +properties on commands in this map for `repeat-mode'. The value +could also be a property list with properties `:enter' and `:exit', +for example, :repeat (:enter (commands ...) :exit (commands ...)). +`:enter' is a list of additional commands that only enter `repeat-mode'. +When the list is empty then by default all commands in the map enter +`repeat-mode'. This is applicable when a command has the `repeat-map' +symbol property on its symbol, but doesn't exist in the map. `:exit' +is a list of commands that exit `repeat-mode'. When the list is +empty, no commands in the map exit `repeat-mode'. This is applicable +when a command exists in the map, but doesn't have the `repeat-map' +symbol property on its symbol. + +\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP REPEAT &rest [KEY DEFINITION]...)" (declare (indent 1)) (let ((opts nil) - doc) + doc repeat props) (while (and defs (keywordp (car defs)) (not (eq (car defs) :menu))) (let ((keyword (pop defs))) (unless defs (error "Uneven number of keywords")) - (if (eq keyword :doc) - (setq doc (pop defs)) - (push keyword opts) - (push (pop defs) opts)))) + (pcase keyword + (:doc (setq doc (pop defs))) + (:repeat (setq repeat (pop defs))) + (_ (push keyword opts) + (push (pop defs) opts))))) (unless (zerop (% (length defs) 2)) (error "Uneven number of key/definition pairs: %s" defs)) + (let ((defs defs) key seen-keys) (while defs @@ -585,9 +600,28 @@ as the variable documentation string. (error "Duplicate definition for key '%s' in keymap '%s'" key variable-name) (push key seen-keys))))) - `(defvar ,variable-name - (define-keymap ,@(nreverse opts) ,@defs) - ,@(and doc (list doc))))) + + (when repeat + (let ((defs defs) + def) + (dolist (def (plist-get repeat :enter)) + (push `(put ',def 'repeat-map ',variable-name) props)) + (while defs + (pop defs) + (setq def (pop defs)) + (when (and (memq (car def) '(function quote)) + (not (memq (cadr def) (plist-get repeat :exit)))) + (push `(put ,def 'repeat-map ',variable-name) props))))) + + (let ((defvar-form + `(defvar ,variable-name + (define-keymap ,@(nreverse opts) ,@defs) + ,@(and doc (list doc))))) + (if repeat + `(progn + ,defvar-form + ,@(nreverse props)) + defvar-form)))) (defun make-non-key-event (symbol) "Mark SYMBOL as an event that shouldn't be returned from `where-is'." commit d6c1c76ba4d1dad4c1a66cfabb54399bf0d4b304 Author: Juri Linkov Date: Thu Nov 17 09:20:15 2022 +0200 * lisp/repeat.el (describe-repeat-maps): Improve the output. Print the table of keybindings and a list of commands that enter and exit repeat-map. Use default outline headings. https://lists.gnu.org/archive/html/emacs-devel/2022-11/msg00969.html diff --git a/lisp/repeat.el b/lisp/repeat.el index 0ae68d6024..f2e1c0ad5a 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -588,21 +588,32 @@ Used in `repeat-mode'." (when (and (symbolp (car a)) (symbolp (car b))) (string-lessp (car a) (car b)))))) - (insert (format-message - "`%s' keymap is repeatable by these commands:\n" - (car keymap))) - (dolist (command (sort (cdr keymap) #'string-lessp)) - (let* ((info (help-fns--analyze-function command)) - (map (list (if (symbolp (car keymap)) - (symbol-value (car keymap)) - (car keymap)))) - (desc (mapconcat (lambda (key) - (propertize (key-description key) - 'face 'help-key-binding)) - (or (where-is-internal command map) - (where-is-internal (nth 3 info) map)) - ", "))) - (insert (format-message " `%s' (bound to %s)\n" command desc)))) + (insert (format-message "* `%s'\n" (car keymap))) + + (let* ((map (if (symbolp (car keymap)) + (symbol-value (car keymap)) + (car keymap))) + (repeat-commands (cdr keymap)) + map-commands commands-enter commands-exit) + (map-keymap (lambda (_key cmd) (when (symbolp cmd) (push cmd map-commands))) map) + (setq map-commands (seq-uniq map-commands)) + (setq commands-enter (seq-difference repeat-commands map-commands)) + (setq commands-exit (seq-difference map-commands repeat-commands)) + + (when (or commands-enter commands-exit) (insert "\n")) + (when commands-enter + (insert (concat "Entered with: " + (mapconcat (lambda (cmd) (format-message "`%s'" cmd)) + commands-enter ", ") + "\n"))) + (when commands-exit + (insert (concat "Exited with: " + (mapconcat (lambda (cmd) (format-message "`%s'" cmd)) + commands-exit ", ") + "\n")))) + + (when (symbolp (car keymap)) + (insert (substitute-command-keys (format-message "\\{%s}" (car keymap))))) (insert "\n"))))))) (provide 'repeat) commit fa9777b174ca330e3f5a75b431d8fe37771acdfa Author: Po Lu Date: Thu Nov 17 15:12:16 2022 +0800 Fix treatment of input focus on MPX setups * src/xterm.c (x_ewmh_activate_frame): Use x_set_input_focus instead of XSetInputFocus. (x_set_input_focus): New function. Take into account the ``client pointer'' chosen by Emacs. (x_focus_frame): Use x_set_input_focus instead of XSetInputFocus. diff --git a/src/xterm.c b/src/xterm.c index d6ba532f16..55252d2201 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1134,6 +1134,7 @@ static void x_clean_failable_requests (struct x_display_info *); static struct frame *x_tooltip_window_to_frame (struct x_display_info *, Window, bool *); static Window x_get_window_below (Display *, Window, int, int, int *, int *); +static void x_set_input_focus (struct x_display_info *, Window, Time); #ifndef USE_TOOLKIT_SCROLL_BARS static void x_scroll_bar_redraw (struct scroll_bar *); @@ -27535,11 +27536,10 @@ x_ewmh_activate_frame (struct frame *f) { time = x_get_server_time (f); - x_ignore_errors_for_next_request (dpyinfo); - XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - RevertToParent, time); + x_set_input_focus (FRAME_DISPLAY_INFO (f), + FRAME_OUTER_WINDOW (f), + time); XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f)); - x_stop_ignoring_errors (dpyinfo); return; } @@ -27584,6 +27584,57 @@ x_get_toplevel_parent (struct frame *f) return parent; } +static void +x_set_input_focus (struct x_display_info *dpyinfo, Window window, + Time time) +{ +#ifdef HAVE_XINPUT2 + struct xi_device_t *device; +#endif + + /* Do the equivalent of XSetInputFocus with the specified window and + time, but use the attachment to the device that Emacs has + designated the client pointer on X Input Extension builds. + Asynchronously trap errors around the generated XI_SetFocus or + SetInputFocus request, in case the device has been destroyed or + the window obscured. + + The revert_to will be set to RevertToParent for generated + SetInputFocus requests. */ + +#ifdef HAVE_XINPUT2 + if (dpyinfo->supports_xi2 + && dpyinfo->client_pointer_device != -1) + { + device = xi_device_from_id (dpyinfo, dpyinfo->client_pointer_device); + + /* The device is a master pointer. Use its attachment, which + should be the master keyboard. */ + + if (device) + { + eassert (device->use == XIMasterPointer); + + x_ignore_errors_for_next_request (dpyinfo); + XISetFocus (dpyinfo->display, device->attachment, + /* Note that the input extension + only supports RevertToParent-type + behavior. */ + window, time); + x_stop_ignoring_errors (dpyinfo); + + return; + } + } +#endif + + /* Otherwise, use the pointer device that the X server says is the + client pointer. */ + x_ignore_errors_for_next_request (dpyinfo); + XSetInputFocus (dpyinfo->display, window, RevertToParent, time); + x_stop_ignoring_errors (dpyinfo); +} + /* In certain situations, when the window manager follows a click-to-focus policy, there seems to be no way around calling XSetInputFocus to give another frame the input focus. @@ -27653,20 +27704,15 @@ x_focus_frame (struct frame *f, bool noactivate) A BadMatch error can occur if the window was obscured after the time of the last user interaction without changing the last-focus-change-time. */ - x_ignore_errors_for_next_request (dpyinfo); - XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - RevertToParent, time); - x_stop_ignoring_errors (dpyinfo); + x_set_input_focus (FRAME_DISPLAY_INFO (f), FRAME_OUTER_WINDOW (f), + time); } else - { - x_ignore_errors_for_next_request (dpyinfo); - XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - /* But when no window manager is in use, we - don't care. */ - RevertToParent, CurrentTime); - x_stop_ignoring_errors (dpyinfo); - } + x_set_input_focus (FRAME_DISPLAY_INFO (f), FRAME_OUTER_WINDOW (f), + /* But when no window manager is in use, + respecting the ICCCM doesn't really + matter. */ + CurrentTime); } } commit 43cca14a9e8cef3eda877ca3dc6a6a9c57263a33 Author: Eli Zaretskii Date: Thu Nov 17 08:48:14 2022 +0200 ; * lisp/emacs-lisp/seq.el (seq-filter): Fix typo in doc string. diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 37b843bcca..1645da2eb0 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -336,7 +336,7 @@ TYPE can be one of the following symbols: `vector', `string' or ;;;###autoload (cl-defgeneric seq-filter (pred sequence) - "Return a list of the all elements in SEQUENCE for which PRED returns non-nil." + "Return a list of all the elements in SEQUENCE for which PRED returns non-nil." (let ((exclude (make-symbol "exclude"))) (delq exclude (seq-map (lambda (elt) (if (funcall pred elt) commit ed5022b4eec676bd6c0509615a1f939b796b942b Author: F. Jason Park Date: Mon Jul 11 05:14:57 2022 -0700 Improve new connections in erc-handle-irc-url * doc/misc/erc.texi: Add new Integrations section to the info manual under Advanced Usage. * etc/ERC-NEWS: Add new section mentioning improved UX when clicking on irc:// links. * lisp/erc/erc.el (erc-handle-irc-url): Add optional "scheme" parameter. Fix `erc-open' invocation so that the server buffer is named correctly by deferring to a new customizable opener. Arrange for JOINing a channel in a manner similar to ERC's autojoin module. (erc-url-connect-function): Add new option for creating a new ERC connection based on info parsed from a URL. (erc--url-default-connect-function): New function to serve as an interactive-only fallback when a user hasn't specified a URL connect function. * lisp/erc/erc-compat.el (erc-compat--29-browse-url--irc): Add new compatibility function for `browse-url-irc' and include it in `browse-url-default-handlers' on Emacs versions below 29. * test/lisp/erc/erc-tests.el (erc-tests--make-server-buf, erc-tests--make-client-buf): Add helpers for creating dummy ERC buffers. (erc-handle-irc-url): Add test. * test/lisp/erc/erc-scenarios-misc.el (erc-scenarios-handle-irc-url): Add new test. * test/lisp/erc/resources/join/legacy/foonet.eld: Relax timeout. (Bug#56514.) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index ad35b78f0e..0d807e323e 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -79,6 +79,7 @@ Advanced Usage * Connecting:: Ways of connecting to an IRC server. * Sample Configuration:: An example configuration file. +* Integrations:: Integrations available for ERC. * Options:: Options that are available for ERC. @end detailmenu @@ -526,6 +527,7 @@ Translate morse code in messages @menu * Connecting:: Ways of connecting to an IRC server. * Sample Configuration:: An example configuration file. +* Integrations:: Integrations available for ERC. * Options:: Options that are available for ERC. @end menu @@ -991,6 +993,32 @@ stuff, to the current ERC buffer." ;; (setq erc-kill-server-buffer-on-quit t) @end lisp +@node Integrations +@section Integrations +@cindex integrations + +@subheading URL +For anything to work, you'll want to set @code{url-irc-function} to +@code{url-irc-erc}. As a rule of thumb, libraries relying directly on +@code{url-retrieve} should be fine out the box from Emacs 29.1 onward. +On older versions of Emacs, you may need to @code{(require 'erc)} +beforehand. @pxref{Retrieving URLs,,, url, URL}. + +For other apps and libraries, such as those relying on the +higher-level @code{browse-url}, you'll oftentimes be asked to specify +a pattern, sometimes paired with a function that accepts a string URL +as a first argument. For example, with EWW, you may need to tack +something like @code{"\\|\\`irc6?s?:"} onto the end of +@code{eww-use-browse-url}. But with @code{gnus-button-alist}, you'll +need a function as well: + +@lisp + '("\\birc6?s?://[][a-z0-9.,@@_:+%?&/#-]+" 0 t browse-url-irc 0) +@end lisp + +@noindent +Users on Emacs 28 and below may need to use @code{browse-url} instead. + @node Options @section Options @cindex options diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 5cabb9b015..f638d4717a 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -77,6 +77,13 @@ blanks when 'erc-send-whitespace-lines' is active. New options have also been added for warning when input spans multiple lines. Although off by default, new users are encouraged to enable them. +** URL handling has improved. +Clicking on 'irc://' and 'ircs://' links elsewhere in Emacs now does +the right thing most of the time. However, for security reasons, +users are now prompted to confirm connection parameters prior to lift +off. See the new '(erc) Integrations' section in the Info manual to +override this. + ** Miscellaneous behavioral changes impacting the user experience. A bug has been fixed that saw prompts being mangled, doubled, or erased in server buffers upon disconnection. Instead, input prompts diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 5b54a0587a..d23703394b 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -32,8 +32,7 @@ ;;; Code: (require 'compat nil 'noerror) -(eval-when-compile (require 'cl-lib)) - +(eval-when-compile (require 'cl-lib) (require 'url-parse)) ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode @@ -285,6 +284,35 @@ If START or END is negative, it counts from the end." `(cl--generic-with-memoization ,table ,@forms)) (t `(progn ,@forms)))) +(defvar url-irc-function) + +(defun erc-compat--29-browse-url-irc (string &rest _) + (require 'url-irc) + (let* ((url (url-generic-parse-url string)) + (url-irc-function + (if (function-equal url-irc-function 'url-irc-erc) + (lambda (host port chan user pass) + (erc-handle-irc-url host port chan user pass (url-type url))) + url-irc-function))) + (url-irc url))) + +(cond ((fboundp 'browse-url-irc)) ; 29 + ((boundp 'browse-url-default-handlers) ; 28 + (cl-pushnew '("\\`irc6?s?://" . erc-compat--29-browse-url-irc) + browse-url-default-handlers)) + ((boundp 'browse-url-browser-function) ; 27 + (require 'browse-url) + (let ((existing browse-url-browser-function)) + (setq browse-url-browser-function + (if (functionp existing) + (lambda (u &rest r) + (apply (if (string-match-p "\\`irc6?s?://" u) + #'erc-compat--29-browse-url-irc + existing) + u r)) + (cons '("\\`irc6?s?://" . erc-compat--29-browse-url-irc) + existing)))))) + (provide 'erc-compat) ;;; erc-compat.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 897357e16b..2312246e3e 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -7186,25 +7186,83 @@ This function should be on `erc-kill-channel-hook'." ;; Teach url.el how to open irc:// URLs with ERC. ;; To activate, customize `url-irc-function' to `url-irc-erc'. -;; FIXME change user to nick, and use API to find server buffer +(defcustom erc-url-connect-function nil + "When non-nil, a function used to connect to an IRC URL. +Called with a string meant to represent a URL scheme, like +\"ircs\", followed by any number of keyword arguments recognized +by `erc' and `erc-tls'." + :group 'erc + :package-version '(ERC . "5.4.1") ; FIXME increment on release + :type '(choice (const nil) function)) + +(defun erc--url-default-connect-function (scheme &rest plist) + (let* ((ircsp (if scheme + (string-suffix-p "s" scheme) + (or (eql 6697 (plist-get plist :port)) + (yes-or-no-p "Connect using TLS? ")))) + (erc-server (plist-get plist :server)) + (erc-port (or (plist-get plist :port) + (and ircsp (erc-normalize-port 'ircs-u)) + erc-port)) + (erc-nick (or (plist-get plist :nick) erc-nick)) + (erc-password (plist-get plist :password)) + (args (erc-select-read-args))) + (unless ircsp + (setq ircsp (eql 6697 erc-port))) + (apply (if ircsp #'erc-tls #'erc) args))) + ;;;###autoload -(defun erc-handle-irc-url (host port channel user password) - "Use ERC to IRC on HOST:PORT in CHANNEL as USER with PASSWORD. +(defun erc-handle-irc-url (host port channel nick password &optional scheme) + "Use ERC to IRC on HOST:PORT in CHANNEL. If ERC is already connected to HOST:PORT, simply /join CHANNEL. -Otherwise, connect to HOST:PORT as USER and /join CHANNEL." - (let ((server-buffer - (car (erc-buffer-filter - (lambda () - (and (string-equal erc-session-server host) - (= erc-session-port port) - (erc-open-server-buffer-p))))))) - (with-current-buffer (or server-buffer (current-buffer)) - (if (and server-buffer channel) - (erc-cmd-JOIN channel) - (erc-open host port (or user (erc-compute-nick)) (erc-compute-full-name) - (not server-buffer) password nil channel - (when server-buffer - (get-buffer-process server-buffer))))))) +Otherwise, connect to HOST:PORT as NICK and /join CHANNEL. + +Beginning with ERC 5.5, new connections require human intervention. +Customize `erc-url-connect-function' to override this." + (when (eql port 0) (setq port nil)) + (let* ((net (erc-networks--determine host)) + (server-buffer + ;; Viable matches may slip through the cracks for unknown + ;; networks. Additional passes could likely improve things. + (car (erc-buffer-filter + (lambda () + (and (not erc--target) + (erc-server-process-alive) + ;; Always trust a matched network. + (or (and net (eq net (erc-network))) + (and (string-equal erc-session-server host) + ;; Ports only matter when dialed hosts + ;; match and we have sufficient info. + (or (not port) + (= (erc-normalize-port erc-session-port) + port))))))))) + key deferred) + (unless server-buffer + (setq deferred t + server-buffer (apply (or erc-url-connect-function + #'erc--url-default-connect-function) + scheme + :server host + `(,@(and port (list :port port)) + ,@(and nick (list :nick nick)) + ,@(and password `(:password ,password)))))) + (when channel + ;; These aren't percent-decoded by default + (when (string-prefix-p "%" channel) + (setq channel (url-unhex-string channel))) + (cl-multiple-value-setq (channel key) (split-string channel "[?]")) + (if deferred + ;; Alternatively, we could make this a defmethod, so when + ;; autojoin is loaded, it can do its own thing. Also, as + ;; with `erc-once-with-server-event', it's fine to set local + ;; hooks here because they're killed when reconnecting. + (with-current-buffer server-buffer + (letrec ((f (lambda (&rest _) + (remove-hook 'erc-after-connect f t) + (erc-cmd-JOIN channel key)))) + (add-hook 'erc-after-connect f nil t))) + (with-current-buffer server-buffer + (erc-cmd-JOIN channel key)))))) (provide 'erc) diff --git a/test/lisp/erc/erc-scenarios-misc.el b/test/lisp/erc/erc-scenarios-misc.el index ded620ccc1..8557a77906 100644 --- a/test/lisp/erc/erc-scenarios-misc.el +++ b/test/lisp/erc/erc-scenarios-misc.el @@ -177,4 +177,32 @@ (erc-scenarios-common-say "Hi") (funcall expect 10 "Hola"))))) +(defvar url-irc-function) + +(ert-deftest erc-scenarios-handle-irc-url () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "join/legacy") + (dumb-server (erc-d-run "localhost" t 'foonet)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter)) + (url-irc-function 'url-irc-erc) + (erc-url-connect-function + (lambda (scheme &rest r) + (ert-info ("Connect to foonet") + (should (equal scheme "irc")) + (with-current-buffer (apply #'erc `(:full-name "tester" ,@r)) + (should (string= (buffer-name) + (format "127.0.0.1:%d" port))) + (current-buffer)))))) + + (with-temp-buffer + (insert (format ";; irc://tester:changeme@127.0.0.1:%d/#chan" port)) + (goto-char 10) + (browse-url-at-point)) + + (ert-info ("Connected") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 10 "welcome"))))) + ;;; erc-scenarios-misc.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index db54cb4889..a5100ec155 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1084,4 +1084,98 @@ '(nil 7000 nil "Bob's Name" t "bob:changeme" nil nil nil nil "bobo" nil))))))) +(defun erc-tests--make-server-buf (name) + (with-current-buffer (get-buffer-create name) + (erc-mode) + (setq erc-server-process (start-process "sleep" (current-buffer) + "sleep" "1") + erc-session-server (concat "irc." name ".org") + erc-session-port 6667 + erc-network (intern name)) + (set-process-query-on-exit-flag erc-server-process nil) + (current-buffer))) + +(defun erc-tests--make-client-buf (server name) + (unless (bufferp server) + (setq server (get-buffer server))) + (with-current-buffer (get-buffer-create name) + (erc-mode) + (setq erc--target (erc--target-from-string name)) + (dolist (v '(erc-server-process + erc-session-server + erc-session-port + erc-network)) + (set v (buffer-local-value v server))) + (current-buffer))) + +(ert-deftest erc-handle-irc-url () + (let* (calls + rvbuf + erc-networks-alist + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook + (erc-url-connect-function + (lambda (&rest r) + (push r calls) + (if (functionp rvbuf) (funcall rvbuf) rvbuf)))) + + (cl-letf (((symbol-function 'erc-cmd-JOIN) + (lambda (&rest r) (push r calls)))) + + (with-current-buffer (erc-tests--make-server-buf "foonet") + (setq rvbuf (current-buffer))) + (erc-tests--make-server-buf "barnet") + (erc-tests--make-server-buf "baznet") + + (ert-info ("Unknown network") + (erc-handle-irc-url "irc.foonet.org" 6667 "#chan" nil nil "irc") + (should (equal '("#chan" nil) (pop calls))) + (should-not calls)) + + (ert-info ("Unknown network, no port") + (erc-handle-irc-url "irc.foonet.org" nil "#chan" nil nil "irc") + (should (equal '("#chan" nil) (pop calls))) + (should-not calls)) + + (ert-info ("Known network, no port") + (setq erc-networks-alist '((foonet "irc.foonet.org"))) + (erc-handle-irc-url "irc.foonet.org" nil "#chan" nil nil "irc") + (should (equal '("#chan" nil) (pop calls))) + (should-not calls)) + + (ert-info ("Known network, different port") + (erc-handle-irc-url "irc.foonet.org" 6697 "#chan" nil nil "irc") + (should (equal '("#chan" nil) (pop calls))) + (should-not calls)) + + (ert-info ("Known network, existing chan with key") + (erc-tests--make-client-buf "foonet" "#chan") + (erc-handle-irc-url "irc.foonet.org" nil "#chan?sec" nil nil "irc") + (should (equal '("#chan" "sec") (pop calls))) + (should-not calls)) + + (ert-info ("Unknown network, connect, no chan") + (erc-handle-irc-url "irc.gnu.org" nil nil nil nil "irc") + (should (equal '("irc" :server "irc.gnu.org") (pop calls))) + (should-not calls)) + + (ert-info ("Unknown network, connect, chan") + (with-current-buffer "foonet" + (should-not (local-variable-p 'erc-after-connect))) + (setq rvbuf (lambda () (erc-tests--make-server-buf "gnu"))) + (erc-handle-irc-url "irc.gnu.org" nil "#spam" nil nil "irc") + (should (equal '("irc" :server "irc.gnu.org") (pop calls))) + (should-not calls) + (with-current-buffer "gnu" + (should (local-variable-p 'erc-after-connect)) + (funcall (car erc-after-connect)) + (should (equal '("#spam" nil) (pop calls))) + (should-not (local-variable-p 'erc-after-connect))) + (should-not calls)))) + + (when noninteractive + (kill-buffer "foonet") + (kill-buffer "barnet") + (kill-buffer "baznet") + (kill-buffer "#chan"))) + ;;; erc-tests.el ends here diff --git a/test/lisp/erc/resources/join/legacy/foonet.eld b/test/lisp/erc/resources/join/legacy/foonet.eld index 344ba7c1da..4025094a59 100644 --- a/test/lisp/erc/resources/join/legacy/foonet.eld +++ b/test/lisp/erc/resources/join/legacy/foonet.eld @@ -1,5 +1,5 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :changeme")) +((pass 10 "PASS :changeme")) ((nick 1 "NICK tester")) ((user 1 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") commit 535cc4c81a91d0661418ce59be951dda9e233a2e Author: F. Jason Park Date: Mon Jul 11 05:14:57 2022 -0700 Add optional server param to erc-networks--determine * lisp/erc/erc-networks.el (erc-networks--determine): Accept optional `server' argument. * test/lisp/erc/erc-networks-tests.el (erc-networks--determine): Add test. (Bug#56514.) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index dba6ead073..b3e5fcf1a3 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -1256,14 +1256,15 @@ server name and search for a match in `erc-networks-alist'." (defconst erc-networks--name-missing-sentinel (gensym "Unknown ") "Value to cover rare case of a literal NETWORK=nil.") -(defun erc-networks--determine () +(defun erc-networks--determine (&optional server) "Return the name of the network as a symbol. -Search `erc-networks-alist' for a known entity matching +Search `erc-networks-alist' for a known entity matching SERVER or `erc-server-announced-name'. If that fails, use the display name given by the `RPL_ISUPPORT' NETWORK parameter." (or (cl-loop for (name matcher) in erc-networks-alist - when (and matcher (string-match (concat matcher "\\'") - erc-server-announced-name)) + when (and matcher + (string-match (concat matcher "\\'") + (or server erc-server-announced-name))) return name) (and-let* ((vanity (erc--get-isupport-entry 'NETWORK 'single)) ((intern vanity)))) diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el index 32bdfa11ff..fc12bf7ce3 100644 --- a/test/lisp/erc/erc-networks-tests.el +++ b/test/lisp/erc/erc-networks-tests.el @@ -1704,4 +1704,21 @@ (erc-networks-tests--clean-bufs)) +(ert-deftest erc-networks--determine () + (should (eq (erc-networks--determine "irc.libera.chat") 'Libera.Chat)) + (should (eq (erc-networks--determine "irc.oftc.net") 'OFTC)) + (should (eq (erc-networks--determine "irc.dal.net") 'DALnet)) + + (let ((erc-server-announced-name "zirconium.libera.chat")) + (should (eq (erc-networks--determine) 'Libera.Chat))) + (let ((erc-server-announced-name "weber.oftc.net")) + (should (eq (erc-networks--determine) 'OFTC))) + (let ((erc-server-announced-name "redemption.ix.us.dal.net")) + (should (eq (erc-networks--determine) 'DALnet))) + + ;; Failure + (let ((erc-server-announced-name "irc-us2.alphachat.net")) + (should (eq (erc-networks--determine) + erc-networks--name-missing-sentinel)))) + ;;; erc-networks-tests.el ends here commit 77d6351d60d3c741550d990fbf97184433b7b59a Author: F. Jason Park Date: Mon Jul 11 05:14:57 2022 -0700 Default to TLS port when calling erc-tls from lisp * lisp/erc/erc.el (erc-normalize-port): Add standard IANA port-name mappings for 6667 and 6697. (erc-open): Add note to doc string explaining that params `connect' and `channel' are mutually exclusive. (erc-tls): Call `erc-compute-port' with override. (erc-compute-port): Call `erc-normalize-port' with result'. * test/lisp/erc/erc-tests.el (erc-tls): Add simplistic test focusing on default parameters. (Bug#56514.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index badda3ab84..897357e16b 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1542,6 +1542,11 @@ symbol, it may have these values: * ircs -> 994 * ircd -> 6667 * ircd-dalnet -> 7000" + ;; These were updated somewhat in 2022 to reflect modern standards + ;; and practices. See also: + ;; + ;; https://datatracker.ietf.org/doc/html/rfc7194#section-1 + ;; https://www.iana.org/assignments/service-names-port-numbers (cond ((symbolp port) (erc-normalize-port (symbol-name port))) @@ -1554,8 +1559,10 @@ symbol, it may have these values: 194) ((string-equal port "ircs") 994) - ((string-equal port "ircd") + ((string-equal port "ircu") 6667) ; 6665-6669 + ((string-equal port "ircd") ; nonstandard (irc-serv is 529) 6667) + ((string-equal port "ircs-u") 6697) ((string-equal port "ircd-dalnet") 7000) (t @@ -1924,7 +1931,9 @@ removed from the list will be disabled." If CONNECT is non-nil, connect to the server. Otherwise assume already connected and just create a separate buffer for the new -target CHANNEL. +target given by CHANNEL, meaning these parameters are mutually +exclusive. Note that CHANNEL may also be a query; its name has +been retained for historical reasons. Use PASSWD as user password on the server. If TGT-LIST is non-nil, use it to initialize `erc-default-recipients'. @@ -2183,7 +2192,7 @@ interactively." ;;;###autoload (cl-defun erc-tls (&key (server (erc-compute-server)) - (port (erc-compute-port)) + (port (erc-compute-port 'ircs-u)) (nick (erc-compute-nick)) (user (erc-compute-user)) password @@ -6404,7 +6413,7 @@ non-nil value is found. - PORT (the argument passed to this function) - The `erc-port' option - The `erc-default-port' variable" - (or port erc-port erc-default-port)) + (erc-normalize-port (or port erc-port erc-default-port))) ;; time routines diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index f72db816af..db54cb4889 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1042,4 +1042,46 @@ :nick "nick" :password nil))))) +(ert-deftest erc-tls () + (let (calls) + (cl-letf (((symbol-function 'user-login-name) + (lambda (&optional _) "tester")) + ((symbol-function 'erc-open) + (lambda (&rest r) (push r calls)))) + + (ert-info ("Defaults") + (erc-tls) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t + nil nil nil nil nil "user" nil)))) + + (ert-info ("Full") + (erc-tls :server "irc.gnu.org" + :port 7000 + :user "bobo" + :nick "bob" + :full-name "Bob's Name" + :password "bob:changeme" + :client-certificate t + :id 'GNU.org) + (should (equal (pop calls) + '("irc.gnu.org" 7000 "bob" "Bob's Name" t + "bob:changeme" nil nil nil t "bobo" GNU.org)))) + + ;; Values are often nil when called by lisp code, which leads to + ;; null params. This is why `erc-open' recomputes almost + ;; everything. + (ert-info ("Fallback") + (let ((erc-nick "bob") + (erc-server "irc.gnu.org") + (erc-email-userid "bobo") + (erc-user-full-name "Bob's Name")) + (erc-tls :server nil + :port 7000 + :nick nil + :password "bob:changeme")) + (should (equal (pop calls) + '(nil 7000 nil "Bob's Name" t + "bob:changeme" nil nil nil nil "bobo" nil))))))) + ;;; erc-tests.el ends here commit 46c765ed09422767306bd7acfc8422d5ad4cea4a Author: F. Jason Park Date: Mon Jul 11 05:14:57 2022 -0700 Refactor erc-select-read-args * lisp/erc/erc-backend.el (erc--server-connect-dumb-ipv6-regexp): Add liberal pattern for matching bracketed IPv6 addresses. (erc-server-connect): Remove brackets from IPv6 hosts before connecting. * lisp/erc/erc.el (erc--ensure-url): Add compat adapter to massage partial URLs given as input that may be missing the scheme:// portion. (erc-select-read-args): Keep bracketed IPv6 hosts intact. Make this function fully URL-aware (was only partially so). Accept optional `input' argument. * lisp/erc/erc-tests.el (erc-tests--ipv6-examples, erc--server-connect-dumb-ipv6-regexp, erc-select-read-args): Add test reading user input during interactive invocations of entry points. (Bug#56514.) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index d49e6a5f1a..15fd6ac50f 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -638,12 +638,18 @@ The current buffer is given by BUFFER." (let ((p (plist-put parameters :nowait t))) (apply #'open-network-stream name buffer host service p))) +(defvar erc--server-connect-dumb-ipv6-regexp + ;; Not for validation (gives false positives). + (rx bot "[" (group (+ (any xdigit digit ":.")) (? "%" (+ alnum))) "]" eot)) + (defun erc-server-connect (server port buffer &optional client-certificate) "Perform the connection and login using the specified SERVER and PORT. We will store server variables in the buffer given by BUFFER. CLIENT-CERTIFICATE may optionally be used to specify a TLS client certificate to use for authentication when connecting over TLS (see `erc-session-client-certificate' for more details)." + (when (string-match erc--server-connect-dumb-ipv6-regexp server) + (setq server (match-string 1 server))) (let ((msg (erc-format-message 'connect ?S server ?p port)) process (args `(,(format "erc-%s-%s" server port) nil ,server ,port))) (when client-certificate diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 303f45d177..badda3ab84 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -70,7 +70,7 @@ (require 'auth-source) (require 'time-date) (require 'iso8601) -(eval-when-compile (require 'subr-x)) +(eval-when-compile (require 'subr-x) (require 'url-parse)) (defconst erc-version "5.4.1" "This version of ERC.") @@ -2094,52 +2094,51 @@ parameters SERVER and NICK." :group 'erc-hooks :type '(repeat function)) +(defun erc--ensure-url (input) + (unless (string-match (rx bot "irc" (? "6") (? "s") "://") input) + (when (and (string-match (rx (? (+ any) "@") + (or (group (* (not "[")) ":" (* any)) + (+ any)) + ":" (+ (not (any ":]"))) eot) + input) + (match-beginning 1)) + (setq input (concat "[" (substring input (match-beginning 1)) "]"))) + (setq input (concat "irc://" input))) + input) + ;;;###autoload (defun erc-select-read-args () "Prompt the user for values of nick, server, port, and password." - (let (user-input server port nick passwd) - (setq user-input (read-string - "IRC server: " - (erc-compute-server) 'erc-server-history-list)) - - (if (string-match "\\(.*\\):\\(.*\\)\\'" user-input) - (setq port (erc-string-to-port (match-string 2 user-input)) - user-input (match-string 1 user-input)) - (setq port - (erc-string-to-port (read-string - "IRC port: " (erc-port-to-string - (erc-compute-port)))))) - - (if (string-match "\\`\\(.*\\)@\\(.*\\)" user-input) - (setq nick (match-string 1 user-input) - user-input (match-string 2 user-input)) - (setq nick - (if (erc-already-logged-in server port nick) - (read-string - (erc-format-message 'nick-in-use ?n nick) - nick 'erc-nick-history-list) - (read-string - "Nickname: " (erc-compute-nick nick) - 'erc-nick-history-list)))) - - (setq server user-input) - - (setq passwd (if erc-prompt-for-password - (read-passwd "Server password: ") - (with-suppressed-warnings ((obsolete erc-password)) - erc-password))) + (require 'url-parse) + (let* ((input (let ((d (erc-compute-server))) + (read-string (format "Server (default is %S): " d) + nil 'erc-server-history-list d))) + ;; For legacy reasons, also accept a URL without a scheme. + (url (url-generic-parse-url (erc--ensure-url input))) + (server (url-host url)) + (sp (and (or (string-suffix-p "s" (url-type url)) + (and (equal server erc-default-server) + (not (string-prefix-p "irc://" input)))) + 'ircs-u)) + (port (or (url-portspec url) + (erc-compute-port + (let ((d (erc-compute-port sp))) ; may be a string + (read-string (format "Port (default is %s): " d) + nil nil d))))) + ;; Trust the user not to connect twice accidentally. We + ;; can't use `erc-already-logged-in' to check for an existing + ;; connection without modifying it to consider USER and PASS. + (nick (or (url-user url) + (let ((d (erc-compute-nick))) + (read-string (format "Nickname (default is %S): " d) + nil 'erc-nick-history-list d)))) + (passwd (or (url-password url) + (if erc-prompt-for-password + (read-passwd "Server password (optional): ") + (with-suppressed-warnings ((obsolete erc-password)) + erc-password))))) (when (and passwd (string= "" passwd)) (setq passwd nil)) - - (while (erc-already-logged-in server port nick) - ;; hmm, this is a problem when using multiple connections to a bnc - ;; with the same nick. Currently this code prevents using more than one - ;; bnc with the same nick. actually it would be nice to have - ;; bncs transparent, so that erc-compute-buffer-name displays - ;; the server one is connected to. - (setq nick (read-string - (erc-format-message 'nick-in-use ?n nick) - nick 'erc-nick-history-list))) (list :server server :port port :nick nick :password passwd))) ;;;###autoload diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index c88dd9888d..f72db816af 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -953,4 +953,93 @@ (kill-buffer "ExampleNet") (kill-buffer "#chan"))) +(defvar erc-tests--ipv6-examples + '("1:2:3:4:5:6:7:8" + "::ffff:10.0.0.1" "::ffff:1.2.3.4" "::ffff:0.0.0.0" + "1:2:3:4:5:6:77:88" "::ffff:255.255.255.255" + "fe08::7:8" "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" + "1:2:3:4:5:6:7:8" "1::" "1:2:3:4:5:6:7::" "1::8" + "1:2:3:4:5:6::8" "1:2:3:4:5:6::8" "1::7:8" "1:2:3:4:5::7:8" + "1:2:3:4:5::8" "1::6:7:8" "1:2:3:4::6:7:8" "1:2:3:4::8" + "1::5:6:7:8" "1:2:3::5:6:7:8" "1:2:3::8" "1::4:5:6:7:8" + "1:2::4:5:6:7:8" "1:2::8" "1::3:4:5:6:7:8" "1::3:4:5:6:7:8" + "1::8" "::2:3:4:5:6:7:8" "::2:3:4:5:6:7:8" "::8" + "::" "fe08::7:8%eth0" "fe08::7:8%1" "::255.255.255.255" + "::ffff:255.255.255.255" "::ffff:0:255.255.255.255" + "2001:db8:3:4::192.0.2.33" "64:ff9b::192.0.2.33")) + +(ert-deftest erc--server-connect-dumb-ipv6-regexp () + (dolist (a erc-tests--ipv6-examples) + (should-not (string-match erc--server-connect-dumb-ipv6-regexp a)) + (should (string-match erc--server-connect-dumb-ipv6-regexp + (concat "[" a "]"))))) + +(ert-deftest erc-select-read-args () + + (ert-info ("Defaults to TLS") + (should (equal (ert-simulate-keys "\r\r\r\r" + (erc-select-read-args)) + (list :server "irc.libera.chat" + :port 6697 + :nick (user-login-name) + :password nil)))) + + (ert-info ("Override default TLS") + (should (equal (ert-simulate-keys "irc://irc.libera.chat\r\r\r\r" + (erc-select-read-args)) + (list :server "irc.libera.chat" + :port 6667 + :nick (user-login-name) + :password nil)))) + + (ert-info ("Address includes port") + (should (equal (ert-simulate-keys + "localhost:6667\rnick\r\r" + (erc-select-read-args)) + (list :server "localhost" + :port 6667 + :nick "nick" + :password nil)))) + + (ert-info ("Address includes nick, password skipped via option") + (should (equal (ert-simulate-keys "nick@localhost:6667\r" + (let (erc-prompt-for-password) + (erc-select-read-args))) + (list :server "localhost" + :port 6667 + :nick "nick" + :password nil)))) + + (ert-info ("Addresss includes nick and password") + (should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r" + (erc-select-read-args)) + (list :server "localhost" + :port 6667 + :nick "nick" + :password "sesame")))) + + (ert-info ("IPv6 address plain") + (should (equal (ert-simulate-keys "::1\r\r\r\r" + (erc-select-read-args)) + (list :server "[::1]" + :port 6667 + :nick (user-login-name) + :password nil)))) + + (ert-info ("IPv6 address with port") + (should (equal (ert-simulate-keys "[::1]:6667\r\r\r" + (erc-select-read-args)) + (list :server "[::1]" + :port 6667 + :nick (user-login-name) + :password nil)))) + + (ert-info ("IPv6 address includes nick") + (should (equal (ert-simulate-keys "nick@[::1]:6667\r\r" + (erc-select-read-args)) + (list :server "[::1]" + :port 6667 + :nick "nick" + :password nil))))) + ;;; erc-tests.el ends here commit 5699e43f27ef5ca760a38572928be8a53819a430 Author: F. Jason Park Date: Mon Jul 11 05:14:57 2022 -0700 Accommodate ircs:// URLs in url-irc and browse-url * lisp/url/url-irc.el (url-irc-function): Change signature of function interface to expect a final "scheme" argument, such as "ircs". (url-irc): Call `url-irc-function' with new positional argument, the scheme extracted via `url-type' from the input URL. (url-irc-erc, url-irc-rcirc, url-irc-zenirc): Accept a URL scheme as a sixth positional arg. (url-ircs-default-port, url-ircs): Add new autoloaded constant and alias for `url-scheme-get-property' to recognize. Do this to avoid having to add another file. * lisp/net/browse-url.el (browse-url-irc-function): Add new option. (browse-url--irc): Add new function to call `browse-url-irc-function'. (browse-url-default-handlers): Add "irc://" entry. (browse-url-irc): Add new function to serve as general handler for "irc://" URLS. Accept trailing variadic args to accommodate non-browse-url interfaces as well. * test/lisp/net/browse-url-tests.el (browse-url-tests-select-handler-irc): Add test for "irc://" URL pattern. * etc/NEWS: Mention select browse-url and url-irc changes. (Bug#56514.) diff --git a/etc/NEWS b/etc/NEWS index 1e7190e830..bb2bd52134 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -439,6 +439,12 @@ The user options 'url-gateway-rlogin-host', 'url-gateway-rlogin-parameters', and 'url-gateway-rlogin-user-name' are also obsolete. +--- +** The user function 'url-irc-function' now takes a 'scheme' argument. +The user option 'url-irc-function' is now called with a sixth argument +corresponding to the scheme portion of the target URL. For example, +this would be "ircs" for a URL like "ircs://irc.libera.chat". + --- ** The linum.el library is now obsolete. We recommend using either the built-in 'display-line-numbers-mode', or @@ -2642,6 +2648,17 @@ This user option decides which URL scheme that 'browse-url' and related functions will use by default. For example, you could customize this to "https" to always prefer HTTPS URLs. +--- +*** New user option 'browse-url-irc-function'. +This option specifies a function for opening irc:// links. It +defaults to the new function 'browse-url-irc'. + +--- +*** New function 'browse-url-irc'. +This multipurpose autoloaded function can be used for opening irc:// +and ircs:// URLS by any caller that passes a URL string as an initial +arg. + --- *** Support for the Netscape web browser has been removed. This support has been obsolete since Emacs 25.1. The final version of @@ -2868,6 +2885,9 @@ remote host are shown. Alternatively, the user option *** 'outlineify-sticky' command is renamed to 'allout-outlinify-sticky'. The old name is still available as an obsolete function alias. +--- +*** The url-irc library now understands ircs:// links. + --- *** New command 'world-clock-copy-time-as-kill' for 'M-x world-clock'. It copies the current line into the kill ring. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 1597f3651a..7ac6396d31 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -222,6 +222,14 @@ be used instead." (function :tag "Other function")) :version "26.1") +(defcustom browse-url-irc-function 'browse-url-irc + "Function to open an irc:// link." + :type '(choice + (function-item :tag "Emacs IRC" :value browse-url-irc) + (const :tag "None" nil) + (function :tag "Other function")) + :version "29.1") + (defcustom browse-url-button-regexp (concat "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|gemini\\|" @@ -547,6 +555,11 @@ process), or nil (we don't know)." (function-put 'browse-url--man 'browse-url-browser-kind #'browse-url--browser-kind-man) +(defun browse-url--irc (url &rest args) + "Call `browse-url-irc-function' with URL and ARGS." + (funcall browse-url-irc-function url args)) +(function-put 'browse-url--irc 'browse-url-browser-kind 'internal) + (defun browse-url--browser (url &rest args) "Call `browse-url-browser-function' with URL and ARGS." (funcall browse-url-browser-function url args)) @@ -565,6 +578,7 @@ process), or nil (we don't know)." (defvar browse-url-default-handlers '(("\\`mailto:" . browse-url--mailto) ("\\`man:" . browse-url--man) + ("\\`irc6?s?://" . browse-url--irc) (browse-url--non-html-file-url-p . browse-url-emacs)) "Like `browse-url-handlers' but populated by Emacs and packages. @@ -1510,6 +1524,16 @@ used instead of `browse-url-new-window-flag'." (function-put 'browse-url-text-emacs 'browse-url-browser-kind 'internal) +;; --- irc --- + +;;;###autoload +(defun browse-url-irc (url &rest _) + "Call `url-irc' directly after parsing URL. +This function is a fit for options like `gnus-button-alist'." + (url-irc (url-generic-parse-url url))) + +(function-put 'browse-url-irc 'browse-url-browser-kind 'internal) + ;; --- mailto --- (autoload 'rfc6068-parse-mailto-url "rfc6068") diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el index 9161f7d13e..f97b6de6fe 100644 --- a/lisp/url/url-irc.el +++ b/lisp/url/url-irc.el @@ -38,11 +38,13 @@ The function should take the following arguments: PORT - the port number of the IRC server to contact CHANNEL - What channel on the server to visit right away (can be nil) USER - What username to use -PASSWORD - What password to use" +PASSWORD - What password to use. + SCHEME - a URI scheme, such as \"irc\" or \"ircs\"" :type '(choice (const :tag "rcirc" :value url-irc-rcirc) (const :tag "ERC" :value url-irc-erc) (const :tag "ZEN IRC" :value url-irc-zenirc) (function :tag "Other")) + :version "29.1" ; Added SCHEME :group 'url) ;; External. @@ -51,7 +53,7 @@ PASSWORD - What password to use" (defvar zenirc-server-alist) (defvar zenirc-buffer-name) -(defun url-irc-zenirc (host port channel user password) +(defun url-irc-zenirc (host port channel user password _) (let ((zenirc-buffer-name (if (and user host port) (format "%s@%s:%d" user host port) (format "%s:%d" host port))) @@ -65,14 +67,14 @@ PASSWORD - What password to use" (insert "/join " channel) (zenirc-send-line)))) -(defun url-irc-rcirc (host port channel user password) +(defun url-irc-rcirc (host port channel user password _) (let ((chan (when channel (concat "#" channel)))) (rcirc-connect host port user nil nil (when chan (list chan)) password) (when chan (switch-to-buffer (concat chan "@" host))))) -(defun url-irc-erc (host port channel user password) - (erc-handle-irc-url host port channel user password)) +(defun url-irc-erc (host port channel user password scheme) + (erc-handle-irc-url host port channel user password scheme)) ;;;###autoload (defun url-irc (url) @@ -80,16 +82,32 @@ PASSWORD - What password to use" (port (url-port url)) (pass (url-password url)) (user (url-user url)) - (chan (url-filename url))) + (chan (url-filename url)) + (type (url-type url)) + (compatp (eql 5 (cdr (func-arity url-irc-function))))) (if (url-target url) (setq chan (concat chan "#" (url-target url)))) (if (string-match "^/" chan) (setq chan (substring chan 1 nil))) (if (= (length chan) 0) (setq chan nil)) - (funcall url-irc-function host port chan user pass) + (when compatp + (lwarn 'url :error "Obsolete value for `url-irc-function'")) + (apply url-irc-function + host port chan user pass (unless compatp (list type))) nil)) +;;;; ircs:// + +;; The function `url-scheme-get-property' tries and fails to load the +;; nonexistent url-ircs.el but falls back to using the following: + +;;;###autoload +(defconst url-ircs-default-port 6697 "Default port for IRCS connections.") + +;;;###autoload +(defalias 'url-ircs 'url-irc) + (provide 'url-irc) ;;; url-irc.el ends here diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el index 1c993958b8..dc81976821 100644 --- a/test/lisp/net/browse-url-tests.el +++ b/test/lisp/net/browse-url-tests.el @@ -56,6 +56,15 @@ 'browse-url--man)) (should-not (browse-url-select-handler "man:ls" 'external))) +(ert-deftest browse-url-tests-select-handler-irc () + (should (eq (browse-url-select-handler "irc://localhost" 'internal) + 'browse-url--irc)) + (should-not (browse-url-select-handler "irc://localhost" 'external)) + (should (eq (browse-url-select-handler "irc6://localhost") + 'browse-url--irc)) + (should (eq (browse-url-select-handler "ircs://tester@irc.gnu.org/#chan") + 'browse-url--irc))) + (ert-deftest browse-url-tests-select-handler-file () (should (eq (browse-url-select-handler "file://foo.txt") 'browse-url-emacs)) commit d4028ead897464c9799847900b4acb2276acaac6 Author: F. Jason Park Date: Mon Oct 24 22:58:13 2022 -0700 Warn of future breaking change to erc-response.tags * lisp/erc/erc-backend.el (erc-parse-tags-format): New option to determine type of the `erc-response' "tags" field. (erc-parse-tags): Defer to internal generic function. (erc--parse-tags): New function to hold original `erc-parse-tags' implementation. (erc--parse-message-tags): New generic function that conditionally calls `erc--parse-tags', perhaps emitting a warning beforehand. (erc-parse-server-response): Call `erc--parse-message-tags'. (Bug#58797.) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 51c92e0f12..d49e6a5f1a 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -1122,8 +1122,37 @@ See also `erc-server-send'." ;;;; Handling responses +(defcustom erc-tags-format 'overridable + "Shape of the `tags' alist in `erc-response' objects. +When set to `legacy', pre-5.5 parsing behavior takes effect for +the tags portion of every message. The resulting alist contains +conses of the form (STRING . LIST), in which LIST is comprised of +at most one, possibly empty string. When set to nil, ERC only +parses tags if an active module defines an implementation. It +otherwise ignores them. In such cases, each alist element is a +cons of a symbol and an optional, nonempty string. + +With the default value of `overridable', ERC behaves as it does +with `legacy' except that it emits a warning whenever first +encountering a message containing tags in a given Emacs session. +But it only does so when a module implementing overriding, +non-legacy behavior isn't already active in the current network +context. + +Note that future bundled modules providing IRCv3 functionality +will not be compatible with the legacy format. User code should +eventually transition to expecting this \"5.5+ variant\" and set +this option to nil." + :package-version '(ERC . "5.4.1") ; FIXME increment on next release + :type '(choice (const nil) + (const legacy) + (const overridable))) + (defun erc-parse-tags (string) "Parse IRCv3 tags list in STRING to a (tag . value) alist." + (erc--parse-message-tags string)) + +(defun erc--parse-tags (string) (let ((tags) (tag-strings (split-string string ";"))) (dolist (tag-string tag-strings tags) @@ -1133,6 +1162,28 @@ See also `erc-server-send'." `(,pair)) tags))))) +;; A benefit of this function being internal is not having to define a +;; separate method just to ensure an `erc-tags-format' value of +;; `legacy' always wins. A downside is that module code must take +;; care to preserve that promise manually. + +(cl-defgeneric erc--parse-message-tags (string) + "Parse STRING into an alist of (TAG . VALUE) conses. +Expect TAG to be a symbol and VALUE nil or a nonempty string. +Don't split composite raw-input values containing commas; +instead, leave them as a single string." + (when erc-tags-format + (unless (or (eq erc-tags-format 'legacy) + (get 'erc-parse-tags 'erc-v3-warned-p)) + (put 'erc-parse-tags 'erc-v3-warned-p t) + (display-warning + 'ERC + (concat + "Legacy ERC tags behavior is currently in effect, but other modules," + " including those bundled with ERC, may override this in future" + " releases. See `erc-tags-format' for more info."))) + (erc--parse-tags string))) + (defun erc-parse-server-response (proc string) "Parse and act upon a complete line from an IRC server. PROC is the process (connection) from which STRING was received. @@ -1142,9 +1193,9 @@ PROCs `process-buffer' is `current-buffer' when this function is called." (let* ((tag-list (when (eq (aref string 0) ?@) (substring string 1 (string-search " " string)))) - (msg (make-erc-response :unparsed string :tags (when tag-list - (erc-parse-tags - tag-list)))) + (msg (make-erc-response :unparsed string :tags + (when tag-list + (erc--parse-message-tags tag-list)))) (string (if tag-list (substring string (+ 1 (string-search " " string))) string)) diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index d8aac36eab..23a1933798 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -77,6 +77,9 @@ (cl-defstruct (erc--target-channel (:include erc--target))) (cl-defstruct (erc--target-channel-local (:include erc--target-channel))) +;; Beginning in 5.5/29.1, the `tags' field may take on one of two +;; differing types. See `erc-tags-format' for details. + (cl-defstruct (erc-response (:conc-name erc-response.)) (unparsed "" :type string) (sender "" :type string) commit e7f2f6cd92b924ecdfcf1356560d4a168546677d Author: F. Jason Park Date: Thu Oct 27 00:21:10 2022 -0700 Improve auto-reconnect visibility in ERC * lisp/erc/erc-backend.el (erc--server-reconnect-timer): New variable. (erc-server-reconnect-function): New user option. (erc-process-sentinel-2): Display time remaining until next reconnection attempt. Also remove condition case and move bulk of else condition logic to `erc-schedule-reconnect'. More importantly, no longer set `erc--server-reconnecting here'). (erc-server-connect): Initialize `erc--server-reconnect-timer' to nil. (erc-server-reconnect): Set `erc-server--reconnecting' here. (erc--mode-line-process-reconnecting): New constant to store value for "reconnect" state of `mode-line-process'. (erc--cancel-auto-reconnect-timer): New function to cancel auto-reconnect timer and print message. (erc-schedule-reconnect): New function for scheduling another reconnect attempt. * lisp/erc/erc.el (erc-open): Only update mode line for target buffers. For server buffers, let `erc-login' and/or process sentinels take care of it. (erc--cmd-reconnect, erc-cmd-RECONNECT): Rename latter to former, a new function, but repurpose existing to recognize newly allowed additional arguments and act accordingly. In new internal function, cancel an existing auto-reconnect timer, if any, before proceeding. Defer to `erc-server-reconnect' to set `erc--server-reconnecting'. Fix `with-suppressed-warnings' form. (erc-update-mode-line-buffer): Show "reconnecting in Ns" for `mode-line-process' when awaiting an automatic reconnect attempt. (erc-message-english-reconnecting, erc-message-english-reconnect-canceled): Add new message functions to English catalog. * lisp/erc/erc-pcomplete.el (pcomplete/erc-mode/RECONNECT): Perform completion for newly subcommand-aware `erc-cmd-RECONNECT'. * lisp/erc/erc-scenarios-base-reconnect (erc-scenarios-base-cancel-reconnect): Add new test case for canceling reconnect timers. (Bug#58840.) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 026b34849a..51c92e0f12 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -299,6 +299,9 @@ function `erc-server-process-alive' instead.") (defvar-local erc--server-last-reconnect-count 0 "Snapshot of reconnect count when the connection was established.") +(defvar-local erc--server-reconnect-timer nil + "Auto-reconnect timer for a network context.") + (defvar-local erc-server-quitting nil "Non-nil if the user requests a quit.") @@ -401,6 +404,16 @@ This only has an effect if `erc-server-auto-reconnect' is non-nil." If a key is pressed while ERC is waiting, it will stop waiting." :type 'number) +(defcustom erc-server-reconnect-function 'erc-server-delayed-reconnect + "Function called by the reconnect timer to create a new connection. +Called with a server buffer as its only argument. Potential uses +include exponential backoff and probing for connectivity prior to +dialing. Use `erc-schedule-reconnect' to instead try again later +and optionally alter the attempts tally." + :package-version '(ERC . "5.4.1") ; FIXME on next release + :type '(choice (function-item erc-server-delayed-reconnect) + function)) + (defcustom erc-split-line-length 440 "The maximum length of a single message. If a message exceeds this size, it is broken into multiple ones. @@ -645,7 +658,8 @@ TLS (see `erc-session-client-certificate' for more details)." (setq erc-server-process process) (setq erc-server-quitting nil) (setq erc-server-reconnecting nil - erc--server-reconnecting nil) + erc--server-reconnecting nil + erc--server-reconnect-timer nil) (setq erc-server-timed-out nil) (setq erc-server-banned nil) (setq erc-server-error-occurred nil) @@ -686,6 +700,7 @@ Make sure you are in an ERC buffer when running this." (with-current-buffer buffer (erc-update-mode-line) (erc-set-active-buffer (current-buffer)) + (setq erc--server-reconnecting t) (setq erc-server-last-sent-time 0) (setq erc-server-lines-sent 0) (let ((erc-server-connect-function (or erc-session-connector @@ -758,37 +773,59 @@ EVENT is the message received from the closed connection process." erc-server-reconnecting) (erc--server-reconnect-p event))) +(defconst erc--mode-line-process-reconnecting + '(:eval (erc-with-server-buffer + (and erc--server-reconnect-timer + (format ": reconnecting in %.1fs" + (- (timer-until erc--server-reconnect-timer + (current-time))))))) + "Mode-line construct showing seconds until next reconnect attempt. +Move point around to refresh.") + +(defun erc--cancel-auto-reconnect-timer () + (when erc--server-reconnect-timer + (cancel-timer erc--server-reconnect-timer) + (erc-display-message nil 'notice nil 'reconnect-canceled + ?u (buffer-name) + ?c (- (timer-until erc--server-reconnect-timer + (current-time)))) + (setq erc--server-reconnect-timer nil) + (erc-update-mode-line))) + +(defun erc-schedule-reconnect (buffer &optional incr) + "Create and return a reconnect timer for BUFFER. +When `erc-server-reconnect-attempts' is a number, increment +`erc-server-reconnect-count' by INCR unconditionally." + (let ((count (and (integerp erc-server-reconnect-attempts) + (- erc-server-reconnect-attempts + (cl-incf erc-server-reconnect-count (or incr 1)))))) + (erc-display-message nil 'error (current-buffer) 'reconnecting + ?m erc-server-reconnect-timeout + ?i (if count erc-server-reconnect-count "N") + ?n (if count erc-server-reconnect-attempts "A")) + (setq erc-server-reconnecting nil + erc--server-reconnect-timer + (run-at-time erc-server-reconnect-timeout nil + erc-server-reconnect-function buffer)))) + (defun erc-process-sentinel-2 (event buffer) "Called when `erc-process-sentinel-1' has detected an unexpected disconnect." - (if (not (buffer-live-p buffer)) - (erc-update-mode-line) + (when (buffer-live-p buffer) (with-current-buffer buffer - (let ((reconnect-p (erc--server-reconnect-p event)) message delay) + (let ((reconnect-p (erc--server-reconnect-p event)) message) (setq message (if reconnect-p 'disconnected 'disconnected-noreconnect)) (erc-display-message nil 'error (current-buffer) message) (if (not reconnect-p) ;; terminate, do not reconnect (progn - (setq erc--server-reconnecting nil) + (setq erc--server-reconnecting nil + erc--server-reconnect-timer nil) (erc-display-message nil 'error (current-buffer) 'terminated ?e event) - ;; Update mode line indicators - (erc-update-mode-line) (set-buffer-modified-p nil)) ;; reconnect - (condition-case nil - (progn - (setq erc-server-reconnecting nil - erc--server-reconnecting t - erc-server-reconnect-count (1+ erc-server-reconnect-count)) - (setq delay erc-server-reconnect-timeout) - (run-at-time delay nil - #'erc-server-delayed-reconnect buffer)) - (error (unless (integerp erc-server-reconnect-attempts) - (message "%s ... %s" - "Reconnecting until we succeed" - "kill the ERC server buffer to stop")) - (erc-server-delayed-reconnect buffer)))))))) + (erc-schedule-reconnect buffer)))) + (erc-update-mode-line))) (defun erc-process-sentinel-1 (event buffer) "Called when `erc-process-sentinel' has decided that we're disconnecting. diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index af8528dbc3..3ba18e835b 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -179,6 +179,10 @@ for use on `completion-at-point-function'." (defun pcomplete/erc-mode/UNIGNORE () (pcomplete-here (erc-with-server-buffer erc-ignore-list))) +(defun pcomplete/erc-mode/RECONNECT () + (pcomplete-here '("cancel")) + (pcomplete-opt "a")) + ;;; Functions that provide possible completions. (defun pcomplete-erc-commands () diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 2d55e698a7..303f45d177 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2032,12 +2032,12 @@ Returns the buffer for the given server or channel." ;; Saving log file on exit (run-hook-with-args 'erc-connect-pre-hook buffer) - (when connect - (erc-server-connect erc-session-server - erc-session-port - buffer - erc-session-client-certificate)) - (erc-update-mode-line) + (if connect + (erc-server-connect erc-session-server + erc-session-port + buffer + erc-session-client-certificate) + (erc-update-mode-line)) ;; Now display the buffer in a window as per user wishes. (unless (eq buffer old-buffer) @@ -3804,17 +3804,17 @@ the message given by REASON." (put 'erc-cmd-GQUIT 'do-not-parse-args t) (put 'erc-cmd-GQUIT 'process-not-needed t) -(defun erc-cmd-RECONNECT () - "Try to reconnect to the current IRC server." +(defun erc--cmd-reconnect () (let ((buffer (erc-server-buffer)) (process nil)) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) (with-current-buffer buffer + (when erc--server-reconnect-timer + (erc--cancel-auto-reconnect-timer)) (setq erc-server-quitting nil) (with-suppressed-warnings ((obsolete erc-server-reconnecting)) (setq erc-server-reconnecting t)) - (setq erc--server-reconnecting t) (setq erc-server-reconnect-count 0) (setq process (get-buffer-process (erc-server-buffer))) (when process @@ -3828,6 +3828,18 @@ the message given by REASON." (setq erc--server-reconnecting nil erc-server-reconnecting nil))))) t) + +(defun erc-cmd-RECONNECT (&rest args) + "Try reconnecting to the current IRC server. +Alternatively, CANCEL a scheduled attempt for either the current +connection or, with -A, all applicable connections. + +\(fn [CANCEL [-A]])" + (pcase args + (`("cancel" "-a") (erc-buffer-filter #'erc--cancel-auto-reconnect-timer)) + (`("cancel") (erc-with-server-buffer (erc--cancel-auto-reconnect-timer))) + (_ (erc--cmd-reconnect)))) + (put 'erc-cmd-RECONNECT 'process-not-needed t) (defun erc-cmd-SERVER (server) @@ -6713,11 +6725,12 @@ shortened server name instead." (?s . ,(erc-format-target-and/or-server)) (?S . ,(erc-format-target-and/or-network)) (?t . ,(erc-format-target)))) - (process-status (cond ((and (erc-server-process-alive) - (not erc-server-connected)) - ":connecting") - ((erc-server-process-alive) - "") + (process-status (cond ((erc-server-process-alive buffer) + (unless erc-server-connected + ": connecting")) + ((erc-with-server-buffer + erc--server-reconnect-timer) + erc--mode-line-process-reconnecting) (t ": CLOSED"))) (face (cond ((eq erc-header-line-face-method nil) @@ -6728,7 +6741,7 @@ shortened server name instead." 'erc-header-line)))) (setq mode-line-buffer-identification (list (format-spec erc-mode-line-format spec))) - (setq mode-line-process (list process-status)) + (setq mode-line-process process-status) (let ((header (if erc-header-line-format (format-spec erc-header-line-format spec) nil))) @@ -6913,6 +6926,8 @@ All windows are opened in the current frame." (disconnected . "\n\nConnection failed! Re-establishing connection...\n") (disconnected-noreconnect . "\n\nConnection failed! Not re-establishing connection.\n") + (reconnecting . "Reconnecting in %ms: attempt %i/%n ...") + (reconnect-canceled . "Canceled %u reconnect timer with %cs to go...") (finished . "\n\n*** ERC finished ***\n") (terminated . "\n\n*** ERC terminated: %e\n") (login . "Logging in as `%n'...") diff --git a/test/lisp/erc/erc-scenarios-base-reconnect.el b/test/lisp/erc/erc-scenarios-base-reconnect.el index 49298dc594..8762f33b30 100644 --- a/test/lisp/erc/erc-scenarios-base-reconnect.el +++ b/test/lisp/erc/erc-scenarios-base-reconnect.el @@ -224,4 +224,50 @@ (with-current-buffer "#chan" (funcall expect 10 "here comes the lady"))))) + +(ert-deftest erc-scenarios-base-cancel-reconnect () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/reconnect") + (dumb-server (erc-d-run "localhost" t 'timer 'timer 'timer-last)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter)) + (erc-server-auto-reconnect t) + erc-autojoin-channels-alist + erc-server-buffer) + + (ert-info ("Connect to foonet") + (setq erc-server-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "changeme" + :full-name "tester")) + (with-current-buffer erc-server-buffer + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (ert-info ("Two connection attempts, all stymied") + (with-current-buffer erc-server-buffer + (ert-info ("First two attempts behave normally") + (dotimes (n 2) + (ert-info ((format "Initial attempt %d" (1+ n))) + (funcall expect 3 "Opening connection") + (funcall expect 2 "Password incorrect") + (funcall expect 2 "Connection failed!") + (funcall expect 2 "Re-establishing connection")))) + (ert-info ("/RECONNECT cancels timer but still attempts to connect") + (erc-cmd-RECONNECT) + (funcall expect 2 "Canceled") + (funcall expect 3 "Opening connection") + (funcall expect 2 "Password incorrect") + (funcall expect 2 "Connection failed!") + (funcall expect 2 "Re-establishing connection")) + (ert-info ("Explicitly cancel timer") + (erc-cmd-RECONNECT "cancel") + (funcall expect 2 "Canceled") + (erc-d-t-absent-for 1 "Opening connection" (point))))) + + (ert-info ("Server buffer is unique and temp name is absent") + (should (equal (list (get-buffer (format "127.0.0.1:%d" port))) + (erc-scenarios-common-buflist "127.0.0.1")))))) + ;;; erc-scenarios-base-reconnect.el ends here commit 4351fb7161f9490f21281b0b0abfd5854dc2f2ea Author: F. Jason Park Date: Wed Nov 16 01:21:20 2022 -0800 ; Make some ERC test fixtures a bit more courteous * test/lisp/erc/erc-dcc-tests.el (erc-dcc-tests--pcomplete-common): Only emit messages when interactive. * test/lisp/erc/resources/erc-d/erc-d-tests.el (erc-d-tests-with-server): Shadow `erc-after-connect' so `erc-autojoin-channels' doesn't affect other tests. test/lisp/erc/resources/erc-scenarios-common.el (erc-scenarios-common--make-bindings): Shadow `erc-after-connect' here as well. Also require erc instead of erc-backend to silence some new compiler warnings the cropped up after the creation of erc-common.el. diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index 8645d7f104..74cbb7d947 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -167,7 +167,8 @@ (defun erc-dcc-tests--pcomplete-common (test-fn) (with-current-buffer (get-buffer-create "*erc-dcc-do-GET-command*") - (let* ((proc (start-process "fake" (current-buffer) "sleep" "10")) + (let* ((inhibit-message noninteractive) + (proc (start-process "fake" (current-buffer) "sleep" "10")) (elt (list :nick "tester!~tester@fake.irc" :type 'GET :peer nil diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el index a4befd96b5..8dd5cef7aa 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-tests.el +++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el @@ -562,6 +562,7 @@ DUMB-SERVER-VAR are bound accordingly in BODY." ;; (erc-server-flood-penalty 0.05) erc-autojoin-channels-alist + erc-after-connect erc-server-auto-reconnect) (should-not erc-d--slow-mo) (with-current-buffer "*erc-d-server*" (erc-d-t-search-for 4 "Starting")) diff --git a/test/lisp/erc/resources/erc-scenarios-common.el b/test/lisp/erc/resources/erc-scenarios-common.el index bc2cb68cd8..ef65125241 100644 --- a/test/lisp/erc/resources/erc-scenarios-common.el +++ b/test/lisp/erc/resources/erc-scenarios-common.el @@ -73,7 +73,7 @@ (require 'erc-d-t) (require 'erc-d))) -(require 'erc-backend) +(require 'erc) (eval-when-compile (require 'erc-join) (require 'erc-services)) @@ -125,6 +125,7 @@ (erc-auth-source-parameters-join-function nil) (erc-autojoin-channels-alist nil) (erc-server-auto-reconnect nil) + (erc-after-connect nil) (erc-d-linger-secs 10) ,@bindings))) commit c5d91358b594e057e37ea557923e6aa9d85b61e1 Author: F. Jason Park Date: Sun Apr 24 06:20:09 2022 -0700 Support auth-source-pass in ERC * doc/misc/erc.texi: Mention that the auth-source-pass backend is supported. * lisp/erc/erc-compat.el (erc-compat--29-auth-source-pass-search, erc-compat--29-auth-source-pass--build-result-many, erc-compat--29-auth-source-pass--retrieve-parsed, erc-compat--29-auth-source-pass-backend-parse, erc-compat--auth-source-backend-parser-functions): Adapt some yet unreleased functions from auth-source-pass that mimic the netrc backend, and add forward declarations to support them. * lisp/erc/erc.el (erc--auth-source-search): Use own auth-source-pass erc-compat backend. * test/lisp/erc/erc-services-tests.el (erc-join-tests--auth-source-pass-entries): Remove useless items. (erc--auth-source-search--pass-standard, erc--auth-source-search--pass-announced, erc--auth-source-search--pass-overrides): Remove `ert-skip' guard. (Bug#58985.) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 3db83197f9..ad35b78f0e 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -861,7 +861,8 @@ The default value for all three options is the function @code{erc-auth-source-search}. It tries to merge relevant contextual parameters with those provided or discovered from the logical connection or the underlying transport. Some auth-source back ends may not be -compatible; netrc, plstore, json, and secrets are currently supported. +compatible; netrc, plstore, json, secrets, and pass are currently +supported. @end defopt @subheading Full name diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 03bd8f1352..5b54a0587a 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -32,6 +32,8 @@ ;;; Code: (require 'compat nil 'noerror) +(eval-when-compile (require 'cl-lib)) + ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode @@ -157,6 +159,121 @@ If START or END is negative, it counts from the end." res)))))) +;;;; Auth Source + +(declare-function auth-source-pass--get-attr + "auth-source-pass" (key entry-data)) +(declare-function auth-source-pass--disambiguate + "auth-source-pass" (host &optional user port)) +(declare-function auth-source-backend-parse-parameters + "auth-source-pass" (entry backend)) +(declare-function auth-source-backend "auth-source" (&rest slots)) +(declare-function auth-source-pass-entries "auth-source-pass" nil) +(declare-function auth-source-pass-parse-entry "auth-source-pass" (entry)) + +(defvar auth-sources) +(defvar auth-source-backend-parser-functions) + +;; This hard codes `auth-source-pass-port-separator' to ":" +(defun erc-compat--29-auth-source-pass--retrieve-parsed (seen e port-number-p) + (when (string-match (rx (or bot "/") + (or (: (? (group-n 20 (+ (not (in " /@")))) "@") + (group-n 10 (+ (not (in " /:@")))) + (? ":" (group-n 30 (+ (not (in " /:")))))) + (: (group-n 11 (+ (not (in " /:@")))) + (? ":" (group-n 31 (+ (not (in " /:"))))) + (? "/" (group-n 21 (+ (not (in " /:"))))))) + eot) + e) + (puthash e `( :host ,(or (match-string 10 e) (match-string 11 e)) + ,@(if-let* ((tr (match-string 21 e))) + (list :user tr :suffix t) + (list :user (match-string 20 e))) + :port ,(and-let* ((p (or (match-string 30 e) + (match-string 31 e))) + (n (string-to-number p))) + (if (or (zerop n) (not port-number-p)) + (format "%s" p) + n))) + seen))) + +;; This looks bad, but it just inlines `auth-source-pass--find-match-many'. +(defun erc-compat--29-auth-source-pass--build-result-many + (hosts users ports require max) + "Return a plist of HOSTS, PORTS, USERS, and secret." + (unless (listp hosts) (setq hosts (list hosts))) + (unless (listp users) (setq users (list users))) + (unless (listp ports) (setq ports (list ports))) + (unless max (setq max 1)) + (let ((seen (make-hash-table :test #'equal)) + (entries (auth-source-pass-entries)) + (check (lambda (m k v) + (let ((mv (plist-get m k))) + (if (memq k require) + (and v (equal mv v)) + (or (not v) (not mv) (equal mv v)))))) + out suffixed suffixedp) + (catch 'done + (dolist (host hosts) + (pcase-let ((`(,_ ,u ,p) (auth-source-pass--disambiguate host))) + (unless (or (not (equal "443" p)) (string-prefix-p "https://" host)) + (setq p nil)) + (dolist (user (or users (list u))) + (dolist (port (or ports (list p))) + (dolist (e entries) + (when-let* + ((m (or (gethash e seen) + (erc-compat--29-auth-source-pass--retrieve-parsed + seen e (integerp port)))) + ((equal host (plist-get m :host))) + ((funcall check m :port port)) + ((funcall check m :user user)) + (parsed (auth-source-pass-parse-entry e)) + (secret (or (auth-source-pass--get-attr 'secret parsed) + (not (memq :secret require))))) + (push + `( :host ,host ; prefer user-provided :host over h + ,@(and-let* ((u (plist-get m :user))) (list :user u)) + ,@(and-let* ((p (plist-get m :port))) (list :port p)) + ,@(and secret (not (eq secret t)) (list :secret secret))) + (if (setq suffixedp (plist-get m :suffix)) suffixed out)) + (unless suffixedp + (when (or (zerop (cl-decf max)) + (null (setq entries (delete e entries)))) + (throw 'done out))))) + (setq suffixed (nreverse suffixed)) + (while suffixed + (push (pop suffixed) out) + (when (zerop (cl-decf max)) + (throw 'done out)))))))) + (reverse out))) + +(cl-defun erc-compat--29-auth-source-pass-search + (&rest spec &key host user port require max &allow-other-keys) + ;; From `auth-source-pass-search' + (cl-assert (and host (not (eq host t))) + t "Invalid password-store search: %s %s") + (erc-compat--29-auth-source-pass--build-result-many + host user port require max)) + +(defun erc-compat--29-auth-source-pass-backend-parse (entry) + (when (eq entry 'password-store) + (auth-source-backend-parse-parameters + entry (auth-source-backend + :source "." + :type 'password-store + :search-function #'erc-compat--29-auth-source-pass-search)))) + +(defun erc-compat--auth-source-backend-parser-functions () + (if (memq 'password-store auth-sources) + (progn + (require 'auth-source-pass) + `(,@(unless (bound-and-true-p auth-source-pass-extra-query-keywords) + '(erc-compat--29-auth-source-pass-backend-parse)) + ,@auth-source-backend-parser-functions)) + auth-source-backend-parser-functions)) + + ;;;; Misc 29.1 (defmacro erc-compat--with-memoization (table &rest forms) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 6b14cf87e2..2d55e698a7 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3225,7 +3225,9 @@ host but different ports would result in the one with port 123 getting the nod. Much the same would happen for entries sharing only a port: the one with host foo would win." (when-let* - ((priority (map-keys defaults)) + ((auth-source-backend-parser-functions + (erc-compat--auth-source-backend-parser-functions)) + (priority (map-keys defaults)) (test (lambda (a b) (catch 'done (dolist (key priority) diff --git a/test/lisp/erc/erc-services-tests.el b/test/lisp/erc/erc-services-tests.el index c22d4cf75e..7ff2e36e77 100644 --- a/test/lisp/erc/erc-services-tests.el +++ b/test/lisp/erc/erc-services-tests.el @@ -474,7 +474,6 @@ ("GNU.chat:irc/#chan" (secret . "foo")))) (ert-deftest erc--auth-source-search--pass-standard () - (ert-skip "Pass backend not yet supported") (let ((store erc-join-tests--auth-source-pass-entries) (auth-sources '(password-store)) (auth-source-do-cache nil)) @@ -487,7 +486,6 @@ (erc-services-tests--auth-source-standard #'erc-auth-source-search)))) (ert-deftest erc--auth-source-search--pass-announced () - (ert-skip "Pass backend not yet supported") (let ((store erc-join-tests--auth-source-pass-entries) (auth-sources '(password-store)) (auth-source-do-cache nil)) @@ -500,7 +498,6 @@ (erc-services-tests--auth-source-announced #'erc-auth-source-search)))) (ert-deftest erc--auth-source-search--pass-overrides () - (ert-skip "Pass backend not yet supported") (let ((store `(,@erc-join-tests--auth-source-pass-entries ("GNU.chat:6697/#chan" (secret . "spam")) commit 2cf9e699ef0fc43a4eadaf00a1ed2f876765c64d Author: F. Jason Park Date: Tue Nov 1 22:46:24 2022 -0700 Make auth-source-pass behave more like other backends * lisp/auth-source-pass.el (auth-source-pass-extra-query-keywords): Add new option to bring search behavior more in line with other backends. (auth-source-pass-search): Add new keyword params `max' and `require' and consider new option `auth-source-pass-extra-query-keywords' for dispatch. (auth-source-pass--match-regexp, auth-source-pass--retrieve-parsed, auth-source-pass--match-parts): Add supporting variable and helpers. (auth-source-pass--build-result-many, auth-source-pass--find-match-many): Add "-many" variants for existing workhorse functions. * test/lisp/auth-source-pass-tests.el: Require `ert-x'. (auth-source-pass-can-start-from-auth-source-search): Ensure `auth-source-pass-extra-query-keywords' is enabled around test body. (auth-source-pass-extra-query-keywords--wild-port-miss-netrc, auth-source-pass-extra-query-keywords--wild-port-miss, auth-source-pass-extra-query-keywords--wild-port-hit-netrc, auth-source-pass-extra-query-keywords--wild-port-hit, auth-source-pass-extra-query-keywords--wild-port-req-miss-netrc, auth-source-pass-extra-query-keywords--wild-port-req-miss, auth-source-pass-extra-query-keywords--netrc-akib, auth-source-pass-extra-query-keywords--akib, auth-source-pass-extra-query-keywords--netrc-host, auth-source-pass-extra-query-keywords--host, auth-source-pass-extra-query-keywords--baseline, auth-source-pass-extra-query-keywords--port-type, auth-source-pass-extra-query-keywords--hosts-first, auth-source-pass-extra-query-keywords--ambiguous-user-host, auth-source-pass-extra-query-keywords--suffixed-user, auth-source-pass-extra-query-keywords--user-priorities): Add juxtaposed netrc and extra-query-keywords pairs to demo optional extra-compliant behavior. * doc/misc/auth.texi: Add option `auth-source-pass-extra-query-keywords' to auth-source-pass section. * etc/NEWS: Mention `auth-source-pass-extra-query-keywords' in Emacs 29.1 package changes section. (Bug#58985.) Special thanks to Akib Azmain Turja for helping improve this patch. diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi index 9dc63af6bc..872e5f88f5 100644 --- a/doc/misc/auth.texi +++ b/doc/misc/auth.texi @@ -526,6 +526,8 @@ If several entries match, the one matching the most items (where an while searching for an entry matching the @code{rms} user on host @code{gnu.org} and port @code{22}, then the entry @file{gnu.org:22/rms.gpg} is preferred over @file{gnu.org.gpg}. +However, such processing is not applied when the option +@code{auth-source-pass-extra-parameters} is set to @code{t}. Users of @code{pass} may also be interested in functionality provided by other Emacs packages: @@ -549,6 +551,22 @@ Set this variable to a string that should separate an host name from a port in an entry. Defaults to @samp{:}. @end defvar +@defvar auth-source-pass-extra-query-keywords +This expands the selection of available keywords to include +@code{:max} and @code{:require} and tells more of them to accept a +list of query parameters as an argument. When searching, it also +favors the @samp{rms@@gnu.org.gpg} form for usernames over the +@samp{gnu.org/rms.gpg} form, regardless of whether a @code{:user} +param was provided. + +In general, if you prefer idiosyncrasies traditionally exhibited by +this backend, such as prioritizing field count in a filename, try +setting this option to @code{nil}. But, if you experience problems +predicting the outcome of searches relative to other auth-source +backends or encounter code expecting to query multiple backends +uniformly, try flipping it back to @code{t} (the default). +@end defvar + @node Help for developers @chapter Help for developers diff --git a/etc/NEWS b/etc/NEWS index e39833a704..1e7190e830 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1395,6 +1395,14 @@ If non-nil and there's only one matching option, auto-select that. If non-nil, this user option describes what entries not to add to the database stored on disk. +** Auth-Source + ++++ +*** New user option 'auth-source-pass-extra-query-keywords'. +Whether to recognize additional keyword params, like ':max' and +':require', as well as accept lists of query terms paired with +applicable keywords. + ** Dired +++ diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el index 0955e2ed07..dc274843e1 100644 --- a/lisp/auth-source-pass.el +++ b/lisp/auth-source-pass.el @@ -55,13 +55,27 @@ :type 'string :version "27.1") +(defcustom auth-source-pass-extra-query-keywords t + "Whether to consider additional keywords when performing a query. +Specifically, when the value is t, recognize the `:max' and +`:require' keywords and accept lists of query parameters for +certain keywords, such as `:host' and `:user'. Also, wrap all +returned secrets in a function and forgo any further results +filtering unless given an applicable `:require' argument. When +this option is nil, do none of that, and enact the narrowing +behavior described toward the bottom of the Info node `(auth) The +Unix password store'." + :type 'boolean + :version "29.1") + (cl-defun auth-source-pass-search (&rest spec &key backend type host user port + require max &allow-other-keys) "Given some search query, return matching credentials. See `auth-source-search' for details on the parameters SPEC, BACKEND, TYPE, -HOST, USER and PORT." +HOST, USER, PORT, REQUIRE, and MAX." (cl-assert (or (null type) (eq type (oref backend type))) t "Invalid password-store search: %s %s") (cond ((eq host t) @@ -70,6 +84,8 @@ HOST, USER and PORT." ((null host) ;; Do not build a result, as none will match when HOST is nil nil) + (auth-source-pass-extra-query-keywords + (auth-source-pass--build-result-many host port user require max)) (t (when-let ((result (auth-source-pass--build-result host port user))) (list result))))) @@ -89,6 +105,39 @@ HOSTS can be a string or a list of strings." (seq-subseq retval 0 -2)) ;; remove password retval)))) +(defvar auth-source-pass--match-regexp nil) + +(defun auth-source-pass--match-regexp (s) + (rx-to-string ; autoloaded + `(: (or bot "/") + (or (: (? (group-n 20 (+ (not (in ?\ ?/ ?@ ,s)))) "@") + (group-n 10 (+ (not (in ?\ ?/ ?@ ,s)))) + (? ,s (group-n 30 (+ (not (in ?\ ?/ ,s)))))) + (: (group-n 11 (+ (not (in ?\ ?/ ?@ ,s)))) + (? ,s (group-n 31 (+ (not (in ?\ ?/ ,s))))) + (? "/" (group-n 21 (+ (not (in ?\ ?/ ,s))))))) + eot) + 'no-group)) + +(defun auth-source-pass--build-result-many (hosts ports users require max) + "Return multiple `auth-source-pass--build-result' values." + (unless (listp hosts) (setq hosts (list hosts))) + (unless (listp users) (setq users (list users))) + (unless (listp ports) (setq ports (list ports))) + (let* ((auth-source-pass--match-regexp (auth-source-pass--match-regexp + auth-source-pass-port-separator)) + (rv (auth-source-pass--find-match-many hosts users ports + require (or max 1)))) + (when auth-source-debug + (auth-source-pass--do-debug "final result: %S" rv)) + (let (out) + (dolist (e rv out) + (when-let* ((s (plist-get e :secret)) ; not captured by closure in 29.1 + (v (auth-source--obfuscate s))) + (setf (plist-get e :secret) + (lambda () (auth-source--deobfuscate v)))) + (push e out))))) + ;;;###autoload (defun auth-source-pass-enable () "Enable auth-source-password-store." @@ -206,6 +255,67 @@ HOSTS can be a string or a list of strings." hosts (list hosts)))) +(defun auth-source-pass--retrieve-parsed (seen path port-number-p) + (when (string-match auth-source-pass--match-regexp path) + (puthash path + `( :host ,(or (match-string 10 path) (match-string 11 path)) + ,@(if-let* ((tr (match-string 21 path))) + (list :user tr :suffix t) + (list :user (match-string 20 path))) + :port ,(and-let* ((p (or (match-string 30 path) + (match-string 31 path))) + (n (string-to-number p))) + (if (or (zerop n) (not port-number-p)) + (format "%s" p) + n))) + seen))) + +(defun auth-source-pass--match-parts (parts key value require) + (let ((mv (plist-get parts key))) + (if (memq key require) + (and value (equal mv value)) + (or (not value) (not mv) (equal mv value))))) + +(defun auth-source-pass--find-match-many (hosts users ports require max) + "Return plists for valid combinations of HOSTS, USERS, PORTS." + (let ((seen (make-hash-table :test #'equal)) + (entries (auth-source-pass-entries)) + out suffixed suffixedp) + (catch 'done + (dolist (host hosts out) + (pcase-let ((`(,_ ,u ,p) (auth-source-pass--disambiguate host))) + (unless (or (not (equal "443" p)) (string-prefix-p "https://" host)) + (setq p nil)) + (dolist (user (or users (list u))) + (dolist (port (or ports (list p))) + (dolist (e entries) + (when-let* + ((m (or (gethash e seen) (auth-source-pass--retrieve-parsed + seen e (integerp port)))) + ((equal host (plist-get m :host))) + ((auth-source-pass--match-parts m :port port require)) + ((auth-source-pass--match-parts m :user user require)) + (parsed (auth-source-pass-parse-entry e)) + ;; For now, ignore body-content pairs, if any, + ;; from `auth-source-pass--parse-data'. + (secret (or (auth-source-pass--get-attr 'secret parsed) + (not (memq :secret require))))) + (push + `( :host ,host ; prefer user-provided :host over h + ,@(and-let* ((u (plist-get m :user))) (list :user u)) + ,@(and-let* ((p (plist-get m :port))) (list :port p)) + ,@(and secret (not (eq secret t)) (list :secret secret))) + (if (setq suffixedp (plist-get m :suffix)) suffixed out)) + (unless suffixedp + (when (or (zerop (cl-decf max)) + (null (setq entries (delete e entries)))) + (throw 'done out))))) + (setq suffixed (nreverse suffixed)) + (while suffixed + (push (pop suffixed) out) + (when (zerop (cl-decf max)) + (throw 'done out)))))))))) + (defun auth-source-pass--disambiguate (host &optional user port) "Return (HOST USER PORT) after disambiguation. Disambiguate between having user provided inside HOST (e.g., diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index f5147a7ce0..8bcb2739bb 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -25,7 +25,7 @@ ;;; Code: -(require 'ert) +(require 'ert-x) (require 'auth-source-pass) @@ -466,7 +466,10 @@ HOSTNAME, USER and PORT are passed unchanged to (ert-deftest auth-source-pass-can-start-from-auth-source-search () (auth-source-pass--with-store '(("gitlab.com" ("user" . "someone"))) (auth-source-pass-enable) - (let ((result (car (auth-source-search :host "gitlab.com")))) + ;; This also asserts an aspect of traditional search behavior + ;; relative to `auth-source-pass-extra-query-keywords'. + (let* ((auth-source-pass-extra-query-keywords nil) + (result (car (auth-source-search :host "gitlab.com")))) (should (equal (plist-get result :user) "someone")) (should (equal (plist-get result :host) "gitlab.com"))))) @@ -488,6 +491,266 @@ HOSTNAME, USER and PORT are passed unchanged to (should (auth-source-pass--have-message-matching "found 2 entries matching \"gitlab.com\": (\"a/gitlab.com\" \"b/gitlab.com\")")))) + +;;;; Option `auth-source-pass-extra-query-keywords' (bug#58985) + +;; No entry has the requested port, but a result is still returned. + +(ert-deftest auth-source-pass-extra-query-keywords--wild-port-miss-netrc () + (ert-with-temp-file netrc-file + :text "\ +machine x.com password a +machine x.com port 42 password b +" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (results (auth-source-search :host "x.com" :port 22 :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results '((:host "x.com" :secret "a"))))))) + +(ert-deftest auth-source-pass-extra-query-keywords--wild-port-miss () + (auth-source-pass--with-store '(("x.com" (secret . "a")) + ("x.com:42" (secret . "b"))) + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host "x.com" :port 22 :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results '((:host "x.com" :secret "a"))))))) + +;; One of two entries has the requested port, both returned. + +(ert-deftest auth-source-pass-extra-query-keywords--wild-port-hit-netrc () + (ert-with-temp-file netrc-file + :text "\ +machine x.com password a +machine x.com port 42 password b +" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (results (auth-source-search :host "x.com" :port 42 :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results '((:host "x.com" :secret "a") + (:host "x.com" :port "42" :secret "b"))))))) + +(ert-deftest auth-source-pass-extra-query-keywords--wild-port-hit () + (auth-source-pass--with-store '(("x.com" (secret . "a")) + ("x.com:42" (secret . "b"))) + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host "x.com" :port 42 :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results + '((:host "x.com" :secret "a") + (:host "x.com" :port 42 :secret "b"))))))) + +;; No entry has the requested port, but :port is required, so search fails. + +(ert-deftest auth-source-pass-extra-query-keywords--wild-port-req-miss-netrc () + (ert-with-temp-file netrc-file + :text "\ +machine x.com password a +machine x.com port 42 password b +" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (results (auth-source-search + :host "x.com" :port 22 :require '(:port) :max 2))) + (should-not results)))) + +(ert-deftest auth-source-pass-extra-query-keywords--wild-port-req-miss () + (let ((auth-source-pass-extra-query-keywords t)) + (auth-source-pass--with-store '(("x.com" (secret . "a")) + ("x.com:42" (secret . "b"))) + (auth-source-pass-enable) + (should-not (auth-source-search + :host "x.com" :port 22 :require '(:port) :max 2))))) + +;; Specifying a :host without a :user finds a lone entry and does not +;; include extra fields (i.e., :port nil) in the result. +;; https://lists.gnu.org/archive/html/emacs-devel/2022-11/msg00130.html + +(ert-deftest auth-source-pass-extra-query-keywords--netrc-akib () + (ert-with-temp-file netrc-file + :text "\ +machine x.com password a +machine disroot.org user akib password b +machine z.com password c +" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (results (auth-source-search :host "disroot.org" :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results + '((:host "disroot.org" :user "akib" :secret "b"))))))) + +(ert-deftest auth-source-pass-extra-query-keywords--akib () + (auth-source-pass--with-store '(("x.com" (secret . "a")) + ("akib@disroot.org" (secret . "b")) + ("z.com" (secret . "c"))) + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host "disroot.org" :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results + '((:host "disroot.org" :user "akib" :secret "b"))))))) + +;; Searches for :host are case-sensitive, and a returned host isn't +;; normalized. + +(ert-deftest auth-source-pass-extra-query-keywords--netrc-host () + (ert-with-temp-file netrc-file + :text "\ +machine libera.chat password a +machine Libera.Chat password b +" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (results (auth-source-search :host "Libera.Chat" :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results '((:host "Libera.Chat" :secret "b"))))))) + +(ert-deftest auth-source-pass-extra-query-keywords--host () + (auth-source-pass--with-store '(("libera.chat" (secret . "a")) + ("Libera.Chat" (secret . "b"))) + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host "Libera.Chat" :max 2))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results + '((:host "Libera.Chat" :secret "b"))))))) + + +;; A retrieved store entry mustn't be nil regardless of whether its +;; path contains port or user components. + +(ert-deftest auth-source-pass-extra-query-keywords--baseline () + (let ((auth-source-pass-extra-query-keywords t)) + (auth-source-pass--with-store '(("x.com")) + (auth-source-pass-enable) + (should-not (auth-source-search :host "x.com"))))) + +;; Output port type (int or string) matches that of input parameter. + +(ert-deftest auth-source-pass-extra-query-keywords--port-type () + (let ((auth-source-pass-extra-query-keywords t) + (f (lambda (r) (setf (plist-get r :secret) (auth-info-password r)) r))) + (auth-source-pass--with-store '(("x.com:42" (secret . "a"))) + (auth-source-pass-enable) + (should (equal (mapcar f (auth-source-search :host "x.com" :port 42)) + '((:host "x.com" :port 42 :secret "a"))))) + (auth-source-pass--with-store '(("x.com:42" (secret . "a"))) + (auth-source-pass-enable) + (should (equal (mapcar f (auth-source-search :host "x.com" :port "42")) + '((:host "x.com" :port "42" :secret "a"))))))) + +;; Match precision sometimes takes a back seat to the traversal +;; ordering. Specifically, the :host (h1, ...) args hold greater sway +;; over the output because they determine the first coordinate in the +;; sequence of (host, user, port) combinations visited. (Taking a +;; tree-wise view, these become the depth-1 nodes in a DFS.) + +;; Note that all trailing /user forms are demoted for the sake of +;; predictability (see tests further below for details). This means +;; that, in the following test, /bar is held in limbo, followed by +;; /foo, but they both retain priority over "gnu.org", as noted above. + +(ert-deftest auth-source-pass-extra-query-keywords--hosts-first () + (auth-source-pass--with-store '(("x.com:42/bar" (secret . "a")) + ("gnu.org" (secret . "b")) + ("x.com" (secret . "c")) + ("fake.com" (secret . "d")) + ("x.com/foo" (secret . "e"))) + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host '("x.com" "gnu.org") :max 3))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results + ;; Notice gnu.org is never considered ^ + '((:host "x.com" :secret "c") + (:host "x.com" :user "bar" :port "42" :secret "a") + (:host "x.com" :user "foo" :secret "e"))))))) + +;; This is another example given in the bug thread. + +(ert-deftest auth-source-pass-extra-query-keywords--ambiguous-user-host () + (auth-source-pass--with-store '(("foo.com/bar.org" (secret . "a")) + ("foo.com" (secret . "b")) + ("bar.org" (secret . "c")) + ("fake.com" (secret . "d"))) + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host "bar.org" :max 3))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results '((:host "bar.org" :secret "c"))))))) + +;; This conveys the same idea as `user-priorities', just below, but +;; with slightly more realistic and less legible values. + +(ert-deftest auth-source-pass-extra-query-keywords--suffixed-user () + (let ((store (sort (copy-sequence '(("x.com:42/bar" (secret . "a")) + ("bar@x.com" (secret . "b")) + ("x.com" (secret . "?")) + ("bar@y.org" (secret . "c")) + ("fake.com" (secret . "?")) + ("fake.com/bar" (secret . "d")) + ("y.org/bar" (secret . "?")) + ("bar@fake.com" (secret . "e")))) + (lambda (&rest _) (zerop (random 2)))))) + (auth-source-pass--with-store store + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host '("x.com" "fake.com" "y.org") + :user "bar" + :require '(:user) :max 5))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results + '((:host "x.com" :user "bar" :secret "b") + (:host "x.com" :user "bar" :port "42" :secret "a") + (:host "fake.com" :user "bar" :secret "e") + (:host "fake.com" :user "bar" :secret "d") + (:host "y.org" :user "bar" :secret "c")))))))) + +;; This is a more distilled version of `suffixed-user', above. It +;; better illustrates that search order takes precedence over "/user" +;; demotion because otherwise * and ** would be swapped, below. It +;; follows that omitting the :port 2, gets you {u@h:1, u@h:2, h:1/u, +;; h:2/u, u@g:1}. + +(ert-deftest auth-source-pass-extra-query-keywords--user-priorities () + (let ((store (sort (copy-sequence '(("h:1/u" (secret . "/")) + ("h:2/u" (secret . "/")) + ("u@h:1" (secret . "@")) + ("u@h:2" (secret . "@")) + ("g:1/u" (secret . "/")) + ("g:2/u" (secret . "/")) + ("u@g:1" (secret . "@")) + ("u@g:2" (secret . "@")))) + (lambda (&rest _) (zerop (random 2)))))) + (auth-source-pass--with-store store + (auth-source-pass-enable) + (let* ((auth-source-pass-extra-query-keywords t) + (results (auth-source-search :host '("h" "g") + :port 2 + :max 5))) + (dolist (result results) + (setf (plist-get result :secret) (auth-info-password result))) + (should (equal results + '((:host "h" :user "u" :port 2 :secret "@") + (:host "h" :user "u" :port 2 :secret "/") ; * + (:host "g" :user "u" :port 2 :secret "@") ; ** + (:host "g" :user "u" :port 2 :secret "/")))))))) + (provide 'auth-source-pass-tests) ;;; auth-source-pass-tests.el ends here commit 0147e1ed831151dddac65727886d5a70bbab9f02 Author: Jim Porter Date: Wed Nov 2 09:22:43 2022 -0700 Enable/disable 'server-mode' when starting/stopping the server * lisp/server.el (server-mode-map): New keymap... (server-mode): ... use it. (server-start): Update the 'server-mode' variable (and sync to 'global-minor-modes') when starting/stopping the server. * test/lisp/server-tests.el: New file (bug#58909). diff --git a/lisp/server.el b/lisp/server.el index 90d97c1538..553890ce29 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -670,7 +670,6 @@ the `server-process' variable." "/tmp/") (ignore-errors (delete-directory (file-name-directory server-file)))))) - (setq server-mode nil) ;; already set by the minor mode code (display-warning 'server (concat "Unable to start the Emacs server.\n" @@ -688,7 +687,9 @@ server or call `\\[server-force-delete]' to forcibly disconnect it.")) (if leave-dead (progn (unless (eq t leave-dead) (server-log (message "Server stopped"))) - (setq server-process nil)) + (setq server-mode nil + global-minor-modes (delq 'server-mode global-minor-modes) + server-process nil)) ;; Make sure there is a safe directory in which to place the socket. (server-ensure-safe-dir server-dir) (when server-process @@ -728,6 +729,8 @@ server or call `\\[server-force-delete]' to forcibly disconnect it.")) :plist '(:authenticated t))))) (unless server-process (error "Could not start server process")) (process-put server-process :server-file server-file) + (setq server-mode t) + (push 'server-mode global-minor-modes) (when server-use-tcp (let ((auth-key (server-get-auth-key))) (process-put server-process :auth-key auth-key) @@ -796,6 +799,10 @@ by the current Emacs process, use the `server-process' variable." t) (file-error nil))) +;; This keymap is empty, but allows users to define keybindings to use +;; when `server-mode' is active. +(defvar-keymap server-mode-map) + ;;;###autoload (define-minor-mode server-mode "Toggle Server mode. @@ -805,6 +812,7 @@ Server mode runs a process that accepts commands from the `server-start' for details." :global t :version "22.1" + :keymap server-mode-map ;; Fixme: Should this check for an existing server socket and do ;; nothing if there is one (for multiple Emacs sessions)? (server-start (not server-mode))) diff --git a/test/lisp/server-tests.el b/test/lisp/server-tests.el new file mode 100644 index 0000000000..351b8ef8d1 --- /dev/null +++ b/test/lisp/server-tests.el @@ -0,0 +1,41 @@ +;;; server-tests.el --- Emacs server test suite -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'server) + +;;; Tests: + +(ert-deftest server-test/server-start-sets-minor-mode () + "Ensure that calling `server-start' also sets `server-mode' properly." + (server-start) + (unwind-protect + (progn + ;; Make sure starting the server activates the minor mode. + (should (eq server-mode t)) + (should (memq 'server-mode global-minor-modes))) + ;; Always stop the server, even if the above checks fail. + (server-start t)) + ;; Make sure stopping the server deactivates the minor mode. + (should (eq server-mode nil)) + (should-not (memq 'server-mode global-minor-modes))) + +;;; server-tests.el ends here commit 7781121c44736a9a5ad0422955f23bfc045f5504 Author: Karl Fogel Date: Wed Nov 16 20:34:28 2022 -0600 Fix two typos in a doc string diff --git a/lisp/bookmark.el b/lisp/bookmark.el index b57ad12986..15e7273f91 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -365,8 +365,8 @@ BOOKMARK-RECORD is, e.g., one element from `bookmark-alist'." (car bookmark-record)) (defun bookmark-type-from-full-record (bookmark-record) - "Return then type of BOOKMARK-RECORD. -BOOKMARK-RECORD is, e.g., one element from `bookmark-alist'. It's + "Return the type of BOOKMARK-RECORD. +BOOKMARK-RECORD is, e.g., one element from `bookmark-alist'. Its type is read from the symbol property named `bookmark-handler-type' read on the record handler function." (let ((handler (bookmark-get-handler bookmark-record))) commit 999027888c781e879838c6190662b8da459ced77 Author: Juanma Barranquero Date: Thu Nov 17 03:15:15 2022 +0100 ; * src/comp.c (Fnative_elisp_load): Fix typo in docstring diff --git a/src/comp.c b/src/comp.c index 14012634cc..d2a2252cf2 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5609,7 +5609,7 @@ file_in_eln_sys_dir (Lisp_Object filename) /* Load related routines. */ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, doc: /* Load native elisp code FILENAME. -LATE_LOAD has to be non-nil when loading for deferred compilation. */) +LATE-LOAD has to be non-nil when loading for deferred compilation. */) (Lisp_Object filename, Lisp_Object late_load) { CHECK_STRING (filename); commit 17075a975ffefa7fc26d4681968a2f8bfe3a9cf2 Author: Thomas Fitzsimmons Date: Wed Nov 16 20:29:26 2022 -0500 EUDC: Fix eudc-capf-message-expand-name nil result * lisp/net/eudc-capf.el (eudc-capf-message-expand-name): Return nil if EUDC query returns no results. (Bug#59314) diff --git a/lisp/net/eudc-capf.el b/lisp/net/eudc-capf.el index 92f0c80493..e2bbd5b28b 100644 --- a/lisp/net/eudc-capf.el +++ b/lisp/net/eudc-capf.el @@ -123,11 +123,12 @@ queried for email addresses, and the results delivered to (match-end 0))) (end (point)) (prefix (save-excursion (buffer-substring-no-properties beg end)))) - (list beg end - (completion-table-with-cache - (lambda (_) - (eudc-query-with-words (split-string prefix "[ \t]+") t)) - t)))))) + (let ((result + (eudc-query-with-words (split-string prefix "[ \t]+") t))) + (when result + (list beg end + (completion-table-with-cache + (lambda (_) result) t)))))))) (provide 'eudc-capf) ;;; eudc-capf.el ends here commit f696d27d1ca8e5fe72cd2cd305f5c00b906a00b1 Author: Stefan Monnier Date: Wed Nov 16 16:35:10 2022 -0500 * src/itree.c: Use more uniform names starting with `itree_` (struct itree_stack, itree_stack_create, itree_stack_destroy) (itree_stack_clear, itree_stack_push_flagged, interval_stack_push) (itree_stack_pop): Rename from `interval_stack*`. (itree_max_height, itree_update_limit, itree_inherit_offset) (itree_propagate_limit, itree_validate, itree_init) (itree_rotate_left, itree_rotate_right, itree_insert_fix) (itree_contains, itree_subtree_min, itree_remove_fix) (itree_replace_child, itree_transplant): Rename from `interval_tree_*`. (itree_insert_node): Rename from `interval_tree_insert`. (itree_node_intersects): Rename from `interval_node_insert`. diff --git a/src/itree.c b/src/itree.c index ae69c97d6d..da0242905c 100644 --- a/src/itree.c +++ b/src/itree.c @@ -155,7 +155,7 @@ nav_flag (nodeptr_and_flag nav) } /* Simple dynamic array. */ -struct interval_stack +struct itree_stack { nodeptr_and_flag *nodes; size_t size; @@ -164,10 +164,10 @@ struct interval_stack /* This is just a simple dynamic array with stack semantics. */ -static struct interval_stack* -interval_stack_create (intmax_t initial_size) +static struct itree_stack* +itree_stack_create (intmax_t initial_size) { - struct interval_stack *stack = xmalloc (sizeof (struct interval_stack)); + struct itree_stack *stack = xmalloc (sizeof (struct itree_stack)); stack->size = max (0, initial_size); stack->nodes = xmalloc (stack->size * sizeof (struct itree_node*)); stack->length = 0; @@ -175,7 +175,7 @@ interval_stack_create (intmax_t initial_size) } static void -interval_stack_destroy (struct interval_stack *stack) +itree_stack_destroy (struct itree_stack *stack) { if (! stack) return; @@ -185,13 +185,13 @@ interval_stack_destroy (struct interval_stack *stack) } static void -interval_stack_clear (struct interval_stack *stack) +itree_stack_clear (struct itree_stack *stack) { stack->length = 0; } static inline void -interval_stack_ensure_space (struct interval_stack *stack, uintmax_t nelements) +itree_stack_ensure_space (struct itree_stack *stack, uintmax_t nelements) { if (nelements > stack->size) { @@ -204,31 +204,31 @@ interval_stack_ensure_space (struct interval_stack *stack, uintmax_t nelements) /* Push NODE on the STACK, while settings its visited flag to FLAG. */ static inline void -interval_stack_push_flagged (struct interval_stack *stack, +itree_stack_push_flagged (struct itree_stack *stack, struct itree_node *node, bool flag) { eassert (node); /* FIXME: While the stack used in the iterator is bounded by the tree depth and could be easily pre-allocated to a large enough size to avoid - this "ensure" check, `interval_stack_push` is also used elsewhere to + this "ensure" check, `itree_stack_push` is also used elsewhere to simply collect some subset of the overlays, where it's only bounded by the total number of overlays in the buffer (which can be large and thus preferably not pre-allocated needlessly). */ - interval_stack_ensure_space (stack, stack->length + 1); + itree_stack_ensure_space (stack, stack->length + 1); stack->nodes[stack->length] = make_nav (node, flag); stack->length++; } static inline void -interval_stack_push (struct interval_stack *stack, struct itree_node *node) +itree_stack_push (struct itree_stack *stack, struct itree_node *node) { - interval_stack_push_flagged (stack, node, false); + itree_stack_push_flagged (stack, node, false); } static inline nodeptr_and_flag -interval_stack_pop (struct interval_stack *stack) +itree_stack_pop (struct itree_stack *stack) { if (stack->length == 0) return make_nav (NULL, false); @@ -241,7 +241,7 @@ interval_stack_pop (struct interval_stack *stack) /* State used when iterating interval. */ struct itree_iterator { - struct interval_stack *stack; + struct itree_stack *stack; ptrdiff_t begin; ptrdiff_t end; @@ -261,7 +261,7 @@ struct itree_iterator static struct itree_iterator *iter = NULL; static int -interval_tree_max_height (const struct itree_tree *tree) +itree_max_height (const struct itree_tree *tree) { return 2 * log (tree->size + 1) / log (2) + 0.5; } @@ -276,9 +276,9 @@ itree_iterator_create (struct itree_tree *tree) FIXME: Since this stack only needs to be about 2*max_depth in the worst case, we could completely pre-allocate it to something like word-bit-size * 2 and then never worry about growing it. */ - const int size = (tree ? interval_tree_max_height (tree) : 19) + 1; + const int size = (tree ? itree_max_height (tree) : 19) + 1; - g->stack = interval_stack_create (size); + g->stack = itree_stack_create (size); g->running = false; g->begin = 0; g->end = 0; @@ -334,7 +334,7 @@ check_subtree (struct itree_node *node, and <= to its parent's otick. Note: we cannot assert that (NODE.otick == NODE.parent.otick) - implies (NODE.offset == 0) because interval_tree_inherit_offset() + implies (NODE.offset == 0) because itree_inherit_offset() doesn't always update otick. It could, but it is not clear there is a need. */ eassert (node->otick <= tree_otick); @@ -438,7 +438,7 @@ itree_newlimit (struct itree_node *node) /* Update NODE's limit attribute according to its children. */ static void -interval_tree_update_limit (struct itree_node *node) +itree_update_limit (struct itree_node *node) { if (node == NULL) return; @@ -453,7 +453,7 @@ interval_tree_update_limit (struct itree_node *node) */ static void -interval_tree_inherit_offset (uintmax_t otick, struct itree_node *node) +itree_inherit_offset (uintmax_t otick, struct itree_node *node) { eassert (node->parent == NULL || node->parent->otick >= node->otick); if (node->otick == otick) @@ -490,7 +490,7 @@ interval_tree_inherit_offset (uintmax_t otick, struct itree_node *node) stable, i.e. new_limit = old_limit. */ static void -interval_tree_propagate_limit (struct itree_node *node) +itree_propagate_limit (struct itree_node *node) { ptrdiff_t newlimit; @@ -511,15 +511,15 @@ interval_tree_propagate_limit (struct itree_node *node) } static struct itree_node* -interval_tree_validate (struct itree_tree *tree, struct itree_node *node) +itree_validate (struct itree_tree *tree, struct itree_node *node) { if (tree->otick == node->otick || node == NULL) return node; if (node != tree->root) - interval_tree_validate (tree, node->parent); + itree_validate (tree, node->parent); - interval_tree_inherit_offset (tree->otick, node); + itree_inherit_offset (tree->otick, node); return node; } @@ -550,7 +550,7 @@ ptrdiff_t itree_node_begin (struct itree_tree *tree, struct itree_node *node) { - interval_tree_validate (tree, node); + itree_validate (tree, node); return node->begin; } @@ -560,7 +560,7 @@ ptrdiff_t itree_node_end (struct itree_tree *tree, struct itree_node *node) { - interval_tree_validate (tree, node); + itree_validate (tree, node); return node->end; } @@ -588,7 +588,7 @@ itree_clear (struct itree_tree *tree) /* Initialize a pre-allocated tree (presumably on the stack). */ static void -interval_tree_init (struct itree_tree *tree) +itree_init (struct itree_tree *tree) { itree_clear (tree); } @@ -613,15 +613,15 @@ itree_size (struct itree_tree *tree) /* Perform the familiar left-rotation on node NODE. */ static void -interval_tree_rotate_left (struct itree_tree *tree, +itree_rotate_left (struct itree_tree *tree, struct itree_node *node) { eassert (node->right != NULL); struct itree_node *right = node->right; - interval_tree_inherit_offset (tree->otick, node); - interval_tree_inherit_offset (tree->otick, right); + itree_inherit_offset (tree->otick, node); + itree_inherit_offset (tree->otick, right); /* Turn right's left subtree into node's right subtree. */ node->right = right->left; @@ -649,22 +649,22 @@ interval_tree_rotate_left (struct itree_tree *tree, node->parent = right; /* Order matters here. */ - interval_tree_update_limit (node); - interval_tree_update_limit (right); + itree_update_limit (node); + itree_update_limit (right); } /* Perform the familiar right-rotation on node NODE. */ static void -interval_tree_rotate_right (struct itree_tree *tree, +itree_rotate_right (struct itree_tree *tree, struct itree_node *node) { eassert (tree && node && node->left != NULL); struct itree_node *left = node->left; - interval_tree_inherit_offset (tree->otick, node); - interval_tree_inherit_offset (tree->otick, left); + itree_inherit_offset (tree->otick, node); + itree_inherit_offset (tree->otick, left); node->left = left->right; if (left->right != NULL) @@ -686,8 +686,8 @@ interval_tree_rotate_right (struct itree_tree *tree, if (node != NULL) node->parent = left; - interval_tree_update_limit (left); - interval_tree_update_limit (node); + itree_update_limit (left); + itree_update_limit (node); } /* Repair the tree after an insertion. @@ -695,7 +695,7 @@ interval_tree_rotate_right (struct itree_tree *tree, Rebalance the parents as needed to re-establish the RB invariants. */ static void -interval_tree_insert_fix (struct itree_tree *tree, +itree_insert_fix (struct itree_tree *tree, struct itree_node *node) { eassert (tree->root->red == false); @@ -729,12 +729,12 @@ interval_tree_insert_fix (struct itree_tree *tree, if (node == node->parent->right) /* case 2.a */ { node = node->parent; - interval_tree_rotate_left (tree, node); + itree_rotate_left (tree, node); } /* case 3.a */ node->parent->red = false; node->parent->parent->red = true; - interval_tree_rotate_right (tree, node->parent->parent); + itree_rotate_right (tree, node->parent->parent); } } else @@ -754,12 +754,12 @@ interval_tree_insert_fix (struct itree_tree *tree, if (node == node->parent->left) /* case 2.b */ { node = node->parent; - interval_tree_rotate_right (tree, node); + itree_rotate_right (tree, node); } /* case 3.b */ node->parent->red = false; node->parent->parent->red = true; - interval_tree_rotate_left (tree, node->parent->parent); + itree_rotate_left (tree, node->parent->parent); } } } @@ -774,7 +774,7 @@ interval_tree_insert_fix (struct itree_tree *tree, Note, that inserting a node twice results in undefined behavior. */ static void -interval_tree_insert (struct itree_tree *tree, struct itree_node *node) +itree_insert_node (struct itree_tree *tree, struct itree_node *node) { eassert (node && node->begin <= node->end); /* FIXME: The assertion below fails because `delete_all_overlays` @@ -794,7 +794,7 @@ interval_tree_insert (struct itree_tree *tree, struct itree_node *node) ancestors limit values. */ while (child != NULL) { - interval_tree_inherit_offset (otick, child); + itree_inherit_offset (otick, child); parent = child; eassert (child->offset == 0); child->limit = max (child->limit, node->end); @@ -827,7 +827,7 @@ interval_tree_insert (struct itree_tree *tree, struct itree_node *node) { node->red = true; eassert (check_tree (tree, false)); /* FIXME: Too expensive. */ - interval_tree_insert_fix (tree, node); + itree_insert_fix (tree, node); } } @@ -838,7 +838,7 @@ itree_insert (struct itree_tree *tree, struct itree_node *node, node->begin = begin; node->end = end; node->otick = tree->otick; - interval_tree_insert (tree, node); + itree_insert_node (tree, node); } /* Safely modify a node's interval. */ @@ -848,26 +848,26 @@ itree_node_set_region (struct itree_tree *tree, struct itree_node *node, ptrdiff_t begin, ptrdiff_t end) { - interval_tree_validate (tree, node); + itree_validate (tree, node); if (begin != node->begin) { itree_remove (tree, node); node->begin = min (begin, PTRDIFF_MAX - 1); node->end = max (node->begin, end); - interval_tree_insert (tree, node); + itree_insert_node (tree, node); } else if (end != node->end) { node->end = max (node->begin, end); eassert (node != NULL); - interval_tree_propagate_limit (node); + itree_propagate_limit (node); } } /* Return true, if NODE is a member of TREE. */ static bool -interval_tree_contains (struct itree_tree *tree, struct itree_node *node) +itree_contains (struct itree_tree *tree, struct itree_node *node) { eassert (iter && node); struct itree_node *other; @@ -891,11 +891,11 @@ itree_limit_is_stable (struct itree_node *node) } static struct itree_node* -interval_tree_subtree_min (uintmax_t otick, struct itree_node *node) +itree_subtree_min (uintmax_t otick, struct itree_node *node) { if (node == NULL) return node; - while ((interval_tree_inherit_offset (otick, node), + while ((itree_inherit_offset (otick, node), node->left != NULL)) node = node->left; return node; @@ -906,7 +906,7 @@ interval_tree_subtree_min (uintmax_t otick, struct itree_node *node) so re-balance the parents to re-establish the RB invariants. */ static void -interval_tree_remove_fix (struct itree_tree *tree, +itree_remove_fix (struct itree_tree *tree, struct itree_node *node, struct itree_node *parent) { @@ -927,7 +927,7 @@ interval_tree_remove_fix (struct itree_tree *tree, { other->red = false; parent->red = true; - interval_tree_rotate_left (tree, parent); + itree_rotate_left (tree, parent); other = parent->right; } eassume (other != NULL); @@ -946,13 +946,13 @@ interval_tree_remove_fix (struct itree_tree *tree, { other->left->red = false; other->red = true; - interval_tree_rotate_right (tree, other); + itree_rotate_right (tree, other); other = parent->right; } other->red = parent->red; /* 4.a */ parent->red = false; other->right->red = false; - interval_tree_rotate_left (tree, parent); + itree_rotate_left (tree, parent); node = tree->root; parent = NULL; } @@ -965,7 +965,7 @@ interval_tree_remove_fix (struct itree_tree *tree, { other->red = false; parent->red = true; - interval_tree_rotate_right (tree, parent); + itree_rotate_right (tree, parent); other = parent->left; } eassume (other != NULL); @@ -984,14 +984,14 @@ interval_tree_remove_fix (struct itree_tree *tree, { other->right->red = false; other->red = true; - interval_tree_rotate_left (tree, other); + itree_rotate_left (tree, other); other = parent->left; } other->red = parent->red; /* 4.b */ parent->red = false; other->left->red = false; - interval_tree_rotate_right (tree, parent); + itree_rotate_right (tree, parent); node = tree->root; parent = NULL; } @@ -1024,7 +1024,7 @@ itree_total_offset (struct itree_node *node) unchanged. Caller is responsible for recalculation of `limit`. Requires both nodes to be using the same effective `offset`. */ static void -interval_tree_replace_child (struct itree_tree *tree, +itree_replace_child (struct itree_tree *tree, struct itree_node *source, struct itree_node *dest) { @@ -1050,11 +1050,11 @@ interval_tree_replace_child (struct itree_tree *tree, recalculation of `limit`. Requires both nodes to be using the same effective `offset`. */ static void -interval_tree_transplant (struct itree_tree *tree, +itree_transplant (struct itree_tree *tree, struct itree_node *source, struct itree_node *dest) { - interval_tree_replace_child (tree, source, dest); + itree_replace_child (tree, source, dest); source->left = dest->left; if (source->left != NULL) source->left->parent = source; @@ -1069,17 +1069,17 @@ interval_tree_transplant (struct itree_tree *tree, struct itree_node* itree_remove (struct itree_tree *tree, struct itree_node *node) { - eassert (interval_tree_contains (tree, node)); + eassert (itree_contains (tree, node)); eassert (check_tree (tree, true)); /* FIXME: Too expensive. */ /* Find `splice`, the leaf node to splice out of the tree. When `node` has at most one child this is `node` itself. Otherwise, it is the in order successor of `node`. */ - interval_tree_inherit_offset (tree->otick, node); + itree_inherit_offset (tree->otick, node); struct itree_node *splice = (node->left == NULL || node->right == NULL) ? node - : interval_tree_subtree_min (tree->otick, node->right); + : itree_subtree_min (tree->otick, node->right); /* Find `subtree`, the only child of `splice` (may be NULL). Note: `subtree` will not be modified other than changing its parent to @@ -1100,7 +1100,7 @@ itree_remove (struct itree_tree *tree, struct itree_node *node) `splice` is black, this creates a red-red violation, so remember this now as the field can be overwritten when splice is transplanted below. */ - interval_tree_replace_child (tree, subtree, splice); + itree_replace_child (tree, subtree, splice); bool removed_black = !splice->red; /* Replace `node` with `splice` in the tree and propagate limit @@ -1109,18 +1109,18 @@ itree_remove (struct itree_tree *tree, struct itree_node *node) has a new child. */ if (splice != node) { - interval_tree_transplant (tree, splice, node); - interval_tree_propagate_limit (subtree_parent); + itree_transplant (tree, splice, node); + itree_propagate_limit (subtree_parent); if (splice != subtree_parent) - interval_tree_update_limit (splice); + itree_update_limit (splice); } - interval_tree_propagate_limit (splice->parent); + itree_propagate_limit (splice->parent); --tree->size; /* Fix any black height violation caused by removing a black node. */ if (removed_black) - interval_tree_remove_fix (tree, subtree, subtree_parent); + itree_remove_fix (tree, subtree, subtree_parent); eassert ((tree->size == 0) == (tree->root == NULL)); eassert (check_tree (tree, true)); /* FIXME: Too expensive. */ @@ -1164,14 +1164,14 @@ itree_iterator_start (struct itree_tree *tree, ptrdiff_t begin, iter->end = end; iter->otick = tree->otick; iter->order = order; - interval_stack_clear (iter->stack); + itree_stack_clear (iter->stack); if (begin <= end && tree->root != NULL) - interval_stack_push_flagged (iter->stack, tree->root, false); + itree_stack_push_flagged (iter->stack, tree->root, false); iter->file = file; iter->line = line; iter->running = true; - /* interval_stack_ensure_space (iter->stack, - 2 * interval_tree_max_height (tree)); */ + /* itree_stack_ensure_space (iter->stack, + 2 * itree_max_height (tree)); */ return iter; } @@ -1210,7 +1210,7 @@ itree_insert_gap (struct itree_tree *tree, order, so we need to remove them first. This doesn't apply for `before_markers` since in that case, all positions move identically regardless of `front_advance` or `rear_advance`. */ - struct interval_stack *saved = interval_stack_create (0); + struct itree_stack *saved = itree_stack_create (0); struct itree_node *node = NULL; if (!before_markers) { @@ -1221,7 +1221,7 @@ itree_insert_gap (struct itree_tree *tree, the overlay is empty, make sure we don't move begin past end by pretending it's !front_advance. */ && (node->begin != node->end || node->rear_advance)) - interval_stack_push (saved, node); + itree_stack_push (saved, node); } } for (size_t i = 0; i < saved->length; ++i) @@ -1231,15 +1231,15 @@ itree_insert_gap (struct itree_tree *tree, narrow AND shift some subtree at the same time. */ if (tree->root != NULL) { - const int size = interval_tree_max_height (tree) + 1; - struct interval_stack *stack = interval_stack_create (size); - interval_stack_push (stack, tree->root); + const int size = itree_max_height (tree) + 1; + struct itree_stack *stack = itree_stack_create (size); + itree_stack_push (stack, tree->root); nodeptr_and_flag nav; - while ((nav = interval_stack_pop (stack), + while ((nav = itree_stack_pop (stack), node = nav_nodeptr (nav))) { /* Process in pre-order. */ - interval_tree_inherit_offset (tree->otick, node); + itree_inherit_offset (tree->otick, node); if (pos > node->limit) continue; if (node->right != NULL) @@ -1251,10 +1251,10 @@ itree_insert_gap (struct itree_tree *tree, ++tree->otick; } else - interval_stack_push (stack, node->right); + itree_stack_push (stack, node->right); } if (node->left != NULL) - interval_stack_push (stack, node->left); + itree_stack_push (stack, node->left); if (before_markers ? node->begin >= pos @@ -1265,16 +1265,16 @@ itree_insert_gap (struct itree_tree *tree, { node->end += length; eassert (node != NULL); - interval_tree_propagate_limit (node); + itree_propagate_limit (node); } } - interval_stack_destroy (stack); + itree_stack_destroy (stack); } /* Reinsert nodes starting at POS having front-advance. */ uintmax_t notick = tree->otick; nodeptr_and_flag nav; - while ((nav = interval_stack_pop (saved), + while ((nav = itree_stack_pop (saved), node = nav_nodeptr (nav))) { eassert (node->otick == ootick); @@ -1283,10 +1283,10 @@ itree_insert_gap (struct itree_tree *tree, node->begin += length; node->end += length; node->otick = notick; - interval_tree_insert (tree, node); + itree_insert_node (tree, node); } - interval_stack_destroy (saved); + itree_stack_destroy (saved); } /* Delete a gap at POS of length LENGTH, contracting all intervals @@ -1303,16 +1303,16 @@ itree_delete_gap (struct itree_tree *tree, /* Can't use the iterator here, because by decrementing begin, we might unintentionally bring shifted nodes back into our search space. */ - const int size = interval_tree_max_height (tree) + 1; - struct interval_stack *stack = interval_stack_create (size); + const int size = itree_max_height (tree) + 1; + struct itree_stack *stack = itree_stack_create (size); struct itree_node *node; - interval_stack_push (stack, tree->root); + itree_stack_push (stack, tree->root); nodeptr_and_flag nav; - while ((nav = interval_stack_pop (stack))) + while ((nav = itree_stack_pop (stack))) { node = nav_nodeptr (nav); - interval_tree_inherit_offset (tree->otick, node); + itree_inherit_offset (tree->otick, node); if (pos > node->limit) continue; if (node->right != NULL) @@ -1324,10 +1324,10 @@ itree_delete_gap (struct itree_tree *tree, ++tree->otick; } else - interval_stack_push (stack, node->right); + itree_stack_push (stack, node->right); } if (node->left != NULL) - interval_stack_push (stack, node->left); + itree_stack_push (stack, node->left); if (pos < node->begin) node->begin = max (pos, node->begin - length); @@ -1335,10 +1335,10 @@ itree_delete_gap (struct itree_tree *tree, { node->end = max (pos , node->end - length); eassert (node != NULL); - interval_tree_propagate_limit (node); + itree_propagate_limit (node); } } - interval_stack_destroy (stack); + itree_stack_destroy (stack); } @@ -1356,7 +1356,7 @@ itree_delete_gap (struct itree_tree *tree, a NODE2 strictly bigger than NODE1 should also be included). */ static inline bool -interval_node_intersects (const struct itree_node *node, +itree_node_intersects (const struct itree_node *node, ptrdiff_t begin, ptrdiff_t end) { return (begin < node->end && node->begin < end) @@ -1388,7 +1388,7 @@ itree_iterator_next (struct itree_iterator *g) { nodeptr_and_flag nav; bool visited; - while ((nav = interval_stack_pop (g->stack), + while ((nav = itree_stack_pop (g->stack), node = nav_nodeptr (nav), visited = nav_flag (nav), node && !visited)) @@ -1396,40 +1396,40 @@ itree_iterator_next (struct itree_iterator *g) struct itree_node *const left = node->left; struct itree_node *const right = node->right; - interval_tree_inherit_offset (g->otick, node); + itree_inherit_offset (g->otick, node); eassert (itree_limit_is_stable (node)); switch (g->order) { case ITREE_ASCENDING: if (right != null && node->begin <= g->end) - interval_stack_push_flagged (g->stack, right, false); - if (interval_node_intersects (node, g->begin, g->end)) - interval_stack_push_flagged (g->stack, node, true); + itree_stack_push_flagged (g->stack, right, false); + if (itree_node_intersects (node, g->begin, g->end)) + itree_stack_push_flagged (g->stack, node, true); /* Node's children may still be off-set and we need to add it. */ if (left != null && g->begin <= left->limit + left->offset) - interval_stack_push_flagged (g->stack, left, false); + itree_stack_push_flagged (g->stack, left, false); break; case ITREE_DESCENDING: if (left != null && g->begin <= left->limit + left->offset) - interval_stack_push_flagged (g->stack, left, false); - if (interval_node_intersects (node, g->begin, g->end)) - interval_stack_push_flagged (g->stack, node, true); + itree_stack_push_flagged (g->stack, left, false); + if (itree_node_intersects (node, g->begin, g->end)) + itree_stack_push_flagged (g->stack, node, true); if (right != null && node->begin <= g->end) - interval_stack_push_flagged (g->stack, right, false); + itree_stack_push_flagged (g->stack, right, false); break; case ITREE_PRE_ORDER: if (right != null && node->begin <= g->end) - interval_stack_push_flagged (g->stack, right, false); + itree_stack_push_flagged (g->stack, right, false); if (left != null && g->begin <= left->limit + left->offset) - interval_stack_push_flagged (g->stack, left, false); - if (interval_node_intersects (node, g->begin, g->end)) - interval_stack_push_flagged (g->stack, node, true); + itree_stack_push_flagged (g->stack, left, false); + if (itree_node_intersects (node, g->begin, g->end)) + itree_stack_push_flagged (g->stack, node, true); break; } } /* Node may have been invalidated by itree_iterator_narrow after it was pushed: Check if it still intersects. */ - } while (node && ! interval_node_intersects (node, g->begin, g->end)); + } while (node && ! itree_node_intersects (node, g->begin, g->end)); return node; } commit 1772d88c1fa811eee235ba9b8b7584bb000ac293 Author: Stephen Leake Date: Wed Nov 16 09:52:09 2022 -0800 Call xref--analyze with correct project * lisp/progmodes/xref.el (xref-show-definitions-buffer-at-bottom): Call xref--analyze with correct project. diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index bb36688ef8..89a090ae93 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1237,16 +1237,21 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'." (max-height (/ (window-height) 2)) (size-fun (lambda (window) (fit-window-to-buffer window max-height))) + xref-alist buf) (cond ((not (cdr xrefs)) (xref-pop-to-location (car xrefs) (assoc-default 'display-action alist))) (t + ;; Call it here because it can call (project-current), and that + ;; might depend on individual buffer, not just directory. + (setq xref-alist (xref--analyze xrefs)) + (with-current-buffer (get-buffer-create xref-buffer-name) (xref--ensure-default-directory dd (current-buffer)) (xref--transient-buffer-mode) - (xref--show-common-initialize (xref--analyze xrefs) fetcher alist) + (xref--show-common-initialize xref-alist fetcher alist) (pop-to-buffer (current-buffer) `(display-buffer-in-direction . ((direction . below) (window-height . ,size-fun)))) commit f793add1758fd01f678698a90f5847b575f63cf8 Author: Gabriel do Nascimento Ribeiro Date: Tue Nov 15 19:42:01 2022 -0300 Add flat-button to docstring of 'set-face-attribute' * lisp/faces.el (set-face-attribute): Add 'flat-button' to COLOR and STYLE sections of docstring. (Bug#59266) diff --git a/lisp/faces.el b/lisp/faces.el index 09e8110449..5ae1c65a4d 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -787,13 +787,12 @@ specified below. WIDTH specifies the width of the lines to draw; it defaults to 1. If WIDTH is negative, the absolute value is the width of the lines, and draw top/bottom lines inside the characters area, not around it. COLOR is the name of the color to draw in, default is -the foreground color of the face for simple boxes, and the background -color of the face for 3D boxes. STYLE specifies whether a 3D box -should be draw. If STYLE is `released-button', draw a box looking -like a released 3D button. If STYLE is `pressed-button' draw a box -that appears like a pressed button. If STYLE is nil, the default if -the property list doesn't contain a style specification, draw a 2D -box. +the background color of the face for 3D boxes and `flat-button', and +the foreground color of the face for other boxes. STYLE specifies +whether a 3D box should be draw. If STYLE is `released-button', draw +a box looking like a released 3D button. If STYLE is `pressed-button' +draw a box that appears like a pressed button. If STYLE is nil, +`flat-button' or omitted, draw a 2D box. `:inverse-video' commit 0a26b2621752ada1a43992ee7391b1c56bd6a6b0 Author: Eli Zaretskii Date: Wed Nov 16 16:37:23 2022 +0200 Reduce buffer-tests noisiness even more * test/src/buffer-tests.el (test-kill-buffer-auto-save-default) (test-kill-buffer-auto-save-delete-yes) (test-kill-buffer-auto-save-delete-no) (test-buffer-modifications, test-restore-buffer-modified-p): Shut up auto-save messages. (Bug#59028) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 2b6c974159..0e6d717cbb 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -8422,7 +8422,7 @@ Finally, kill the buffer and its temporary file." (insert "foo\n") (should buffer-auto-save-file-name) (setq auto-save buffer-auto-save-file-name) - (do-auto-save) + (do-auto-save t) (should (file-exists-p auto-save)) (kill-buffer (current-buffer)) (should (file-exists-p auto-save))))))) @@ -8437,7 +8437,7 @@ Finally, kill the buffer and its temporary file." (insert "foo\n") (should buffer-auto-save-file-name) (setq auto-save buffer-auto-save-file-name) - (do-auto-save) + (do-auto-save t) (should (file-exists-p auto-save)) ;; This should delete the auto-save file. (kill-buffer (current-buffer)) @@ -8453,7 +8453,7 @@ Finally, kill the buffer and its temporary file." (insert "foo\n") (should buffer-auto-save-file-name) (setq auto-save buffer-auto-save-file-name) - (do-auto-save) + (do-auto-save t) (should (file-exists-p auto-save)) ;; This should not delete the auto-save file. (kill-buffer (current-buffer)) @@ -8468,7 +8468,7 @@ Finally, kill the buffer and its temporary file." (insert "foo") (should (buffer-modified-p)) (should-not (eq (buffer-modified-p) 'autosaved)) - (do-auto-save nil t) + (do-auto-save t t) (should (eq (buffer-modified-p) 'autosaved)) (with-silent-modifications (put-text-property 1 3 'face 'bold)) @@ -8492,7 +8492,7 @@ Finally, kill the buffer and its temporary file." (restore-buffer-modified-p nil) (should-not (buffer-modified-p)) (insert "bar") - (do-auto-save nil t) + (do-auto-save t t) (should (eq (buffer-modified-p) 'autosaved)) (insert "zot") (restore-buffer-modified-p 'autosaved) commit aee4d67b097910a13cf371e96f697a966a4c0869 Author: Matt Armstrong Date: Tue Nov 15 10:33:00 2022 -0800 Reduce buffer-tests noisiness when run in batch mode. * test/src/buffer-tests.el (overlay-modification-hooks): Remove noisy `message' calls and use `ert-info' to log context of test failures. (bug#59028) (overlay-tests-start-recording-modification-hooks): ditto. diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 3fc52eaf8b..2b6c974159 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -42,7 +42,6 @@ recorded calls conveniently." overlay hooks-property (list (lambda (ov &rest args) - (message " %S called on %S with args %S" hooks-property ov args) (should inhibit-modification-hooks) (should (eq ov overlay)) (push (list hooks-property args) @@ -175,47 +174,41 @@ properties." (t 1 2 0)) (insert-behind-hooks (t 1 2 0))))))) - (message "BEGIN overlay-modification-hooks test-case %S" test-case) - - ;; All three hooks ignore the overlay's `front-advance' and - ;; `rear-advance' option, so test both ways while expecting the same - ;; result. - (dolist (advance '(nil t)) - (message " advance is %S" advance) - (let-alist test-case - (with-temp-buffer - ;; Set up the temporary buffer and overlay as specified by - ;; the test case. - (insert (or .buffer-text "1234")) - (let ((overlay (make-overlay - (or .overlay-beg 2) - (or .overlay-end 4) - nil - advance advance))) - (message " (buffer-string) is %S" (buffer-string)) - (message " overlay is %S" overlay) - (overlay-tests-start-recording-modification-hooks overlay) - - ;; Modify the buffer, possibly inducing calls to the - ;; overlay's modification hooks. - (should (or .insert-at .replace)) - (when .insert-at - (goto-char .insert-at) - (insert "x") - (message " inserted \"x\" at %S, buffer-string now %S" - .insert-at (buffer-string))) - (when .replace - (goto-char (point-min)) - (search-forward .replace) - (replace-match "x") - (message " replaced %S with \"x\"" .replace)) - - ;; Verify that the expected and actual modification hook - ;; calls match. - (should (equal - .expected-calls - (overlay-tests-get-recorded-modification-hooks - overlay))))))))) + (ert-info ((format "test-case: %S" test-case)) + ;; All three hooks ignore the overlay's `front-advance' and + ;; `rear-advance' option, so test both ways while expecting the same + ;; result. + (dolist (advance '(nil t)) + (ert-info ((format "advance is %S" advance)) + (let-alist test-case + (with-temp-buffer + ;; Set up the temporary buffer and overlay as specified by + ;; the test case. + (insert (or .buffer-text "1234")) + (let ((overlay (make-overlay + (or .overlay-beg 2) + (or .overlay-end 4) + nil + advance advance))) + (overlay-tests-start-recording-modification-hooks overlay) + + ;; Modify the buffer, possibly inducing calls to the + ;; overlay's modification hooks. + (should (or .insert-at .replace)) + (when .insert-at + (goto-char .insert-at) + (insert "x")) + (when .replace + (goto-char (point-min)) + (search-forward .replace) + (replace-match "x")) + + ;; Verify that the expected and actual modification hook + ;; calls match. + (should (equal + .expected-calls + (overlay-tests-get-recorded-modification-hooks + overlay))))))))))) (ert-deftest overlay-modification-hooks-message-other-buf () "Test for bug#21824. commit 4cf97969e6bb6f47c5b6ad4ca2afc2370abd6212 Author: Eli Zaretskii Date: Wed Nov 16 16:13:45 2022 +0200 ; * lisp/apropos.el (apropos): Doc fix. (Bug#59248) diff --git a/lisp/apropos.el b/lisp/apropos.el index 62a37df820..d9d8f4c372 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -651,7 +651,8 @@ while a list of strings is used as a word list." (defun apropos (pattern &optional do-all) "Show all meaningful Lisp symbols whose names match PATTERN. Symbols are shown if they are defined as functions, variables, or -faces, or if they have nonempty property lists. +faces, or if they have nonempty property lists, or if they are +known keywords. PATTERN can be a word, a list of words (separated by spaces), or a regexp (using some regexp special characters). If it is a word, commit 277504584d4cf7b3d67cd4a8cae1849b6cc700fc Author: Philip Kaludercic Date: Wed Nov 16 09:16:28 2022 +0100 Set vc-prepare-patches-separately to nil in .dir-locals.el * .dir-locals.el (c-mode): Set 'vc-prepare-patches-separately'. See https://lists.gnu.org/archive/html/emacs-devel/2022-11/msg00973.html. diff --git a/.dir-locals.el b/.dir-locals.el index a85769b534..f0ab46236f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -7,7 +7,8 @@ (emacs-lisp-docstring-fill-column . 65) (vc-git-annotate-switches . "-w") (bug-reference-url-format . "https://debbugs.gnu.org/%s") - (diff-add-log-use-relative-names . t))) + (diff-add-log-use-relative-names . t) + (vc-prepare-patches-separately . nil))) (c-mode . ((c-file-style . "GNU") (c-noise-macro-names . ("INLINE" "NO_INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "UNINIT" "CALLBACK" "ALIGN_STACK"))