commit b5d36efa5777e4cc6db1067d58224d676cedbdd3 (HEAD, refs/remotes/origin/master) Author: Spencer Baugh Date: Wed Jan 24 11:10:40 2024 -0500 Update minibuffer-show-help based on minibuffer-visible-completions minibuffer-visible-completions makes some more convenient bindings available, but the help shown by minibuffer-show-help wasn't suggesting them. Now it is. * lisp/simple.el (completion-setup-function): Change help text when minibuffer-visible-completions is non-nil. (bug#68689) diff --git a/lisp/simple.el b/lisp/simple.el index 4ffe159dc88..1157bd578fd 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -10335,13 +10335,27 @@ Called from `temp-buffer-show-hook'." ;; Maybe insert help string. (when completion-show-help (goto-char (point-min)) - (insert (substitute-command-keys - (if (display-mouse-p) - "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n" - "Type \\[minibuffer-choose-completion] on a completion to select it.\n"))) - (insert (substitute-command-keys - "Type \\[minibuffer-next-completion] or \\[minibuffer-previous-completion] \ -to move point between completions.\n\n")))))) + (if minibuffer-visible-completions + (let ((helps + (with-current-buffer (window-buffer (active-minibuffer-window)) + (list + (substitute-command-keys + (if (display-mouse-p) + "Click or type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n" + "Type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n")) + (substitute-command-keys + "Type \\[minibuffer-next-completion], \\[minibuffer-previous-completion], \ +\\[minibuffer-next-line-completion], \\[minibuffer-previous-line-completion] \ +to move point between completions.\n\n"))))) + (dolist (help helps) + (insert help))) + (insert (substitute-command-keys + (if (display-mouse-p) + "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n" + "Type \\[minibuffer-choose-completion] on a completion to select it.\n"))) + (insert (substitute-command-keys + "Type \\[minibuffer-next-completion] or \\[minibuffer-previous-completion] \ +to move point between completions.\n\n"))))))) (add-hook 'completion-setup-hook #'completion-setup-function) commit 28c9c7cf464c87e90567f8b0e04f854163aa6187 Author: Spencer Baugh Date: Wed Jan 24 10:52:40 2024 -0500 Fix next-line-completion for multi-line completions Previously it would not move out of a multi-line completion, and now it will. * lisp/simple.el (next-line-completion): Move to the completion start or end before going forward or backward lines. (bug#68688) diff --git a/lisp/simple.el b/lisp/simple.el index 692c0dacefc..4ffe159dc88 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9940,6 +9940,20 @@ Also see the `completion-auto-wrap' variable." (interactive "p") (next-completion (- n))) +(defun completion--move-to-candidate-start () + "If in a completion candidate, move point to its start." + (when (and (get-text-property (point) 'mouse-face) + (not (bobp)) + (get-text-property (1- (point)) 'mouse-face)) + (goto-char (previous-single-property-change (point) 'mouse-face)))) + +(defun completion--move-to-candidate-end () + "If in a completion candidate, move point to its end." + (when (and (get-text-property (point) 'mouse-face) + (not (eobp)) + (get-text-property (1+ (point)) 'mouse-face)) + (goto-char (or (next-single-property-change (point) 'mouse-face) (point-max))))) + (defun next-completion (n) "Move to the next item in the completions buffer. With prefix argument N, move N items (negative N means move @@ -10029,9 +10043,7 @@ Also see the `completion-auto-wrap' variable." (if (get-text-property (point) 'mouse-face) ;; If in a completion, move to the start of it. - (when (and (not (bobp)) - (get-text-property (1- (point)) 'mouse-face)) - (goto-char (previous-single-property-change (point) 'mouse-face))) + (completion--move-to-candidate-start) ;; Try to move to the previous completion. (setq pos (previous-single-property-change (point) 'mouse-face)) (if pos @@ -10046,6 +10058,7 @@ Also see the `completion-auto-wrap' variable." (while (> n 0) (setq found nil pos nil column (current-column) line (line-number-at-pos)) + (completion--move-to-candidate-end) (while (and (not found) (eq (forward-line 1) 0) (not (eobp)) @@ -10070,6 +10083,7 @@ Also see the `completion-auto-wrap' variable." (while (< n 0) (setq found nil pos nil column (current-column) line (line-number-at-pos)) + (completion--move-to-candidate-start) (while (and (not found) (eq (forward-line -1) 0) (eq (move-to-column column) column)) diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index c1fe3032cb5..d104858b0d0 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -465,6 +465,20 @@ (previous-line-completion 4) (should (equal "ac" (get-text-property (point) 'completion--string)))))) +(ert-deftest completion-next-line-multline-test () + (let ((completion-auto-wrap t)) + (completing-read-with-minibuffer-setup + '("a\na" "a\nb" "ac") + (insert "a") + (minibuffer-completion-help) + (switch-to-completions) + (goto-char (point-min)) + (next-line-completion 5) + (should (equal "a\nb" (get-text-property (point) 'completion--string))) + (goto-char (point-min)) + (previous-line-completion 5) + (should (equal "a\nb" (get-text-property (point) 'completion--string)))))) + (ert-deftest completions-header-format-test () (let ((completion-show-help nil) (completions-header-format nil)) commit 1ba8d1c43702cf8ddd5d7159401d7b3ebc51f4fe Author: Corwin Brust Date: Fri Jan 19 23:51:36 2024 -0600 Add more erc-message-type choices * lisp/erc/erc.el (erc-message-type): Add more of the possible IRC message types to customize widget for `erc-*hide-list'. New options have tags informed by these descriptions: https://modern.ircdocs.horse/#numerics (Bug#68601) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 0da211a5f28..edac1060c3e 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -386,6 +386,16 @@ If nil, only \"> \" will be shown." (const "PART") (const "QUIT") (const "MODE") + (const :tag "Away notices (RPL_AWAY 301)" "301") + (const :tag "Self back notice (REP_UNAWAY 305)" "305") + (const :tag "Self away notice (REP_NOWAWAY 306)" "306") + (const :tag "Channel modes on join (RPL_CHANNELMODEIS 324)" "324") + (const :tag "Channel creation time (RPL_CREATIONTIME 329)" "329") + (const :tag "Channel no-topic on join (RPL_NOTOPIC 331)" "331") + (const :tag "Channel topic on join (RPL_TOPIC 332)" "332") + (const :tag "Topic author and time on join (RPL_TOPICWHOTIME 333)" "333") + (const :tag "Invitation success notice (RPL_INVITING 341)" "341") + (const :tag "Channel member names (353 RPL_NAMEREPLY)" "353") (repeat :inline t :tag "Others" (string :tag "IRC Message Type")))) (defcustom erc-hide-list nil commit d6be068ffe8c151575ea784ce508711b41cec7c5 Author: F. Jason Park Date: Mon Jan 1 06:37:25 2024 -0800 Add replacement-text field to erc-input struct * etc/ERC-NEWS: Promote `refoldp' slot from simulated to real. Mention new `substxt' slot of `erc-input' struct. * lisp/erc/erc-common.el (erc-input): Add `substxt' and `refoldp' slots. (erc--input-split): Move `refoldp' to "superclass". * lisp/erc/erc-goodies.el (erc--command-indicator-permit-insertion): Use `substxt' field instead of overloading `insertp'. (erc--command-indicator-display): Accept extra lines for compatibility. * lisp/erc/erc.el (erc-pre-send-functions): Revise doc. (erc--input-ensure-hook-context, erc-input-refoldp): Remove unused functions, originally meant to be new in ERC 5.6. (erc--run-send-hooks): Copy data from additional fields of `erc-input' object to `erc--input-split' workspace object. (erc--send-input-lines): Handle `substxt' field of `erc-input' object when it's non-nil. (Bug#68265) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index b673d36220a..f91d3fcb351 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -581,9 +581,17 @@ ERC now adjusts input lines to fall within allowed length limits before showing hook members the result. For compatibility, third-party code can request that the final input be adjusted again prior to being sent. To facilitate this, the 'erc-input' object -shared among hook members has gained a "phony" 'refoldp' slot that's -only accessible from 'erc-pre-send-functions'. See doc string for -details. +shared among hook members has gained a 'refoldp' slot. See doc string +for details. + +*** More flexibility in sending and displaying prompt input. +The abnormal hook 'erc-pre-send-functions' previously married outgoing +message text to its inserted representation in an ERC target buffer. +Going forward, users can populate the new slot 'substxt' with +alternate text to insert in place of the 'string' slot's contents, +which ERC still sends to the server. This dichotomy lets users +completely avoid the often fiddly 'erc-send-modify-hook' and friends +for use cases like language translation and subprotocol encoding. *** ERC's prompt survives the insertion of user input and messages. Previously, ERC's prompt and its input marker disappeared while diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index e39e414b290..abcdc4c8843 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -50,7 +50,23 @@ (declare-function widget-type "wid-edit" (widget)) (cl-defstruct erc-input - string insertp sendp) + "Object shared among members of `erc-pre-send-functions'. +Any use outside of the hook is not supported." + ( string "" :type string + :documentation "String to send and, without `substxt', insert. +ERC treats separate lines as separate messages.") + ( insertp nil :type boolean + :documentation "Whether to insert outgoing message. +When nil, ERC still sends `string'.") + ( sendp nil :type boolean + :documentation "Whether to send and (for compat reasons) insert. +To insert without sending, define a (slash) command.") + ( substxt nil :type (or function string null) + :documentation "Alternate string to insert without splitting. +The function form is for internal use.") + ( refoldp nil :type boolean + :documentation "Whether to resplit a possibly overlong `string'. +ERC only refolds `string', never `substxt'.")) (cl-defstruct (erc--input-split (:include erc-input (string "" :read-only t) @@ -58,7 +74,6 @@ (sendp (with-suppressed-warnings ((obsolete erc-send-this)) erc-send-this)))) - (refoldp nil :type boolean) (lines nil :type (list-of string)) (abortp nil :type (list-of symbol)) (cmdp nil :type boolean)) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index bf361ff91fb..8293994c5d4 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -583,15 +583,18 @@ Do nothing if the variable `erc-command-indicator' is nil." "Insert `erc-input' STATE's message if it's an echoed command." (cl-assert erc-command-indicator-mode) (when (erc--input-split-cmdp state) - (setf (erc--input-split-insertp state) #'erc--command-indicator-display) + (setf (erc--input-split-insertp state) t + (erc--input-split-substxt state) #'erc--command-indicator-display) (erc-send-distinguish-noncommands state))) ;; This function used to be called `erc-display-command'. It was ;; neutered in ERC 5.3.x (Emacs 24.5), commented out in 5.4, removed ;; in 5.5, and restored in 5.6. -(defun erc--command-indicator-display (line) +(defun erc--command-indicator-display (line &rest rest) "Insert command LINE as echoed input resembling that of REPLs and shells." (when erc-insert-this + (when rest + (setq line (string-join (cons line rest) "\n"))) (save-excursion (erc--assert-input-bounds) (let ((insert-position (marker-position (goto-char erc-insert-marker))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index fc6f51950e2..0da211a5f28 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1235,30 +1235,30 @@ anyway." (make-obsolete-variable 'erc-send-pre-hook 'erc-pre-send-functions "27.1") (defcustom erc-pre-send-functions nil - "Special hook run to possibly alter the string that is sent. -The functions are called with one argument, an `erc-input' struct, -and should alter that struct. + "Special hook to possibly alter the string to send and insert. +ERC calls the member functions with one argument, an `erc-input' +struct instance to modify as needed. -The struct has three slots: - - `string': The current input string. - `insertp': Whether the string should be inserted into the erc buffer. - `sendp': Whether the string should be sent to the irc server. - -And one \"phony\" slot only accessible by hook members at runtime: +The struct has five slots: - `refoldp': Whether the string should be re-split per protocol limits. + `string': String to send, originally from prompt input. + `insertp': Whether a string should be inserted in the buffer. + `sendp': Whether `string' should be sent to the IRC server. + `substxt': String to display (but not send) instead of `string'. + `refoldp': Whether to re-split `string' per protocol limits. This hook runs after protocol line splitting has taken place, so -the value of `string' is originally \"pre-filled\". If you need -ERC to refill the entire payload before sending it, set the phony -`refoldp' slot to a non-nil value. Note that this refilling is -only a convenience, and modules with special needs, such as -preserving \"preformatted\" text or encoding for subprotocol -\"tunneling\", should handle splitting manually." - :group 'erc - :type 'hook - :version "27.1") +the value of `string' comes \"pre-split\" according to the option +`erc-split-line-length'. If you need ERC to refill the entire +payload before sending it, set the `refoldp' slot to a non-nil +value. Note that this refilling is only a convenience, and +modules with special needs, such as preserving \"preformatted\" +text or encoding for subprotocol \"tunneling\", should handle +splitting manually and possibly also specify replacement text to +display via the `substxt' slot." + :package-version '(ERC . "5.3") + :group 'erc-hooks + :type 'hook) (define-obsolete-variable-alias 'erc--pre-send-split-functions 'erc--input-review-functions "30.1") @@ -7899,22 +7899,6 @@ When all lines are empty, remove all but the first." (setf (erc--input-split-lines state) (mapcan #'erc--split-line (erc--input-split-lines state))))) -(defun erc--input-ensure-hook-context () - (unless (erc--input-split-p erc--current-line-input-split) - (error "Invoked outside of `erc-pre-send-functions'"))) - -(defun erc-input-refoldp (_) - "Impersonate accessor for phony `erc-input' `refoldp' slot. -This function only works inside `erc-pre-send-functions' members." - (declare (gv-setter (lambda (v) - `(progn - (erc--input-ensure-hook-context) - (setf (erc--input-split-refoldp - erc--current-line-input-split) - ,v))))) - (erc--input-ensure-hook-context) - (erc--input-split-refoldp erc--current-line-input-split)) - (defun erc--run-send-hooks (lines-obj) "Run send-related hooks that operate on the entire prompt input. Sequester some of the back and forth involved in honoring old @@ -7932,12 +7916,17 @@ queue. Expect LINES-OBJ to be an `erc--input-split' object." (state (progn ;; This may change `str' and `erc-*-this'. (run-hook-with-args 'erc-send-pre-hook str) - (make-erc-input :string str - :insertp erc-insert-this - :sendp erc-send-this)))) + (make-erc-input + :string str + :insertp erc-insert-this + :sendp erc-send-this + :substxt (erc--input-split-substxt lines-obj) + :refoldp (erc--input-split-refoldp lines-obj))))) (run-hook-with-args 'erc-pre-send-functions state) (setf (erc--input-split-sendp lines-obj) (erc-input-sendp state) (erc--input-split-insertp lines-obj) (erc-input-insertp state) + (erc--input-split-substxt lines-obj) (erc-input-substxt state) + (erc--input-split-refoldp lines-obj) (erc-input-refoldp state) ;; See note in test of same name re trailing newlines. (erc--input-split-lines lines-obj) (let ((lines (split-string (erc-input-string state) @@ -7955,15 +7944,19 @@ queue. Expect LINES-OBJ to be an `erc--input-split' object." (defun erc--send-input-lines (lines-obj) "Send lines in `erc--input-split-lines' object LINES-OBJ." (when (erc--input-split-sendp lines-obj) - (dolist (line (erc--input-split-lines lines-obj)) - (when (erc--input-split-insertp lines-obj) - (if (eq (erc--input-split-insertp lines-obj) - 'erc--command-indicator-display) - (funcall (erc--input-split-insertp lines-obj) line) - (erc-display-msg line))) - (erc-process-input-line (concat line "\n") - (null erc-flood-protect) - (not (erc--input-split-cmdp lines-obj)))))) + (let ((insertp (erc--input-split-insertp lines-obj)) + (substxt (erc--input-split-substxt lines-obj))) + (when (and insertp substxt) + (setq insertp nil) + (if (functionp substxt) + (apply substxt (erc--input-split-lines lines-obj)) + (erc-display-msg substxt))) + (dolist (line (erc--input-split-lines lines-obj)) + (when insertp + (erc-display-msg line)) + (erc-process-input-line (concat line "\n") + (null erc-flood-protect) + (not (erc--input-split-cmdp lines-obj))))))) (defun erc-send-input (input &optional skip-ws-chk) "Treat INPUT as typed in by the user. commit aae131b8dd9ab3c3ceb23079796005873e107bee Author: F. Jason Park Date: Tue Jan 16 10:42:21 2024 -0800 Force erc-speedbar to update on insertion * lisp/erc/erc-speedbar.el (erc-speedbar--force-update-interval-secs, erc-speedbar--last-ran): New variables. (erc-speedbar--reset-last-ran-on-timer, erc-speedbar--run-timer-on-post-insert): New functions. (erc-nickbar-mode, erc-nickbar-enable, erc-nickbar-disable): Use `erc-insert-post-hook' and `speedbar-timer-hook' to update the speedbar periodically. (Bug#63595) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 5fcea056e3e..e3d28aa60dd 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -545,6 +545,29 @@ The INDENT level is ignored." (speedbar-set-mode-line-format)))) (defvar erc-speedbar--shutting-down-p nil) +(defvar erc-speedbar--force-update-interval-secs 5 "Speedbar update period.") + +(defvar-local erc-speedbar--last-ran nil + "When non-nil, a lisp timestamp updated when the speedbar timer runs.") + +(defun erc-speedbar--run-timer-on-post-insert () + "Refresh speedbar if idle for `erc-speedbar--force-update-interval-secs'." + (when speedbar-buffer + (with-current-buffer speedbar-buffer + (when-let + ((dframe-timer) + ((erc--check-msg-prop 'erc--cmd 'PRIVMSG)) + (interval erc-speedbar--force-update-interval-secs) + ((or (null erc-speedbar--last-ran) + (time-less-p erc-speedbar--last-ran + (time-subtract (current-time) interval))))) + (run-at-time 0 nil #'dframe-timer-fn))))) + +(defun erc-speedbar--reset-last-ran-on-timer () + "Reset `erc-speedbar--last-ran'." + (when speedbar-buffer + (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer) + (current-time)))) ;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t) (define-erc-module nickbar nil @@ -559,6 +582,8 @@ raising of frames or the stealing of input focus. If you witness such a thing and can reproduce it, please file a bug report with \\[erc-bug]." ((add-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) + (add-hook 'erc-insert-post-hook #'erc-speedbar--run-timer-on-post-insert) + (add-hook 'speedbar-timer-hook #'erc-speedbar--reset-last-ran-on-timer) (erc-speedbar--ensure) (unless (or erc--updating-modules-p (and-let* ((speedbar-buffer) @@ -569,6 +594,8 @@ such a thing and can reproduce it, please file a bug report with (with-current-buffer buf (erc-speedbar--ensure 'force))))) ((remove-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) + (remove-hook 'erc-insert-post-hook #'erc-speedbar--run-timer-on-post-insert) + (remove-hook 'speedbar-timer-hook #'erc-speedbar--reset-last-ran-on-timer) (when erc-track-mode (setq erc-track--switch-fallback-blockers (remove '(derived-mode . speedbar-mode) commit aedc8b55bfc4d2864d777ac17f6bcf70e4ee04ce Author: F. Jason Park Date: Wed Jan 17 21:42:02 2024 -0800 Actually derive channel membership from PREFIX in ERC * lisp/erc/erc-backend.el (erc--with-isupport-data): Add comment for possibly superior alternate implementation. * lisp/erc/erc-common.el (erc--get-isupport-entry): Use helper to initialize traditional prefix slots in overridden well-known constructor. (erc--parsed-prefix): Reverse order of characters in the `letters' and `statuses' slots, in their defaults and also their definitions. (erc--strpos): New function, a utility for finding a single character in a string. * lisp/erc/erc.el (erc--define-channel-user-status-compat-getter): Modify to query advertised value for associated mode letter at runtime instead of baking it in. (erc-channel-user-voice, erc-channel-user-halfop, erc-channel-user-op, erc-channel-user-admin, erc-channel-user-owner): Supply second argument for fallback mode letter. (erc--cusr-status-p, erc--cusr-change-status): New functions for querying and modifying `erc-channel-user' statuses. (erc-send-input-line): Update speaker time in own nick's `erc-channel-member' entry. (erc-get-channel-membership-prefix): Adapt code to prefer advertised prefix for mode letter. (erc--parsed-prefix): Save "reversed" `letters' and `statuses' so that they're ordered from lowest to highest semantically. (erc--get-prefix-flag, erc--init-cusr-fallback-status, erc--compute-cusr-fallback-status): New functions for retrieving internal prefix values and massaging hard-coded traditional prefixes so they're compatible with existing `erc-channel-member' update code. (erc--partition-prefixed-names): New function, separated for testing and for conversion to a generic in the future when ERC supports extensions that list member rolls in a different format. (erc-channel-receive-names): Refactor to use new status-aware update and init workhorse functions for updating and initializing a `erc-channel-members' entry. (erc--create-current-channel-member): New "status-aware" function comprising the `addp' path of `erc-update-current-channel-member'. (erc--update-current-channel-member): New "status-aware" function comprising the "update" path of `erc-update-current-channel-member', which ran when an existing `erc-channel-members' entry for the queried nick was found. (erc-update-current-channel-member): Split code body into two constituent functions, both for readability and for usability, so callers can more explicitly request the desired operation in a "status-aware" manner. (erc--update-membership-prefix): Remove unused function, originally meant to be new in ERC 5.6. (erc--process-channel-modes): Call `erc--cusr-change-status' instead of `erc--update-membership-prefix'. (erc--shuffle-nuh-nickward): New utility function to ensure code like `erc--partition-prefixed-names' can use `erc--parse-nuh' in a practical and relatively convenient way in the near future. * test/lisp/erc/erc-scenarios-base-chan-modes.el (erc-scenarios-base-chan-modes--speaker-status): New test. * test/lisp/erc/erc-tests.el (erc--parsed-prefix): Reverse expected order of various slot values in `erc--parsed-prefix' objects. (erc--get-prefix-flag, erc--init-cusr-fallback-status, erc--compute-cusr-fallback-status, erc--cusr-status-p, erc--cusr-change-status): New tests. (erc--update-channel-modes, erc-process-input-line): Use newly available utilities imported from common library. * test/lisp/erc/resources/base/modes/speaker-status.eld: New file. (Bug#67220) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 95207e56fd1..e379066b08e 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -2201,7 +2201,9 @@ primitive value." ;; While it's better to depend on interfaces than specific types, ;; using `cl-struct-slot-value' or similar to extract a known slot at ;; runtime would incur a small "ducktyping" tax, which should probably -;; be avoided when running dozens of times per incoming message. +;; be avoided when running hundreds of times per incoming message. +;; Instead of separate keys per data type, we could increment a +;; counter whenever a new 005 arrives. (defmacro erc--with-isupport-data (param var &rest body) "Return structured data stored in VAR for \"ISUPPORT\" PARAM. Expect VAR's value to be an instance of `erc--isupport-data'. If diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index e7e70fffd3a..e39e414b290 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -37,6 +37,7 @@ (defvar erc-session-server) (declare-function erc--get-isupport-entry "erc-backend" (key &optional single)) +(declare-function erc--init-cusr-fallback-status "erc" (v h o a q)) (declare-function erc-get-buffer "erc" (target &optional proc)) (declare-function erc-server-buffer "erc" nil) (declare-function widget-apply-action "wid-edit" (widget &optional event)) @@ -76,11 +77,11 @@ make-erc-channel-user ( &key voice halfop op admin owner last-message-time - &aux (status (+ (if voice 1 0) - (if halfop 2 0) - (if op 4 0) - (if admin 8 0) - (if owner 16 0))))) + &aux (status + (if (or voice halfop op admin owner) + (erc--init-cusr-fallback-status + voice halfop op admin owner) + 0)))) :named) "Object containing channel-specific data for a single user." ;; voice halfop op admin owner @@ -140,9 +141,12 @@ For use with the macro `erc--with-isupport-data'." (cl-defstruct (erc--parsed-prefix (:include erc--isupport-data)) "Server-local data for recognized membership-status prefixes. Derived from the advertised \"PREFIX\" ISUPPORT parameter." - (letters "qaohv" :type string) - (statuses "~&@%+" :type string) - (alist nil :type (list-of cons))) + ( letters "vhoaq" :type string + :documentation "Status letters ranked lowest to highest.") + ( statuses "+%@&~" :type string + :documentation "Status prefixes ranked lowest to highest.") + ( alist nil :type (list-of cons) + :documentation "Alist of letters-prefix pairs.")) (cl-defstruct (erc--channel-mode-types (:include erc--isupport-data)) "Server-local \"CHANMODES\" data." @@ -594,6 +598,10 @@ the resulting variables will end up with more useful doc strings." (debug (symbolp [&rest [keywordp form]] &rest (symbolp . form)))) `(erc--define-catalog ,language ,entries)) +(define-inline erc--strpos (char string) + "Return position of CHAR in STRING or nil if not found." + (inline-quote (string-search (string ,char) ,string))) + (defmacro erc--doarray (spec &rest body) "Map over ARRAY, running BODY with VAR bound to iteration element. Behave more or less like `seq-doseq', but tailor operations for diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index e9d6099317f..fc6f51950e2 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -598,28 +598,52 @@ Removes all users in the current channel. This is called by erc-channel-users) (clrhash erc-channel-users))) -(defmacro erc--define-channel-user-status-compat-getter (name n) +(defmacro erc--define-channel-user-status-compat-getter (name c d) "Define a gv getter for historical `erc-channel-user' status slot NAME. -Expect NAME to be a string and N to be its associated power-of-2 -\"enumerated flag\" integer." +Expect NAME to be a string, C to be its traditionally associated +letter, and D to be its fallback power-of-2 integer for non-ERC +buffers." `(defun ,(intern (concat "erc-channel-user-" name)) (u) ,(format "Get equivalent of pre-5.6 `%s' slot for `erc-channel-user'." name) (declare (gv-setter (lambda (v) (macroexp-let2 nil v v - (,'\`(let ((val (erc-channel-user-status ,',u))) + (,'\`(let ((val (erc-channel-user-status ,',u)) + (n (or (erc--get-prefix-flag ,c) ,d))) (setf (erc-channel-user-status ,',u) (if ,',v - (logior val ,n) - (logand val ,(lognot n)))) + (logior val n) + (logand val (lognot n)))) ,',v)))))) - (= ,n (logand ,n (erc-channel-user-status u))))) - -(erc--define-channel-user-status-compat-getter "voice" 1) -(erc--define-channel-user-status-compat-getter "halfop" 2) -(erc--define-channel-user-status-compat-getter "op" 4) -(erc--define-channel-user-status-compat-getter "admin" 8) -(erc--define-channel-user-status-compat-getter "owner" 16) + (let ((n (or (erc--get-prefix-flag ,c) ,d))) + (= n (logand n (erc-channel-user-status u)))))) + +(erc--define-channel-user-status-compat-getter "voice" ?v 1) +(erc--define-channel-user-status-compat-getter "halfop" ?h 2) +(erc--define-channel-user-status-compat-getter "op" ?o 4) +(erc--define-channel-user-status-compat-getter "admin" ?a 8) +(erc--define-channel-user-status-compat-getter "owner" ?q 16) + +;; This is a generalized version of the compat-oriented getters above. +(defun erc--cusr-status-p (nick-or-cusr letter) + "Return non-nil if NICK-OR-CUSR has channel membership status LETTER." + (and-let* ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) + (cdr (erc-get-channel-member nick-or-cusr)))) + (n (erc--get-prefix-flag letter))) + (= n (logand n (erc-channel-user-status cusr))))) + +(defun erc--cusr-change-status (nick-or-cusr letter enablep &optional resetp) + "Add or remove membership status associated with LETTER for NICK-OR-CUSR. +With RESETP, clear the user's status info completely. If ENABLEP +is non-nil, add the status value associated with LETTER." + (when-let ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) + (cdr (erc-get-channel-member nick-or-cusr)))) + (n (erc--get-prefix-flag letter))) + (cl-callf (lambda (v) + (if resetp + (if enablep n 0) + (if enablep (logior v n) (logand v (lognot n))))) + (erc-channel-user-status cusr)))) (defun erc-channel-user-owner-p (nick) "Return non-nil if NICK is an owner of the current channel." @@ -3900,6 +3924,10 @@ for other purposes.") (defun erc-send-input-line (target line &optional force) "Send LINE to TARGET." + (when-let ((target) + (cmem (erc-get-channel-member (erc-current-nick)))) + (setf (erc-channel-user-last-message-time (cdr cmem)) + (erc-compat--current-lisp-time))) (when (and (not erc--allow-empty-outgoing-lines-p) (string= line "\n")) (setq line " \n")) (erc-message "PRIVMSG" (concat target " " line) force)) @@ -6141,17 +6169,15 @@ return a possibly empty string." (catch 'done (pcase-dolist (`(,letter . ,pfx) (erc--parsed-prefix-alist pfx-obj)) - (pcase letter - ((and ?q (guard (erc-channel-user-owner nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "owner"))) - ((and ?a (guard (erc-channel-user-admin nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "admin"))) - ((and ?o (guard (erc-channel-user-op nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "operator"))) - ((and ?h (guard (erc-channel-user-halfop nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "half-op"))) - ((and ?v (guard (erc-channel-user-voice nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "voice"))))) + (when (erc--cusr-status-p nick-or-cusr letter) + (throw 'done + (pcase letter + (?q (propertize (string pfx) 'help-echo "owner")) + (?a (propertize (string pfx) 'help-echo "admin")) + (?o (propertize (string pfx) 'help-echo "operator")) + (?h (propertize (string pfx) 'help-echo "half-op")) + (?v (propertize (string pfx) 'help-echo "voice")) + (_ (string pfx)))))) ""))) (t (cond ((erc-channel-user-owner nick-or-cusr) @@ -6763,12 +6789,52 @@ parameter advertised by the current server, with the original ordering intact. If no such parameter has yet arrived, return a stand-in from the fallback value \"(qaohv)~&@%+\"." (erc--with-isupport-data PREFIX erc--parsed-prefix - (let ((alist (nreverse (erc-parse-prefix)))) + (let ((alist (erc-parse-prefix))) (make-erc--parsed-prefix :key key :letters (apply #'string (map-keys alist)) :statuses (apply #'string (map-values alist)) - :alist alist)))) + :alist (nreverse alist))))) + +(defun erc--get-prefix-flag (char &optional parsed-prefix from-prefix-p) + "Return numeric rank for CHAR or nil if unknown. +For example, given letters \"qaohv\" return 1 for ?v, 2 for ?h, +and 4 for ?o, etc. If given, expect PARSED-PREFIX to be a +`erc--parse-prefix' object. With FROM-PREFIX-P, expect CHAR to +be a prefix instead." + (and-let* ((obj (or parsed-prefix (erc--parsed-prefix))) + (pos (erc--strpos char (if from-prefix-p + (erc--parsed-prefix-statuses obj) + (erc--parsed-prefix-letters obj))))) + (ash 1 pos))) + +(defun erc--init-cusr-fallback-status (voice halfop op admin owner) + "Return channel-membership based on traditional status semantics. +Massage boolean switches VOICE, HALFOP, OP, ADMIN, and OWNER into +an internal numeric value suitable for the `status' slot of a new +`erc-channel-user' object." + (let ((pfx (erc--parsed-prefix))) + (+ (if voice (if pfx (or (erc--get-prefix-flag ?v pfx) 0) 1) 0) + (if halfop (if pfx (or (erc--get-prefix-flag ?h pfx) 0) 2) 0) + (if op (if pfx (or (erc--get-prefix-flag ?o pfx) 0) 4) 0) + (if admin (if pfx (or (erc--get-prefix-flag ?a pfx) 0) 8) 0) + (if owner (if pfx (or (erc--get-prefix-flag ?q pfx) 0) 16) 0)))) + +(defun erc--compute-cusr-fallback-status (current v h o a q) + "Return current channel membership after toggling V H O A Q as requested. +Assume `erc--parsed-prefix' is non-nil in the current buffer. +Expect status switches V, H, O, A, Q, when non-nil, to be the +symbol `on' or `off'. Return an internal numeric value suitable +for the `status' slot of an `erc-channel-user' object." + (let (on off) + (when v (push (or (erc--get-prefix-flag ?v) 0) (if (eq v 'on) on off))) + (when h (push (or (erc--get-prefix-flag ?h) 0) (if (eq h 'on) on off))) + (when o (push (or (erc--get-prefix-flag ?o) 0) (if (eq o 'on) on off))) + (when a (push (or (erc--get-prefix-flag ?a) 0) (if (eq a 'on) on off))) + (when q (push (or (erc--get-prefix-flag ?q) 0) (if (eq q 'on) on off))) + (when on (setq current (apply #'logior current on))) + (when off (setq current (apply #'logand current (mapcar #'lognot off))))) + current) (defcustom erc-channel-members-changed-hook nil "This hook is called every time the variable `channel-members' changes. @@ -6776,48 +6842,40 @@ The buffer where the change happened is current while this hook is called." :group 'erc-hooks :type 'hook) -(defun erc-channel-receive-names (names-string) - "This function is for internal use only. +(defun erc--partition-prefixed-names (name) + "From NAME, return a list of (STATUS NICK LOGIN HOST). +Expect NAME to be a prefixed name, like @bob." + (unless (string-empty-p name) + (let* ((status (erc--get-prefix-flag (aref name 0) nil 'from-prefix-p)) + (nick (if status (substring name 1) name))) + (unless (string-empty-p nick) + (list status nick nil nil))))) -Update `erc-channel-users' according to NAMES-STRING. -NAMES-STRING is a string listing some of the names on the -channel." - (let* ((prefix (erc--parsed-prefix-alist (erc--parsed-prefix))) - (voice-ch (cdr (assq ?v prefix))) - (op-ch (cdr (assq ?o prefix))) - (hop-ch (cdr (assq ?h prefix))) - (adm-ch (cdr (assq ?a prefix))) - (own-ch (cdr (assq ?q prefix))) - (names (delete "" (split-string names-string))) - name op voice halfop admin owner) - (let ((erc-channel-members-changed-hook nil)) - (dolist (item names) - (let ((updatep t) - (ch (aref item 0))) - (setq name item op 'off voice 'off halfop 'off admin 'off owner 'off) - (if (rassq ch prefix) - (if (= (length item) 1) - (setq updatep nil) - (setq name (substring item 1)) - (setf (pcase ch - ((pred (eq voice-ch)) voice) - ((pred (eq hop-ch)) halfop) - ((pred (eq op-ch)) op) - ((pred (eq adm-ch)) admin) - ((pred (eq own-ch)) owner) - (_ (message "Unknown prefix char `%S'" ch) voice)) - 'on))) - (when updatep +(defun erc-channel-receive-names (names-string) + "Update `erc-channel-members' from NAMES-STRING. +Expect NAMES-STRING to resemble the trailing argument of a 353 +RPL_NAMREPLY. Call internal handlers for parsing individual +names, whose expected composition may differ depending on enabled +extensions." + (let ((names (delete "" (split-string names-string))) + (erc-channel-members-changed-hook nil)) + (dolist (name names) + (when-let ((args (erc--partition-prefixed-names name))) + (pcase-let* ((`(,status ,nick ,login ,host) args) + (cmem (erc-get-channel-user nick))) + (progn ;; If we didn't issue the NAMES request (consider two clients ;; talking to an IRC proxy), `erc-channel-begin-receiving-names' ;; will not have been called, so we have to do it here. (unless erc-channel-new-member-names (erc-channel-begin-receiving-names)) - (puthash (erc-downcase name) t - erc-channel-new-member-names) - (erc-update-current-channel-member - name name t voice halfop op admin owner))))) - (run-hooks 'erc-channel-members-changed-hook))) + (puthash (erc-downcase nick) t erc-channel-new-member-names) + (if cmem + (erc--update-current-channel-member cmem status nil + nick host login) + (erc--create-current-channel-member nick status nil + nick host login))))))) + (run-hooks 'erc-channel-members-changed-hook)) (defun erc-update-user-nick (nick &optional new-nick host login full-name info) @@ -6869,17 +6927,85 @@ which USER is a member, and t is returned." (run-hooks 'erc-channel-members-changed-hook)))))) changed)) +(defun erc--create-current-channel-member + (nick status timep &optional new-nick host login full-name info) + "Add an `erc-channel-member' entry for NICK. +Create a new `erc-server-users' entry if necessary, and ensure +`erc-channel-members-changed-hook' runs exactly once, regardless. +Pass STATUS to the `erc-channel-user' constructor. With TIMEP, +assume NICK has just spoken, and initialize `last-message-time'. +Pass NEW-NICK, HOST, LOGIN, FULL-NAME, and INFO to +`erc-update-user' if a server user exists and otherwise to the +`erc-server-user' constructor." + (cl-assert (null (erc-get-channel-member nick))) + (let* ((user-changed-p nil) + (down (erc-downcase nick)) + (user (gethash down (erc-with-server-buffer erc-server-users)))) + (if user + (progn + (cl-pushnew (current-buffer) (erc-server-user-buffers user)) + ;; Update *after* ^ so hook has chance to run. + (setf user-changed-p (erc-update-user user new-nick host login + full-name info))) + (erc-add-server-user nick + (setq user (make-erc-server-user + :nickname (or new-nick nick) + :host host + :full-name full-name + :login login + :info nil + :buffers (list (current-buffer)))))) + (let ((cusr (erc-channel-user--make + :status (or status 0) + :last-message-time (and timep + (erc-compat--current-lisp-time))))) + (puthash down (cons user cusr) erc-channel-users)) + ;; An existing `cusr' was changed or a new one was added, and + ;; `user' was not updated, though possibly just created (since + ;; `erc-update-user' runs this same hook in all a user's buffers). + (unless user-changed-p + (run-hooks 'erc-channel-members-changed-hook)) + t)) + +(defun erc--update-current-channel-member (cmem status timep &rest user-args) + "Update existing `erc-channel-member' entry. +Set the `status' slot of the entry's `erc-channel-user' side to +STATUS and, with TIMEP, update its `last-message-time'. When +actual changes are made, run `erc-channel-members-changed-hook', +and return non-nil." + (cl-assert cmem) + (let ((cusr (cdr cmem)) + (user (car cmem)) + cusr-changed-p user-changed-p) + (when (and status (/= status (erc-channel-user-status cusr))) + (setf (erc-channel-user-status cusr) status + cusr-changed-p t)) + (when timep + (setf (erc-channel-user-last-message-time cusr) + (erc-compat--current-lisp-time))) + ;; Ensure `erc-channel-members-changed-hook' runs on change. + (cl-assert (memq (current-buffer) (erc-server-user-buffers user))) + (setq user-changed-p (apply #'erc-update-user user user-args)) + ;; An existing `cusr' was changed or a new one was added, and + ;; `user' was not updated, though possibly just created (since + ;; `erc-update-user' runs this same hook in all a user's buffers). + (when (and cusr-changed-p (null user-changed-p)) + (run-hooks 'erc-channel-members-changed-hook)) + (erc-log (format "update-member: user = %S, cusr = %S" user cusr)) + (or cusr-changed-p user-changed-p))) + (defun erc-update-current-channel-member - (nick new-nick &optional addp voice halfop op admin owner host login full-name info - update-message-time) + (nick new-nick &optional addp voice halfop op admin owner host login + full-name info update-message-time) "Update or create entry for NICK in current `erc-channel-members' table. -With ADDP, ensure an entry exists. If one already does, call -`erc-update-user' to handle updates to HOST, LOGIN, FULL-NAME, -INFO, and NEW-NICK. Expect any non-nil membership status -switches among VOICE, HALFOP, OP, ADMIN, and OWNER to be the -symbol `on' or `off' when needing to influence a new or existing -`erc-channel-user' object's `status' slot. Likewise, when -UPDATE-MESSAGE-TIME is non-nil, update or initialize the +With ADDP, ensure an entry exists. When an entry does exist or +when ADDP is non-nil and an `erc-server-users' entry already +exists, call `erc-update-user' with NEW-NICK, HOST, LOGIN, +FULL-NAME, and INFO. Expect any non-nil membership +status switches among VOICE, HALFOP, OP, ADMIN, and OWNER to be +the symbol `on' or `off' when needing to influence a new or +existing `erc-channel-user' object's `status' slot. Likewise, +when UPDATE-MESSAGE-TIME is non-nil, update or initialize the `last-message-time' slot to the current-time. If changes occur, including creation, run `erc-channel-members-changed-hook'. Return non-nil when meaningful changes, including creation, have @@ -6889,62 +7015,26 @@ Without ADDP, do nothing unless a `erc-channel-members' entry exists. When it doesn't, assume the sender is a non-joined entity, like the server itself or a historical speaker, or assume the prior buffer for the channel was killed without parting." - (let* (cusr-changed-p - user-changed-p - (cmem (erc-get-channel-member nick)) - (cusr (cdr cmem)) - (down (erc-downcase nick)) - (user (or (car cmem) - (gethash down (erc-with-server-buffer erc-server-users))))) - (if cusr - (progn - (erc-log (format "update-member: user = %S, cusr = %S" user cusr)) - (when-let (((or voice halfop op admin owner)) - (existing (erc-channel-user-status cusr))) - (when voice (setf (erc-channel-user-voice cusr) (eq voice 'on))) - (when halfop (setf (erc-channel-user-halfop cusr) (eq halfop 'on))) - (when op (setf (erc-channel-user-op cusr) (eq op 'on))) - (when admin (setf (erc-channel-user-admin cusr) (eq admin 'on))) - (when owner (setf (erc-channel-user-owner cusr) (eq owner 'on))) - (setq cusr-changed-p (= existing (erc-channel-user-status cusr)))) - (when update-message-time - (setf (erc-channel-user-last-message-time cusr) (current-time))) - ;; Assume `user' exists and its `buffers' slot contains the - ;; current buffer so that `erc-channel-members-changed-hook' - ;; will run if changes are made. - (setq user-changed-p - (erc-update-user user new-nick - host login full-name info))) - (when addp - (if (null user) - (progn - (setq user (make-erc-server-user - :nickname nick - :host host - :full-name full-name - :login login - :info info - :buffers (list (current-buffer)))) - (erc-add-server-user nick user)) - (setf (erc-server-user-buffers user) - (cons (current-buffer) - (erc-server-user-buffers user)))) - (setq cusr (make-erc-channel-user - :voice (and voice (eq voice 'on)) - :halfop (and halfop (eq halfop 'on)) - :op (and op (eq op 'on)) - :admin (and admin (eq admin 'on)) - :owner (and owner (eq owner 'on)) - :last-message-time (if update-message-time - (current-time)))) - (puthash down (cons user cusr) erc-channel-users) - (setq cusr-changed-p t))) - ;; An existing `cusr' was changed or a new one was added, and - ;; `user' was not updated, though possibly just created (since - ;; `erc-update-user' runs this same hook in all a user's buffers). - (when (and cusr-changed-p (null user-changed-p)) - (run-hooks 'erc-channel-members-changed-hook)) - (or cusr-changed-p user-changed-p))) +(let* ((cmem (erc-get-channel-member nick)) + (status (and (or voice halfop op admin owner) + (if cmem + (erc--compute-cusr-fallback-status + (erc-channel-user-status (cdr cmem)) + voice halfop op admin owner) + (erc--init-cusr-fallback-status + (and voice (eq voice 'on)) + (and halfop (eq halfop 'on)) + (and op (eq op 'on)) + (and admin (eq admin 'on)) + (and owner (eq owner 'on))))))) + (if cmem + (erc--update-current-channel-member cmem status update-message-time + new-nick host login + full-name info) + (when addp + (erc--create-current-channel-member nick status update-message-time + new-nick host login + full-name info))))) (defun erc-update-channel-member (channel nick new-nick &optional add voice halfop op admin owner host login @@ -7134,16 +7224,6 @@ person who changed the modes." ;; nick modes - ignored at this point (t nil)))) -(defun erc--update-membership-prefix (nick letter state) - "Update status prefixes for NICK in current channel buffer. -Expect LETTER to be a status char and STATE to be a boolean." - (erc-update-current-channel-member nick nil nil - (and (= letter ?v) state) - (and (= letter ?h) state) - (and (= letter ?o) state) - (and (= letter ?a) state) - (and (= letter ?q) state))) - (defvar-local erc--channel-modes nil "When non-nil, a hash table of current channel modes. Keys are characters. Values are either a string, for types A-C, @@ -7189,7 +7269,7 @@ complement relevant letters in STRING." (cond ((= ?+ c) (setq +p t)) ((= ?- c) (setq +p nil)) ((and status-letters (string-search (string c) status-letters)) - (erc--update-membership-prefix (pop args) c (if +p 'on 'off))) + (erc--cusr-change-status (pop args) c +p)) ((and-let* ((group (or (aref table c) (and fallbackp ?d)))) (erc--handle-channel-mode group c +p (and (/= group ?d) @@ -7511,6 +7591,12 @@ See associated unit test for precise behavior." (match-string 2 string) (match-string 3 string)))) +(defun erc--shuffle-nuh-nickward (nick login host) + "Interpret results of `erc--parse-nuh', promoting loners to nicks." + (cond (nick (cl-assert (null login)) (list nick login host)) + ((and (null login) host) (list host nil nil)) + ((and login (null host)) (list login nil nil)))) + (defun erc-extract-nick (string) "Return the nick corresponding to a user specification STRING. diff --git a/test/lisp/erc/erc-scenarios-base-chan-modes.el b/test/lisp/erc/erc-scenarios-base-chan-modes.el index 73fba65acf4..3183cd27370 100644 --- a/test/lisp/erc/erc-scenarios-base-chan-modes.el +++ b/test/lisp/erc/erc-scenarios-base-chan-modes.el @@ -81,4 +81,62 @@ (should-not erc-channel-user-limit) (funcall expect 10 " after")))) +;; This asserts proper recognition of nonstandard prefixes advertised +;; via the "PREFIX=" ISUPPORT parameter. Note that without the IRCv3 +;; `multi-prefix' extension, we can't easily sync a user's channel +;; membership status on receipt of a 352/353 by parsing the "flags" +;; parameter because even though servers remember multiple prefixes, +;; they only ever return the one with the highest rank. For example, +;; if on receipt of a 352, we were to "update" someone we believe to +;; be @+ by changing them to a to @, we'd be guilty of willful +;; munging. And if they later lose that @, we'd then see them as null +;; when in fact they're still +. However, we *could* use a single +;; degenerate prefix to "validate" an existing record to ensure +;; correctness of our processing logic, but it's unclear how such a +;; discrepancy ought to be handled beyond asking the user to file a +;; bug. +(ert-deftest erc-scenarios-base-chan-modes--speaker-status () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/modes") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'speaker-status)) + (erc-show-speaker-membership-status t) + (erc-autojoin-channels-alist '(("." "#chan"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port (process-contact dumb-server :service) + :nick "tester" + :user "tester") + (funcall expect 5 "Here on foonet, we provide services"))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + + (ert-info ("Prefixes printed correctly in 353") + (funcall expect 10 "chan: +alice @fsbot -bob !foop")) + + (ert-info ("Speakers honor option `erc-show-speaker-membership-status'") + (funcall expect 10 "<-bob> alice: Of that which hath") + (funcall expect 10 "<+alice> Hie you, make haste") + (funcall expect 10 " hi")) + + (ert-info ("Status conferred and rescinded") + (funcall expect 10 "*** foop (user@netadmin.example.net) has changed ") + (funcall expect 10 "mode for #chan to +v bob") + (funcall expect 10 "<+bob> alice: Fair as a text B") + (funcall expect 10 "<+alice> bob: Even as Apemantus") + (funcall expect 10 "mode for #chan to -v bob") + (funcall expect 10 "<-bob> alice: That's the way") + (funcall expect 10 "<+alice> Give it the beasts")) + + ;; If it had instead overwritten it, our two states would be + ;; out of sync. (See comment above.) + (ert-info ("/WHO output confirms server shadowed V status") + (erc-scenarios-common-say "/who #chan") + (funcall expect 10 '(: "bob" (+ " ") "H-")) + (funcall expect 10 "<-bob> alice: Remains in danger") + (erc-cmd-QUIT ""))))) + ;;; erc-scenarios-base-chan-modes.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 49c72836a22..b51bd67ae04 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -674,7 +674,7 @@ ;; checking if null beforehand. (should-not erc--parsed-prefix) (should (equal (erc--parsed-prefix) - #s(erc--parsed-prefix nil "qaohv" "~&@%+" + #s(erc--parsed-prefix nil "vhoaq" "+%@&~" ((?q . ?~) (?a . ?&) (?o . ?@) (?h . ?%) (?v . ?+))))) (let ((cached (should erc--parsed-prefix))) @@ -696,7 +696,7 @@ (should (equal expected (erc--parsed-prefix-alist erc--parsed-prefix))) (setq cached erc--parsed-prefix) (should (equal cached - #s(erc--parsed-prefix ("(ov)@+") "ov" "@+" + #s(erc--parsed-prefix ("(ov)@+") "vo" "+@" ((?o . ?@) (?v . ?+))))) ;; Second target buffer reuses cached value. (with-temp-buffer @@ -714,6 +714,88 @@ (erc-with-server-buffer erc--parsed-prefix)) '((?q . ?~) (?h . ?%))))))) +(ert-deftest erc--get-prefix-flag () + (erc-tests-common-make-server-buf (buffer-name)) + (should-not erc--parsed-prefix) + (should (= (erc--get-prefix-flag ?v) 1)) + (should (= (erc--get-prefix-flag ?h) 2)) + (should (= (erc--get-prefix-flag ?o) 4)) + (should (= (erc--get-prefix-flag ?a) 8)) + (should (= (erc--get-prefix-flag ?q) 16)) + + (ert-info ("With optional `from-prefix-p'") + (should (= (erc--get-prefix-flag ?+ nil 'fpp) 1)) + (should (= (erc--get-prefix-flag ?% nil 'fpp) 2)) + (should (= (erc--get-prefix-flag ?@ nil 'fpp) 4)) + (should (= (erc--get-prefix-flag ?& nil 'fpp) 8)) + (should (= (erc--get-prefix-flag ?~ nil 'fpp) 16))) + (should erc--parsed-prefix)) + +(ert-deftest erc--init-cusr-fallback-status () + ;; Fallback behavior active because no `erc--parsed-prefix'. + (should-not erc--parsed-prefix) + (should (= 0 (erc--init-cusr-fallback-status nil nil nil nil nil))) + (should (= 1 (erc--init-cusr-fallback-status t nil nil nil nil))) + (should (= 4 (erc--init-cusr-fallback-status nil nil t nil nil))) + (should-not erc--parsed-prefix) ; not created in non-ERC buffer. + + ;; Uses advertised server parameter. + (erc-tests-common-make-server-buf (buffer-name)) + (setq erc-server-parameters '(("PREFIX" . "(YqaohvV)!~&@%+-"))) + (should (= 0 (erc--init-cusr-fallback-status nil nil nil nil nil))) + (should (= 2 (erc--init-cusr-fallback-status t nil nil nil nil))) + (should (= 8 (erc--init-cusr-fallback-status nil nil t nil nil))) + (should erc--parsed-prefix)) + +(ert-deftest erc--compute-cusr-fallback-status () + ;; Useless without an `erc--parsed-prefix'. + (should (= 0 (erc--compute-cusr-fallback-status 0 nil nil nil nil nil))) + (should (= 0 (erc--compute-cusr-fallback-status 0 'on 'on 'on 'on 'on))) + + (erc-tests-common-make-server-buf (buffer-name)) + (should (= 0 (erc--compute-cusr-fallback-status 0 nil nil nil nil nil))) + (should (= 1 (erc--compute-cusr-fallback-status 0 'on nil nil nil nil))) + (should (= 1 (erc--compute-cusr-fallback-status 0 'on 'off 'off 'off 'off))) + (should (= 1 (erc--compute-cusr-fallback-status 1 'on 'off 'off 'off 'off))) + (should (= 1 (erc--compute-cusr-fallback-status 1 nil nil nil nil nil))) + (should (= 1 (erc--compute-cusr-fallback-status 3 nil 'off nil nil nil))) + (should (= 1 (erc--compute-cusr-fallback-status 7 nil 'off 'off nil nil))) + (should (= 4 (erc--compute-cusr-fallback-status 1 'off nil 'on nil nil)))) + +(ert-deftest erc--cusr-status-p () + (erc-tests-common-make-server-buf (buffer-name)) + (should-not erc--parsed-prefix) + (let ((cusr (make-erc-channel-user :voice t :op t))) + (should-not (erc--cusr-status-p cusr ?q)) + (should-not (erc--cusr-status-p cusr ?a)) + (should-not (erc--cusr-status-p cusr ?h)) + (should (erc--cusr-status-p cusr ?o)) + (should (erc--cusr-status-p cusr ?v))) + (should erc--parsed-prefix)) + +(ert-deftest erc--cusr-change-status () + (erc-tests-common-make-server-buf (buffer-name)) + (let ((cusr (make-erc-channel-user))) + (should-not (erc--cusr-status-p cusr ?o)) + (should-not (erc--cusr-status-p cusr ?v)) + (erc--cusr-change-status cusr ?o t) + (erc--cusr-change-status cusr ?v t) + (should (erc--cusr-status-p cusr ?o)) + (should (erc--cusr-status-p cusr ?v)) + + (ert-info ("Reset with optional param") + (erc--cusr-change-status cusr ?q t 'reset) + (should-not (erc--cusr-status-p cusr ?o)) + (should-not (erc--cusr-status-p cusr ?v)) + (should (erc--cusr-status-p cusr ?q))) + + (ert-info ("Clear with optional param") + (erc--cusr-change-status cusr ?v t) + (should (erc--cusr-status-p cusr ?v)) + (erc--cusr-change-status cusr ?q nil 'reset) + (should-not (erc--cusr-status-p cusr ?v)) + (should-not (erc--cusr-status-p cusr ?q))))) + ;; This exists as a reference to assert legacy behavior in order to ;; preserve and incorporate it as a fallback in the 5.6+ replacement. (ert-deftest erc-parse-modes () @@ -737,12 +819,9 @@ (should (equal (erc-parse-modes "-l") '(nil nil (("l" off nil)))))))) (ert-deftest erc--update-channel-modes () - (erc-mode) + (erc-tests-common-make-server-buf) (setq erc-channel-users (make-hash-table :test #'equal) - erc-server-users (make-hash-table :test #'equal) - erc--isupport-params (make-hash-table) erc--target (erc--target-from-string "#test")) - (erc-tests-common-init-server-proc "sleep" "1") (let ((orig-handle-fn (symbol-function 'erc--handle-channel-mode)) calls) @@ -1715,13 +1794,13 @@ ;; regardless of whether a command handler is summoned. (ert-deftest erc-process-input-line () - (let (erc-server-last-sent-time - erc-server-flood-queue - (orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG)) - (erc-default-recipients '("#chan")) + (erc-tests-common-make-server-buf) + (let ((orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG)) + (pop-flood-queue (lambda () (erc-with-server-buffer + (pop erc-server-flood-queue)))) calls) - (with-temp-buffer - (erc-tests-common-init-server-proc "sleep" "1") + (setq erc-server-current-nick "tester") + (with-current-buffer (erc--open-target "#chan") (cl-letf (((symbol-function 'erc-cmd-MSG) (lambda (line) (push line calls) @@ -1735,49 +1814,50 @@ (ert-info ("Baseline") (erc-process-input-line "/msg #chan hi\n") (should (equal (pop calls) " #chan hi")) - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("PRIVMSG #chan :hi\r\n" . utf-8)))) (ert-info ("Quote preserves line intact") (erc-process-input-line "/QUOTE FAKE foo bar\n") - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("FAKE foo bar\r\n" . utf-8)))) (ert-info ("Unknown command respected") (erc-process-input-line "/FAKE foo bar\n") - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("FAKE foo bar\r\n" . utf-8)))) (ert-info ("Spaces preserved") (erc-process-input-line "/msg #chan hi you\n") (should (equal (pop calls) " #chan hi you")) - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("PRIVMSG #chan :hi you\r\n" . utf-8)))) (ert-info ("Empty line honored") (erc-process-input-line "/msg #chan\n") (should (equal (pop calls) " #chan")) - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("PRIVMSG #chan :\r\n" . utf-8))))) (ert-info ("Implicit cmd via `erc-send-input-line-function'") (ert-info ("Baseline") (erc-process-input-line "hi\n") - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("PRIVMSG #chan :hi\r\n" . utf-8)))) (ert-info ("Spaces preserved") (erc-process-input-line "hi you\n") - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("PRIVMSG #chan :hi you\r\n" . utf-8)))) (ert-info ("Empty line transmitted with injected-space kludge") (erc-process-input-line "\n") - (should (equal (pop erc-server-flood-queue) + (should (equal (funcall pop-flood-queue) '("PRIVMSG #chan : \r\n" . utf-8)))) - (should-not calls)))))) + (should-not calls))))) + (erc-tests-common-kill-buffers)) (ert-deftest erc--get-inserted-msg-beg/basic () (erc-tests-common-assert-get-inserted-msg/basic diff --git a/test/lisp/erc/resources/base/modes/speaker-status.eld b/test/lisp/erc/resources/base/modes/speaker-status.eld new file mode 100644 index 00000000000..4a7d508e35c --- /dev/null +++ b/test/lisp/erc/resources/base/modes/speaker-status.eld @@ -0,0 +1,69 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :unknown") + (0.00 ":irc.example.net NOTICE * :*** Looking up your hostname...") + (0.00 ":irc.example.net NOTICE tester :*** Could not resolve your hostname: Domain not found; using your IP address (10.0.2.100) instead.") + (0.09 ":irc.example.net 001 tester :Welcome to the foonet IRC Network tester!tester@10.0.2.100") + (0.01 ":irc.example.net 002 tester :Your host is irc.example.net, running version InspIRCd-3") + (0.01 ":irc.example.net 003 tester :This server was created 07:50:59 Jan 22 2024") + (0.03 ":irc.example.net 004 tester irc.example.net InspIRCd-3 BIRcgikorsw ACHIKMORTVXabcefghijklmnopqrstvyz :HIVXabefghjkloqvy") + (0.00 ":irc.example.net 005 tester ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=ascii CHANLIMIT=#:20 CHANMODES=IXbeg,k,Hfjl,ACKMORTcimnprstz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server") + (0.01 ":irc.example.net 005 tester EXTBAN=,ACORTUacjrwz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=foonet :are supported by this server") + (0.01 ":irc.example.net 005 tester NICKLEN=30 PREFIX=(yqaohvV)!~&@%+- SAFELIST SILENCE=32 STATUSMSG=!~&@%+- TOPICLEN=307 UHNAMES USERIP USERLEN=10 USERMODES=,,s,BIRcgikorw WHOX :are supported by this server") + (0.01 ":irc.example.net 251 tester :There are 2 users and 2 invisible on 2 servers") + (0.00 ":irc.example.net 252 tester 1 :operator(s) online") + (0.00 ":irc.example.net 253 tester 1 :unknown connections") + (0.00 ":irc.example.net 254 tester 2 :channels formed") + (0.00 ":irc.example.net 255 tester :I have 4 clients and 1 servers") + (0.00 ":irc.example.net 265 tester :Current local users: 4 Max: 5") + (0.00 ":irc.example.net 266 tester :Current global users: 4 Max: 5") + (0.00 ":irc.example.net 375 tester :irc.example.net message of the day") + (0.00 ":irc.example.net 372 tester : https://github.com/inspircd/inspircd-docker/issues") + (0.00 ":irc.example.net 372 tester : ") + (0.00 ":irc.example.net 372 tester : Have fun with the image!") + (0.00 ":irc.example.net 376 tester :End of message of the day.") + (0.00 ":irc.example.net 501 tester x :is not a recognised user mode.") + (0.00 ":NickServ!NickServ@services.int NOTICE tester :Welcome to foonet, tester! Here on foonet, we provide services to enable the registration of nicknames and channels! For details, type \2/msg NickServ help\2 and \2/msg ChanServ help\2.")) + +((mode 10 "MODE tester +i") + (0.01 ":tester!tester@10.0.2.100 MODE tester :+i")) + +((join 10 "JOIN #chan") + (0.02 ":tester!tester@10.0.2.100 JOIN :#chan") + (0.02 ":irc.example.net 353 tester = #chan :+alice @fsbot -bob !foop tester") + (0.03 ":irc.example.net 366 tester #chan :End of /NAMES list.") + (0.00 ":bob!bob@localhost PRIVMSG #chan :tester, welcome!") + (0.01 ":alice!alice@localhost PRIVMSG #chan :tester, welcome!")) + +((mode-chan 10 "MODE #chan") + (0.00 ":irc.example.net 324 tester #chan :+nt") + (0.01 ":irc.example.net 329 tester #chan :1705909863") + (0.03 ":bob!bob@localhost PRIVMSG #chan :alice: Of that which hath so faithfully been paid.") + (0.03 ":alice!alice@localhost PRIVMSG #chan :Hie you, make haste, for it grows very late.") + (0.03 ":foop!user@netadmin.example.net PRIVMSG #chan :hi") + ;; (0.07 ":alice!alice@localhost PRIVMSG #chan :bob: And make a clear way to the gods.") + ;; (0.04 ":bob!bob@localhost PRIVMSG #chan :Why, that they have; and bid them so be gone.") + ;; (0.08 ":bob!bob@localhost PRIVMSG #chan :alice: Now stay your strife: what shall be is dispatch'd.") + (0.06 ":foop!user@netadmin.example.net MODE #chan +v :bob") + (0.05 ":bob!bob@localhost PRIVMSG #chan :alice: Fair as a text B in a copy-book.") + (0.07 ":alice!alice@localhost PRIVMSG #chan :bob: Even as Apemantus does now; hate a lord with my heart.") + (0.03 ":bob!bob@localhost PRIVMSG #chan :Then here is a supplication for you. And when you come to him, at the first approach you must kneel; then kiss his foot; then deliver up your pigeons; and then look for your reward. I'll be at hand, sir; see you do it bravely.") + (0.05 ":foop!user@netadmin.example.net MODE #chan -v :bob") + (0.04 ":bob!bob@localhost PRIVMSG #chan :alice: That's the way: for women are light at midnight.") + (0.04 ":alice!alice@localhost PRIVMSG #chan :Give it the beasts, to be rid of the men.") + ;; (0.02 ":alice!alice@localhost PRIVMSG #chan :bob: Here comes young Master Ganymede, my new mistress's brother.") + ) + +((who-chan 10 "who #chan") + (0.03 ":irc.example.net 352 tester #chan alice localhost irc.example.net alice H+ :0 Irc bot based on irc3 http://irc3.readthedocs.io") + (0.03 ":irc.example.net 352 tester #chan fsbot localhost irc.example.net fsbot H@ :0 fsbot") + (0.01 ":irc.example.net 352 tester #chan bob localhost irc.example.net bob H- :0 Irc bot based on irc3 http://irc3.readthedocs.io") + (0.01 ":irc.example.net 352 tester #chan user netadmin.example.net irc.example.net foop H*! :0 unknown") + (0.01 ":irc.example.net 352 tester #chan tester 10.0.2.100 irc.example.net tester H :0 unknown") + (0.01 ":irc.example.net 315 tester #chan :End of /WHO list.") + ;; (0.09 ":bob!bob@localhost PRIVMSG #chan :alice: Shall nothing wrong him. Thus it is, general.") + ;; (0.04 ":alice!alice@localhost PRIVMSG #chan :bob: His father and I were soldiers together; to whom I have been often bound for no less than my life. Here comes the Briton: let him be so entertained amongst you as suits, with gentlemen of your knowing, to a stranger of his quality.") + (0.04 ":bob!bob@localhost PRIVMSG #chan :alice: Remains in danger of her former tooth.")) + +((quit 10 "QUIT :\2ERC\2") + (0.03 "ERROR :Closing link: (tester@10.0.2.100) [Quit: \2ERC\2 5.x (IRC client for GNU Emacs)]")) commit d85f561da03cd4705341a5a73f5c643f778e0f35 Author: F. Jason Park Date: Fri Jan 19 09:11:37 2024 -0800 Reserve negative depth range for ERC's insert hooks * etc/ERC-NEWS: Mention additional reserved depth range of -80 to -20. Also mention possibly having to cycle module activation state after updating options. * lisp/erc/erc-goodies.el (erc-irccontrols-mode, erc-irccontrols-enable): Add `erc-controls-highlight' to `erc-insert-modify-hook' at depth -50. * lisp/erc/erc.el (erc-insert-modify-hook): Mention negative hook-depth range in doc string. diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 6cfa704d995..b673d36220a 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -325,6 +325,15 @@ to enable the displaying of status prefixes on the speaker nicks of incoming chat messages. Prefixes on your speaker nick for outgoing chat messages continue to always be present. +** Updating user options requires cycling associated minor modes. +During a live ERC session, you may need to disable and re-enable a +module's minor mode via 'M-x erc-foo-mode RET' or similar before an +option's updated value takes effect. This primarily impacts new +options introduced by this release and existing ones whose behavior +has changed in some way. At present, ERC does not perform this step +automatically on your behalf, even if a change was made in a +'Custom-mode' buffer or via 'setopt'. + ** Miscellaneous UX changes. Some minor quality-of-life niceties have finally made their way to ERC. For example, fool visibility has become togglable with the new @@ -387,8 +396,10 @@ when present, at depths beginning at 20 and ending below 80. Of most interest to module authors is the new relative positioning of the first three, which have been rotated leftward with respect to their previous places in recent ERC versions (fill, button, match ,stamp). +A similar designated range from -80 to -20 also exists and is home to +the function 'erc-controls-highlight'. -ERC also provisionally reserves the same depth interval for +ERC also provisionally reserves the same depth intervals for 'erc-insert-pre-hook' and possibly other, similar hooks, but will continue to modify non-ERC hooks locally whenever possible, especially in new code. diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 23589657b2d..bf361ff91fb 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -822,7 +822,7 @@ The value `erc-interpret-controls-p' must also be t for this to work." ;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t) (define-erc-module irccontrols nil "This mode enables the interpretation of IRC control chars." - ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight) + ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight -50) (add-hook 'erc-send-modify-hook #'erc-controls-highlight) (erc--modify-local-map t "C-c C-c" #'erc-toggle-interpret-controls)) ((remove-hook 'erc-insert-modify-hook #'erc-controls-highlight) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 767a693a52e..e9d6099317f 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1278,8 +1278,8 @@ of `erc-insert-this' is t. ERC runs this hook with the buffer narrowed to the bounds of the inserted message plus a trailing newline. Built-in modules place -their hook members at depths between 20 and 80, with those from -the stamp module always running last. Use the functions +their hook members in two depth ranges: the first between -80 and +-20 and the second between 20 and 80. Use the functions `erc-find-parsed-property' and `erc-get-parsed-vector' to locate and extract the `erc-response' object for the inserted message." :group 'erc-hooks commit caea0c1649d1df96b811c1388fde396e66bc356b Author: Po Lu Date: Thu Jan 25 12:17:54 2024 +0800 Prevent matrices from remaining invalid post mini-window resize * src/androidfns.c (android_create_tip_frame): Enable building with GLYPH_DEBUG. * src/window.c (resize_mini_window_apply): Garbage the frame if F->redisplay is already set to indicate that redisplay_internal should nevertheless return to it. diff --git a/src/androidfns.c b/src/androidfns.c index bf8ab5b45cc..34f1f533684 100644 --- a/src/androidfns.c +++ b/src/androidfns.c @@ -1931,9 +1931,6 @@ android_create_tip_frame (struct android_display_info *dpyinfo, image_cache_refcount = FRAME_IMAGE_CACHE (f) ? FRAME_IMAGE_CACHE (f)->refcount : 0; -#ifdef GLYPH_DEBUG - dpyinfo_refcount = dpyinfo->reference_count; -#endif /* GLYPH_DEBUG */ gui_default_parameter (f, parms, Qfont_backend, Qnil, "fontBackend", "FontBackend", RES_TYPE_STRING); diff --git a/src/window.c b/src/window.c index 3a54f7ce7b1..915f591221d 100644 --- a/src/window.c +++ b/src/window.c @@ -5331,7 +5331,17 @@ resize_mini_window_apply (struct window *w, int delta) w->pixel_top = r->pixel_top + r->pixel_height; w->top_line = r->top_line + r->total_lines; - /* Enforce full redisplay of the frame. */ + /* Enforce full redisplay of the frame. If f->redisplay is already + set, which it generally is in the wake of a ConfigureNotify + (frame resize) event, merely setting f->redisplay is insufficient + for redisplay_internal to continue redisplaying the frame, as + redisplay_internal cannot distinguish between f->redisplay set + before it calls redisplay_window and that after, so garbage the + frame as well. */ + + if (f->redisplay) + SET_FRAME_GARBAGED (f); + /* FIXME: Shouldn't some of the caller do it? */ fset_redisplay (f); adjust_frame_glyphs (f); commit 65ea742ed5ec505837706d64690e3cc2073825c7 Author: João Távora Date: Thu Jan 25 01:37:57 2024 +0000 Eglot: try even harder to avoid other completion styles (bug#68699) Any completion style except for eglot--dumb-flex spells trouble for Eglot, for the well known reason that LSP is geared towards completion tooltips and none of Emacs' partial-completion shenanigans. This commit puts a "try-completion" function that doesn't return nil in the eglot--dumb-flex completion style so that other styles aren't tried (partial-completion, in particular, errors out). The function often doesn't do anything very useful, but at least it doesn't stop the more usual *Completions* buffer from appearing. * lisp/progmodes/eglot.el (eglot--dumb-tryc): New helper. (completion-styles-alist): Add it to the dumb-flex style. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 511000927cf..c5fbf5eb9d5 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -3060,9 +3060,13 @@ for which LSP on-type-formatting should be requested." finally (cl-return comp))) (defun eglot--dumb-allc (pat table pred _point) (funcall table pat pred t)) +(defun eglot--dumb-tryc (pat table pred point) + (if-let ((probe (funcall table pat pred nil))) + (cons probe (length probe)) + (cons pat point))) (add-to-list 'completion-category-defaults '(eglot-capf (styles eglot--dumb-flex))) -(add-to-list 'completion-styles-alist '(eglot--dumb-flex ignore eglot--dumb-allc)) +(add-to-list 'completion-styles-alist '(eglot--dumb-flex eglot--dumb-tryc eglot--dumb-allc)) (defun eglot-completion-at-point () "Eglot's `completion-at-point' function." commit ad004f10f3668d464d32ed8da18639da9bcc01bb Author: Stefan Monnier Date: Wed Jan 24 14:52:09 2024 -0500 * src/lisp.h (DOHASH): Handle rehashing (bug#68690) I gave too much credit to the comment, and didn't realize that macro was used in places that didn't obey the comment. This macro is getting pretty hideous! diff --git a/src/lisp.h b/src/lisp.h index f822417ffb1..d07d9d14e2f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2604,20 +2604,30 @@ hash_from_key (struct Lisp_Hash_Table *h, Lisp_Object key) } /* Iterate K and V as key and value of valid entries in hash table H. - The body may remove the current entry or alter its value slot, but not - mutate TABLE in any other way. */ -#define DOHASH(h, k, v) \ - for (Lisp_Object *dohash_##k##_##v##_kv = (h)->key_and_value, \ - *dohash_##k##_##v##_end = dohash_##k##_##v##_kv \ - + 2 * HASH_TABLE_SIZE (h), \ - k, v; \ - dohash_##k##_##v##_kv < dohash_##k##_##v##_end \ - && (k = dohash_##k##_##v##_kv[0], \ - v = dohash_##k##_##v##_kv[1], /*maybe unsed*/ (void)v, \ - true); \ - dohash_##k##_##v##_kv += 2) \ - if (hash_unused_entry_key_p (k)) \ - ; \ + The body may mutate the hash-table. */ +#define DOHASH(h, k, v) \ + for (Lisp_Object *dohash_##k##_##v##_base = (h)->key_and_value, \ + *dohash_##k##_##v##_kv = dohash_##k##_##v##_base, \ + *dohash_##k##_##v##_end = dohash_##k##_##v##_base \ + + 2 * HASH_TABLE_SIZE (h), \ + k, v; \ + dohash_##k##_##v##_kv < dohash_##k##_##v##_end \ + && (dohash_##k##_##v##_base == (h)->key_and_value \ + /* The `key_and_value` table has been reallocated! */ \ + || (dohash_##k##_##v##_kv \ + = (dohash_##k##_##v##_kv - dohash_##k##_##v##_base) \ + + (h)->key_and_value, \ + dohash_##k##_##v##_base = (h)->key_and_value, \ + dohash_##k##_##v##_end = dohash_##k##_##v##_base \ + + 2 * HASH_TABLE_SIZE (h), \ + /* Check again, in case the table has shrunk. */ \ + dohash_##k##_##v##_kv < dohash_##k##_##v##_end)) \ + && (k = dohash_##k##_##v##_kv[0], \ + v = dohash_##k##_##v##_kv[1], /*maybe unused*/ (void)v, \ + true); \ + dohash_##k##_##v##_kv += 2) \ + if (hash_unused_entry_key_p (k)) \ + ; \ else commit 1f3371b46e8a6a51f88c56785175b48af2a0bed7 Author: Stefan Monnier Date: Wed Jan 24 12:57:33 2024 -0500 Take stock of the wheel-up/down confusion While we're hopefully all aware of the usual confusion between the scroll operation moving the document or moving the viewport, Emacs has its very own instance of that confusion where the `mouse-wheel-down-event` variable is the one that (used to) hold the value `wheel-up` and vice versa. Thanks for Po Lu's commit 957b4f826a4 which not only fixed my change but brought that confusion to my attention. This patch doesn't fix the problem, but tries to fix the other places in the code where we did not take it into account. * doc/lispref/commands.texi (Misc Events): Mention the wheel-up/down confusion. * lisp/progmodes/flymake.el (flymake--mode-line-counter-map): * lisp/completion-preview.el (completion-preview--mouse-map): Fix wheel-up/down confusion. * lisp/mwheel.el (mouse-wheel-down-event, mouse-wheel-up-event): Fix docstrings. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 5f840ac21ec..6c8d42337d0 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -2567,6 +2567,9 @@ some kinds of systems. On other systems, other events like @code{mouse-4} and @code{wheel-up} and @code{wheel-down} events as well as the events specified in the variables @code{mouse-wheel-up-event} and @code{mouse-wheel-down-event}, defined in @file{mwheel.el}. +Beware that for historical reasons the @code{mouse-wheel-@emph{up}-event} +is the variable that holds an event that should be handled similarly to +@code{wheel-@emph{down}} and vice versa. @vindex mouse-wheel-left-event @vindex mouse-wheel-right-event diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index f552db7aa8e..6fd60f3c416 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -135,12 +135,14 @@ If this option is nil, these commands do not display any message." "" #'completion-preview-insert "C-" #'completion-at-point "" #'completion-at-point + ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events + ;; and vice versa!! "" #'completion-preview-prev-candidate "" #'completion-preview-next-candidate (key-description (vector mouse-wheel-up-event)) - #'completion-preview-prev-candidate + #'completion-preview-next-candidate (key-description (vector mouse-wheel-down-event)) - #'completion-preview-next-candidate) + #'completion-preview-prev-candidate) (defvar-local completion-preview--overlay nil) diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 1e08328c875..53042085bf6 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -34,8 +34,8 @@ ;; Implementation note: ;; ;; I for one would prefer some way of converting the mouse-4/mouse-5 -;; events into different event types, like 'mwheel-up' or -;; 'mwheel-down', but I cannot find a way to do this very easily (or +;; events into different event types, like 'wheel-up' or +;; 'wheel-down', but I cannot find a way to do this very easily (or ;; portably), so for now I just live with it. (require 'timer) @@ -63,14 +63,14 @@ They are sometimes generated by things like `xterm-mouse-mode' as well.") (defcustom mouse-wheel-down-event (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-4) - "Event used for scrolling down, beside `wheel-down', if any." + "Event used for scrolling down, beside `wheel-up', if any." :group 'mouse :type 'symbol :set #'mouse-wheel-change-button) (defcustom mouse-wheel-up-event (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-5) - "Event used for scrolling up, beside `wheel-up', if any." + "Event used for scrolling up, beside `wheel-down', if any." :group 'mouse :type 'symbol :set #'mouse-wheel-change-button) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 225f8ecf874..5974f076556 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1637,14 +1637,16 @@ correctly.") (defvar flymake--mode-line-counter-map (let ((map (make-sparse-keymap))) + ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events + ;; and vice versa!! (define-key map (vector 'mode-line mouse-wheel-down-event) #'flymake--mode-line-counter-scroll-prev) (define-key map [mode-line wheel-down] - #'flymake--mode-line-counter-scroll-prev) + #'flymake--mode-line-counter-scroll-next) (define-key map (vector 'mode-line mouse-wheel-up-event) #'flymake--mode-line-counter-scroll-next) (define-key map [mode-line wheel-up] - #'flymake--mode-line-counter-scroll-next) + #'flymake--mode-line-counter-scroll-prev) map)) (defun flymake--mode-line-counter-1 (type) commit c9705037e98a398d0e6e145f16e0ce8cdd4a8973 Author: Stefan Monnier Date: Wed Jan 24 10:21:44 2024 -0500 Fix build when CHECK_LISP_OBJECT_TYPE is set * src/lisp.h (make_lisp_symbol_internal): Fix last commit. diff --git a/src/lisp.h b/src/lisp.h index eb0ee51d9f9..f822417ffb1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1173,7 +1173,12 @@ make_lisp_symbol_internal (struct Lisp_Symbol *sym) Do not use eassert here, so that builtin symbols like Qnil compile to constants; this is needed for some circa-2024 GCCs even with -O2. */ char *symoffset = (char *) ((char *) sym - (char *) lispsym); - return TAG_PTR (Lisp_Symbol, symoffset); + /* FIXME: We need this silly `a = ... return` η-redex because otherwise GCC + complains about: + lisp.h:615:28: error: expected expression before ‘{’ token + 615 | # define LISP_INITIALLY(w) {w} */ + Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); + return a; } INLINE Lisp_Object commit a043cccb62bfd1812cedf107db327039dfdfe89b Author: Stefan Monnier Date: Wed Jan 24 08:21:26 2024 -0500 * lisp/emacs-lisp/pcase.el (Commentary:): Add paper reference diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 5ac4b289a80..4754d4e720d 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -42,6 +42,14 @@ ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. +;; While the first version was written before I knew about Racket's `match' +;; construct, the second version was significantly influenced by it, +;; so a good presentation of the underlying ideas can be found at: +;; +;; Extensible Pattern Matching in an Extensible Language +;; Sam Tobin-Hochstadt, 2010 +;; https://arxiv.org/abs/1106.2578 + ;;; Code: (require 'macroexp) commit cc861fc528b49fc459bb9a1e5054f5fd82e1b689 Author: Stefan Monnier Date: Wed Jan 24 08:16:11 2024 -0500 (struct composition): Remove dependency on hash-table internals `struct composition` kept an index into the internal `key_and_value` array of hash tables, which only worked because of details of how hash-tables are handled. Replace it with a reference to the key stored at that location in the hash-table, which saves us an indirection while at it. * src/composite.h (struct composition): Replace `hash_index` with the actual `key`. (COMPOSITION_KEY): Simplify accordingly. (mark_composite): Declare. * src/composite.c (get_composition_id): Adjust accordingly. (mark_composite): New function. * src/charset.c (mark_charset): Uncomment. * src/lisp.h (mark_charset): Declare. * src/alloc.c (garbage_collect): Call `mark_charset` and `mark_composite`. * src/pdumper.c (hash_table_contents): Remove invalid comment, since compositions aren't dumped. diff --git a/src/alloc.c b/src/alloc.c index 2a1690d2cff..ab31d21fb33 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6594,6 +6594,8 @@ garbage_collect (void) mark_terminals (); mark_kboards (); mark_threads (); + mark_charset (); + mark_composite (); mark_profiler (); #ifdef HAVE_PGTK mark_pgtkterm (); diff --git a/src/charset.c b/src/charset.c index 9633ccaaef9..4bacc011e85 100644 --- a/src/charset.c +++ b/src/charset.c @@ -2271,14 +2271,13 @@ See also `charset-priority-list' and `set-charset-priority'. */) } /* Not strictly necessary, because all charset attributes are also - reachable from `Vcharset_hash_table`. + reachable from `Vcharset_hash_table`. */ void mark_charset (void) { for (int i = 0; i < charset_table_used; i++) mark_object (charset_table[i].attributes); } -*/ void diff --git a/src/composite.c b/src/composite.c index 0b78a78fa79..111b1cea88b 100644 --- a/src/composite.c +++ b/src/composite.c @@ -321,7 +321,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, cmp = xmalloc (sizeof *cmp); cmp->method = method; - cmp->hash_index = hash_index; + cmp->key = key; cmp->glyph_len = glyph_len; cmp->offsets = xnmalloc (glyph_len, 2 * sizeof *cmp->offsets); cmp->font = NULL; @@ -673,7 +673,7 @@ Lisp_Object composition_gstring_from_id (ptrdiff_t id) { struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); - + /* FIXME: The stability of this value depends on the hash table internals! */ return HASH_VALUE (h, id); } @@ -2148,6 +2148,16 @@ of the way buffer text is examined for matching one of the rules. */) } +/* Not strictly necessary, because all those "keys" are also + reachable from `composition_hash_table`. */ +void +mark_composite (void) +{ + for (int i = 0; i < n_compositions; i++) + mark_object (composition_table[i]->key); +} + + void syms_of_composite (void) { diff --git a/src/composite.h b/src/composite.h index 37f494d69e0..4b412cea696 100644 --- a/src/composite.h +++ b/src/composite.h @@ -84,8 +84,7 @@ composition_registered_p (Lisp_Object prop) ? XCDR (XCDR (XCDR (prop))) \ : CONSP (prop) ? XCDR (prop) : Qnil) -#define COMPOSITION_KEY(cmp) \ - HASH_KEY (XHASH_TABLE (composition_hash_table), (cmp)->hash_index) +#define COMPOSITION_KEY(cmp) (cmp)->key /* Return the Nth glyph of composition specified by CMP. CMP is a pointer to `struct composition'. */ @@ -163,8 +162,8 @@ struct composition { /* Method of the composition. */ enum composition_method method; - /* Index to the composition hash table. */ - ptrdiff_t hash_index; + /* The key under which it's found in the composition hash table. */ + Lisp_Object key; /* For which font we have calculated the remaining members. The actual type is device dependent. */ @@ -200,6 +199,7 @@ extern bool find_composition (ptrdiff_t, ptrdiff_t, ptrdiff_t *, ptrdiff_t *, extern void update_compositions (ptrdiff_t, ptrdiff_t, int); extern void make_composition_value_copy (Lisp_Object); extern void syms_of_composite (void); +extern void mark_composite (void); extern void compose_text (ptrdiff_t, ptrdiff_t, Lisp_Object, Lisp_Object, Lisp_Object); diff --git a/src/lisp.h b/src/lisp.h index 82ce367392e..eb0ee51d9f9 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4073,6 +4073,7 @@ extern ptrdiff_t multibyte_chars_in_text (const unsigned char *, ptrdiff_t); extern void syms_of_character (void); /* Defined in charset.c. */ +extern void mark_charset (void); extern void init_charset (void); extern void init_charset_once (void); extern void syms_of_charset (void); diff --git a/src/pdumper.c b/src/pdumper.c index 7f1a78b4f2d..8907d25cc13 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2650,11 +2650,6 @@ hash_table_contents (struct Lisp_Hash_Table *h) * sizeof *key_and_value); ptrdiff_t n = 0; - /* Make sure key_and_value ends up in the same order; the `hash_index` - field of `struct composition` relies on it by expecting hash table - indices to stay constant across the dump. - FIXME: Remove such dependency on hash table internals (there might - be another one in `composition_gstring_from_id`). */ DOHASH (h, k, v) { key_and_value[n++] = k; commit 3018c6e7ba5d35b756aea5eed7f3981548a597b4 Author: Stefan Monnier Date: Wed Jan 24 08:07:54 2024 -0500 (DOHASH): Change calling convention This leads to simpler code in the users, and more efficient machine code because we don't repeatedly need to fetch the `table_size` and `key_and_value` fields of the hash table object. * src/lisp.h (DOHASH): Rewrite. * src/composite.c (composition_gstring_lookup_cache): Simplify. (composition_gstring_cache_clear_font): * src/print.c (print): * src/pdumper.c (hash_table_contents): * src/minibuf.c (Ftest_completion): * src/json.c (lisp_to_json_nonscalar_1): * src/emacs-module.c (module_global_reference_p): * src/comp.c (compile_function, Fcomp__compile_ctxt_to_file): * src/fns.c (Fmaphash): Adjust to new calling convention. diff --git a/src/comp.c b/src/comp.c index 25c4cb2f22c..5f28cf046b5 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4330,12 +4330,9 @@ compile_function (Lisp_Object func) declare_block (Qentry); Lisp_Object blocks = CALL1I (comp-func-blocks, func); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); - DOHASH (ht, i) - { - Lisp_Object block_name = HASH_KEY (ht, i); - if (!EQ (block_name, Qentry)) - declare_block (block_name); - } + DOHASH (ht, block_name, block) + if (!EQ (block_name, Qentry)) + declare_block (block_name); gcc_jit_block_add_assignment (retrive_block (Qentry), NULL, @@ -4343,10 +4340,8 @@ compile_function (Lisp_Object func) gcc_jit_lvalue_as_rvalue (comp.func_relocs)); - DOHASH (ht, i) + DOHASH (ht, block_name, block) { - Lisp_Object block_name = HASH_KEY (ht, i); - Lisp_Object block = HASH_VALUE (ht, i); Lisp_Object insns = CALL1I (comp-block-insns, block); if (NILP (block) || NILP (insns)) xsignal1 (Qnative_ice, @@ -4961,10 +4956,12 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, struct Lisp_Hash_Table *func_h = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); - DOHASH (func_h, i) declare_function (HASH_VALUE (func_h, i)); + DOHASH (func_h, k, v) + declare_function (v); /* Compile all functions. Can't be done before because the relocation structs has to be already defined. */ - DOHASH (func_h, i) compile_function (HASH_VALUE (func_h, i)); + DOHASH (func_h, k, v) + compile_function (v); /* Work around bug#46495 (GCC PR99126). */ #if defined (WIDE_EMACS_INT) \ diff --git a/src/composite.c b/src/composite.c index d9233fe0cc0..0b78a78fa79 100644 --- a/src/composite.c +++ b/src/composite.c @@ -643,10 +643,7 @@ static Lisp_Object gstring_hash_table; Lisp_Object composition_gstring_lookup_cache (Lisp_Object header) { - struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); - ptrdiff_t i = hash_lookup (h, header); - - return (i >= 0 ? HASH_VALUE (h, i) : Qnil); + return Fgethash (header, gstring_hash_table, Qnil); } Lisp_Object @@ -687,14 +684,9 @@ composition_gstring_cache_clear_font (Lisp_Object font_object) { struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); - DOHASH (h, i) - { - Lisp_Object k = HASH_KEY (h, i); - Lisp_Object gstring = HASH_VALUE (h, i); - - if (EQ (LGSTRING_FONT (gstring), font_object)) - hash_remove_from_table (h, k); - } + DOHASH (h, k, gstring) + if (EQ (LGSTRING_FONT (gstring), font_object)) + hash_remove_from_table (h, k); } DEFUN ("clear-composition-cache", Fclear_composition_cache, diff --git a/src/emacs-module.c b/src/emacs-module.c index 77dd2b9152c..08db39b0b0d 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -410,8 +410,8 @@ module_global_reference_p (emacs_value v, ptrdiff_t *n) struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); /* Note that we can't use `hash_lookup' because V might be a local reference that's identical to some global reference. */ - DOHASH (h, i) - if (&XMODULE_GLOBAL_REFERENCE (HASH_VALUE (h, i))->value == v) + DOHASH (h, k, val) + if (&XMODULE_GLOBAL_REFERENCE (val)->value == v) return true; /* Only used for debugging, so we don't care about overflow, just make sure the operation is defined. */ diff --git a/src/fns.c b/src/fns.c index f34e069ddbe..859df6748f7 100644 --- a/src/fns.c +++ b/src/fns.c @@ -5617,7 +5617,7 @@ If KEY is not found, return DFLT which defaults to nil. */) (Lisp_Object key, Lisp_Object table, Lisp_Object dflt) { struct Lisp_Hash_Table *h = check_hash_table (table); - ptrdiff_t i = hash_lookup_with_hash (h, key, hash_from_key (h, key)); + ptrdiff_t i = hash_lookup (h, key); return i >= 0 ? HASH_VALUE (h, i) : dflt; } @@ -5662,7 +5662,8 @@ set a new value for KEY, or `remhash' to remove KEY. (Lisp_Object function, Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); - DOHASH (h, i) call2 (function, HASH_KEY (h, i), HASH_VALUE (h, i)); + DOHASH (h, k, v) + call2 (function, k, v); return Qnil; } diff --git a/src/json.c b/src/json.c index 5434780ba13..e849ccaf722 100644 --- a/src/json.c +++ b/src/json.c @@ -361,9 +361,8 @@ lisp_to_json_nonscalar_1 (Lisp_Object lisp, json = json_check (json_object ()); count = SPECPDL_INDEX (); record_unwind_protect_ptr (json_release_object, json); - DOHASH (h, i) + DOHASH (h, key, v) { - Lisp_Object key = HASH_KEY (h, i); CHECK_STRING (key); Lisp_Object ekey = json_encode (key); /* We can't specify the length, so the string must be @@ -376,7 +375,7 @@ lisp_to_json_nonscalar_1 (Lisp_Object lisp, wrong_type_argument (Qjson_value_p, lisp); int status = json_object_set_new (json, key_str, - lisp_to_json (HASH_VALUE (h, i), conf)); + lisp_to_json (v, conf)); if (status == -1) { /* A failure can be caused either by an invalid key or diff --git a/src/lisp.h b/src/lisp.h index 09fcd6689bf..82ce367392e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2598,16 +2598,24 @@ hash_from_key (struct Lisp_Hash_Table *h, Lisp_Object key) return h->test->hashfn (key, h); } -/* Hash table iteration construct (roughly an inlined maphash): - Iterate IDXVAR as index over valid entries of TABLE. +/* Iterate K and V as key and value of valid entries in hash table H. The body may remove the current entry or alter its value slot, but not mutate TABLE in any other way. */ -#define DOHASH(TABLE, IDXVAR) \ - for (ptrdiff_t IDXVAR = 0; IDXVAR < (TABLE)->table_size; IDXVAR++) \ - if (hash_unused_entry_key_p (HASH_KEY (TABLE, IDXVAR))) \ - ; \ +#define DOHASH(h, k, v) \ + for (Lisp_Object *dohash_##k##_##v##_kv = (h)->key_and_value, \ + *dohash_##k##_##v##_end = dohash_##k##_##v##_kv \ + + 2 * HASH_TABLE_SIZE (h), \ + k, v; \ + dohash_##k##_##v##_kv < dohash_##k##_##v##_end \ + && (k = dohash_##k##_##v##_kv[0], \ + v = dohash_##k##_##v##_kv[1], /*maybe unsed*/ (void)v, \ + true); \ + dohash_##k##_##v##_kv += 2) \ + if (hash_unused_entry_key_p (k)) \ + ; \ else + void hash_table_thaw (Lisp_Object hash_table); /* Default size for hash tables if not specified. */ diff --git a/src/minibuf.c b/src/minibuf.c index 857b62d94f0..7c0c9799a60 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -2059,8 +2059,7 @@ If COLLECTION is a function, it is called with three arguments: the values STRING, PREDICATE and `lambda'. */) (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate) { - Lisp_Object tail, tem = Qnil; - ptrdiff_t i = 0; + Lisp_Object tail, tem = Qnil, arg = Qnil; CHECK_STRING (string); @@ -2079,7 +2078,7 @@ the values STRING, PREDICATE and `lambda'. */) SBYTES (string)); if (completion_ignore_case && !SYMBOLP (tem)) { - for (i = ASIZE (collection) - 1; i >= 0; i--) + for (ptrdiff_t i = ASIZE (collection) - 1; i >= 0; i--) { tail = AREF (collection, i); if (SYMBOLP (tail)) @@ -2107,24 +2106,27 @@ the values STRING, PREDICATE and `lambda'. */) else if (HASH_TABLE_P (collection)) { struct Lisp_Hash_Table *h = XHASH_TABLE (collection); - i = hash_lookup (h, string); + ptrdiff_t i = hash_lookup (h, string); if (i >= 0) { tem = HASH_KEY (h, i); + arg = HASH_VALUE (h, i); goto found_matching_key; } else - DOHASH (h, j) + DOHASH (h, k, v) { - i = j; - tem = HASH_KEY (h, i); + tem = k; Lisp_Object strkey = (SYMBOLP (tem) ? Fsymbol_name (tem) : tem); if (!STRINGP (strkey)) continue; if (BASE_EQ (Fcompare_strings (string, Qnil, Qnil, strkey, Qnil, Qnil, completion_ignore_case ? Qt : Qnil), - Qt)) - goto found_matching_key; + Qt)) + { + arg = v; + goto found_matching_key; + } } return Qnil; found_matching_key: ; @@ -2141,7 +2143,7 @@ the values STRING, PREDICATE and `lambda'. */) if (!NILP (predicate)) { return HASH_TABLE_P (collection) - ? call2 (predicate, tem, HASH_VALUE (XHASH_TABLE (collection), i)) + ? call2 (predicate, tem, arg) : call1 (predicate, tem); } else diff --git a/src/pdumper.c b/src/pdumper.c index 9c9a1ff382c..7f1a78b4f2d 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2655,10 +2655,10 @@ hash_table_contents (struct Lisp_Hash_Table *h) indices to stay constant across the dump. FIXME: Remove such dependency on hash table internals (there might be another one in `composition_gstring_from_id`). */ - DOHASH (h, i) + DOHASH (h, k, v) { - key_and_value[n++] = HASH_KEY (h, i); - key_and_value[n++] = HASH_VALUE (h, i); + key_and_value[n++] = k; + key_and_value[n++] = v; } return key_and_value; diff --git a/src/print.c b/src/print.c index c99d8d5fe3a..c6a3dba3163 100644 --- a/src/print.c +++ b/src/print.c @@ -1285,9 +1285,9 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* Remove unnecessary objects, which appear only once in OBJ; that is, whose status is Qt. */ struct Lisp_Hash_Table *h = XHASH_TABLE (Vprint_number_table); - DOHASH (h, i) - if (EQ (HASH_VALUE (h, i), Qt)) - Fremhash (HASH_KEY (h, i), Vprint_number_table); + DOHASH (h, k, v) + if (EQ (v, Qt)) + Fremhash (k, Vprint_number_table); } }