From: F. Jason Park Date: Mon, 19 Dec 2022 03:01:40 +0000 (-0800) Subject: Add erc-button helper for substituting command keys X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8184a815aff52cbf1f1b8680d80af2fbf2dce248;p=emacs.git Add erc-button helper for substituting command keys * lisp/erc/erc-button.el (erc-button-mode, erc-button-enable): Warn if `erc-button-alist' contains deprecated FORM field in `nicknames' entry. (erc-button-alist): Discourage arbitrary sexp form for third item of entries and offer more useful bounds-modifying function in its place. Mention that anything other than `erc-button-buttonize-nicks' is deprecated as the FORM field in a `nicknames' entry. Bump package-version even though this doesn't introduce a visible change in the default value. (erc-button--maybe-warn-arbitrary-sexp): Add helper for validating third `erc-button-alist' field. (erc-button--check-nicknames-entry): Add helper to check for deprecated items in `erc-button-alist'. (erc-button--preserve-bounds): Add function to serve as default value for `erc-button--modify-nick-function). (erc-button--modify-nick-function): Add new variable to hold a function that filters nickname bounds when buttonizing. (erc-button--phantom-users, erc-button--add-phantom-speaker, erc-button--phantom-users-mode): Add new internal minor mode for treating unseen speakers of PRIVMSGs as known members of the server for things like coloring nicks during buffer playback. (erc-button--get-user-from-speaker-naive): Add temporary utility function to scrape nick from speaker in narrowed buffer. This will be replaced by an account-aware version in next major ERC release. (erc-button-add-nickname-buttons): Accommodate function variant for "form" field of `erc-button-alist' entries. Minor optimizations. This function will likely become the primary juncture for applying text properties that support nickname-related user-intelligence features. (erc-button-add-buttons-1): Show warning when arbitrary sexp for third "form" field encountered. Accommodate binary function instead. (erc-button--substitute-command-keys-in-region): Add helper function for applying key substitutions in ERC warning messages. (erc-button--display-error-notice-with-keys): Add new helper function for displaying ad hoc warnings that possibly require key substitution. (erc-button--display-error-notice-with-keys-and-warn): Add variant of `erc-button--display-error-notice-with-keys' that also emits warnings. * lisp/erc/erc-networks.el (erc-networks--ensure-announced, erc-networks--on-MOTD-end): Use new key-substitutions helper from erc-button. * test/lisp/erc/erc-tests.el (erc-button--display-error-notice-with-keys): New test. * test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld: Add unknown speaker in channel for phantom store to handle. Currently requires manual intervention to leverage. (Bug#60933.) --- diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 48f6a5d1794..33e69f3b0b8 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -52,7 +52,8 @@ ;;;###autoload(autoload 'erc-button-mode "erc-button" nil t) (define-erc-module button nil "This mode buttonizes all messages according to `erc-button-alist'." - ((add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append) + ((erc-button--check-nicknames-entry) + (add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-send-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-complete-functions #'erc-button-next-function) (erc--modify-local-map t "" #'erc-button-previous)) @@ -165,8 +166,17 @@ REGEXP is the string matching text around the button or a symbol BUTTON is the number of the regexp grouping actually matching the button. This is ignored if REGEXP is `nicknames'. -FORM is a Lisp expression which must eval to true for the button to - be added. +FORM is a Lisp symbol for a special variable whose value must be + true for the button to be added. Alternatively, when REGEXP is + not `nicknames', FORM can be a function whose arguments are BEG + and END, the bounds of the button in the current buffer. It's + expected to return a cons of (possibly identical) bounds or + nil, to deny. For the extent of the call, all face options + defined for the button module are re-bound, shadowing + themselves, so the function is free to change their values. + When regexp is the special symbol `nicknames', FORM must be the + symbol `erc-button-buttonize-nicks'. Specifying anything else + is deprecated. CALLBACK is the function to call when the user push this button. CALLBACK can also be a symbol. Its variable value will be used @@ -176,7 +186,7 @@ PAR is a number of a regexp grouping whose text will be passed to CALLBACK. There can be several PAR arguments. If REGEXP is `nicknames', these are ignored, and CALLBACK will be called with the nickname matched as the argument." - :package-version '(ERC . "5.5") + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(repeat (list :tag "Button" (choice :tag "Matches" @@ -277,22 +287,127 @@ specified by `erc-button-alist'." (concat "\\<" (regexp-quote (car elem)) "\\>") entry))))))))))) +(defun erc-button--maybe-warn-arbitrary-sexp (form) + (if (and (symbolp form) (special-variable-p form)) + (symbol-value form) + (unless (get 'erc-button--maybe-warn-arbitrary-sexp 'warned-arbitrary-sexp) + (put 'erc-button--maybe-warn-arbitrary-sexp 'warned-arbitrary-sexp t) + (lwarn 'erc :warning + (concat "Arbitrary sexps for the third FORM" + " slot of `erc-button-alist' entries" + " have been deprecated."))) + (eval form t))) + +(defun erc-button--check-nicknames-entry () + ;; This helper exists because the module is defined after its options. + (when-let (((eq major-mode 'erc-mode)) + (entry (alist-get 'nicknames erc-button-alist))) + (unless (eq 'erc-button-buttonize-nicks (nth 1 entry)) + (erc-button--display-error-notice-with-keys-and-warn + "Values other than `erc-button-buttonize-nicks' in the third slot of " + "the `nicknames' entry of `erc-button-alist' are deprecated.")))) + +(defun erc-button--preserve-bounds (bounds _ server-user _) + "Return BOUNDS.\n\n(fn BOUNDS NICKNAME SERVER-USER CHANNEL-USER)" + (and server-user bounds)) + +;; This variable is intended to serve as a "core" to be wrapped by +;; (built-in) modules during setup. It's unclear whether +;; `add-function's practice of removing existing advice before +;; re-adding it is desirable when integrating modules since we're +;; mostly concerned with ensuring one "piece" precedes or follows +;; another (specific piece), which may not yet (or ever) be present. + +(defvar erc-button--modify-nick-function #'erc-button--preserve-bounds + "Function to possibly modify aspects of nick being buttonized. +Called with four args: BOUNDS NICKNAME SERVER-USER CHANNEL-USER. +BOUNDS is a cons of (BEG . END) marking the position of the nick +in the current message, which occupies the whole of the narrowed +buffer. BEG is normally also point. NICKNAME is a case-mapped +string without text properties. SERVER-USER and CHANNEL-USER are +the nick's `erc-server-users' entry and its associated (though +possibly nil) `erc-channel-user' object. The function should +return BOUNDS or a suitable replacement to indicate that +buttonizing ought to proceed, and nil if it should be inhibited.") + +(defvar-local erc-button--phantom-users nil) + +(defun erc-button--add-phantom-speaker (args) + "Maybe substitute fake `server-user' for speaker at point." + (pcase args + (`(,bounds ,downcased-nick nil ,channel-user) + (list bounds downcased-nick + ;; Like `with-memoization' but don't cache when value is nil. + (or (gethash downcased-nick erc-button--phantom-users) + (and-let* ((user (erc-button--get-user-from-speaker-naive + (car bounds)))) + (puthash downcased-nick user erc-button--phantom-users))) + channel-user)) + (_ args))) + +(define-minor-mode erc-button--phantom-users-mode + "Minor mode to recognize unknown speakers. +Expect to be used by module setup code for creating placeholder +users on the fly during history playback. Treat an unknown +PRIVMSG speaker, like , as if they were present in a 353 and +are thus a member of the channel. However, don't bother creating +an actual `erc-channel-user' object because their status prefix +is unknown. Instead, just spoof an `erc-server-user' by applying +early (outer), args-filtering advice wrapping +`erc-button--modify-nick-function'." + :interactive nil + (if erc-button--phantom-users-mode + (progn + (add-function :filter-args (local 'erc-button--modify-nick-function) + #'erc-button--add-phantom-speaker '((depth . -90))) + (setq erc-button--phantom-users (make-hash-table :test #'equal))) + (remove-function (local 'erc-button--modify-nick-function) + #'erc-button--add-phantom-speaker) + (kill-local-variable 'erc-nicks--phantom-users))) + +;; FIXME replace this after making ERC account-aware. +(defun erc-button--get-user-from-speaker-naive (point) + "Return `erc-server-user' object for nick at POINT." + (when-let* + (((eql ?< (char-before point))) + ((eq (get-text-property point 'font-lock-face) 'erc-nick-default-face)) + (parsed (erc-get-parsed-vector point))) + (pcase-let* ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) + (make-erc-server-user + :nickname nick + :host (and (not (string-empty-p host)) host) + :login (and (not (string-empty-p login)) login))))) + (defun erc-button-add-nickname-buttons (entry) "Search through the buffer for nicknames, and add buttons." (let ((form (nth 2 entry)) (fun (nth 3 entry)) bounds word) - (when (or (eq t form) - (eval form t)) + (when (eq form 'erc-button-buttonize-nicks) + (setq form (and (symbol-value form) erc-button--modify-nick-function))) + (when (or (functionp form) + (eq t form) + (and form (erc-button--maybe-warn-arbitrary-sexp form))) (goto-char (point-min)) (while (erc-forward-word) (when (setq bounds (erc-bounds-of-word-at-point)) (setq word (buffer-substring-no-properties (car bounds) (cdr bounds))) - (when (or (and (erc-server-buffer-p) (erc-get-server-user word)) - (and erc-channel-users (erc-get-channel-user word))) - (erc-button-add-button (car bounds) (cdr bounds) - fun t (list word)))))))) + (let* ((erc-button-face erc-button-face) + (erc-button-mouse-face erc-button-mouse-face) + (erc-button-nickname-face erc-button-nickname-face) + (down (erc-downcase word)) + (cuser (and erc-channel-users + (gethash down erc-channel-users))) + (user (or (and cuser (car cuser)) + (and erc-server-users + (gethash down erc-server-users))))) + (when (or (not (functionp form)) + (setq bounds + (funcall form bounds down user (cdr cuser)))) + (erc-button-add-button (car bounds) (cdr bounds) + fun t (list word))))))))) (defun erc-button-add-buttons-1 (regexp entry) "Search through the buffer for matches to ENTRY and add buttons." @@ -304,7 +419,14 @@ specified by `erc-button-alist'." (fun (nth 3 entry)) (data (mapcar #'match-string-no-properties (nthcdr 4 entry)))) (when (or (eq t form) - (eval form t)) + (and (functionp form) + (let* ((erc-button-face erc-button-face) + (erc-button-mouse-face erc-button-mouse-face) + (erc-button-nickname-face erc-button-nickname-face) + (rv (funcall form start end))) + (when rv + (setq end (cdr rv) start (car rv))))) + (erc-button--maybe-warn-arbitrary-sexp form)) (erc-button-add-button start end fun nil data regexp))))) (defun erc-button-remove-old-buttons () @@ -513,6 +635,70 @@ and `apropos' for other symbols." (message "@%s is %d:%02d local time" beats hours minutes))) +(defun erc-button--substitute-command-keys-in-region (beg end) + "Replace command in region with keys and return new bounds" + (let* ((o (buffer-substring beg end)) + (s (substitute-command-keys o))) + (unless (equal o s) + (setq erc-button-face nil)) + (delete-region beg end) + (insert s)) + (cons beg (point))) + +;;;###autoload +(defun erc-button--display-error-notice-with-keys (&optional parsed buffer + &rest strings) + "Add help keys to STRINGS for configuration-related admonishments. +Return inserted result. Expect PARSED to be an `erc-response' +object, a string, or nil. Expect BUFFER to be a buffer, a string, +or nil. As a special case, allow PARSED to be a buffer as long +as BUFFER is a string or nil. If STRINGS contains any trailing +non-strings, concatenate leading string members before applying +`format'. Otherwise, just concatenate everything." + (when (stringp buffer) + (push buffer strings) + (setq buffer nil)) + (when (stringp parsed) + (push parsed strings) + (setq parsed nil)) + (when (bufferp parsed) + (cl-assert (null buffer)) + (setq buffer parsed + parsed nil)) + (let* ((op (if (seq-every-p #'stringp (cdr strings)) + #'concat + (let ((head (pop strings))) + (while (stringp (car strings)) + (setq head (concat head (pop strings)))) + (push head strings)) + #'format)) + (string (apply op strings)) + (erc-insert-post-hook + (cons (lambda () + (setq string (buffer-substring (point-min) + (1- (point-max))))) + erc-insert-post-hook)) + (erc-button-alist + `((,(rx "\\[" (group (+ (not "]"))) "]") 0 + erc-button--substitute-command-keys-in-region + erc-button-describe-symbol 1) + ,@erc-button-alist))) + (erc-display-message parsed '(notice error) (or buffer 'active) string) + string)) + +;;;###autoload +(defun erc-button--display-error-notice-with-keys-and-warn (&rest args) + "Like `erc-button--display-error-notice-with-keys' but also warn." + (let ((string (apply #'erc-button--display-error-notice-with-keys args))) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (with-syntax-table lisp-mode-syntax-table + (skip-syntax-forward "^-")) + (forward-char) + (display-warning + 'erc (buffer-substring-no-properties (point) (point-max)))))) + (provide 'erc-button) ;;; erc-button.el ends here diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 4337d633cfa..dd481032e7e 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -67,6 +67,9 @@ (declare-function erc-server-process-alive "erc-backend" (&optional buffer)) (declare-function erc-set-active-buffer "erc" (buffer)) +(declare-function erc-button--display-error-notice-with-keys + (parsed &rest strings)) + ;; Variables (defgroup erc-networks nil @@ -1310,12 +1313,11 @@ shutting down the connection." Copy source (prefix) from MOTD-ish message as a last resort." ;; The 004 handler never ran; see 2004-03-10 Diane Murray in change log (unless erc-server-announced-name - (setq erc-server-announced-name (erc-response.sender parsed)) - (erc-display-error-notice - parsed (concat "Failed to determine server name. Using \"" - erc-server-announced-name "\" instead." - " If this was unexpected, consider reporting it via " - (substitute-command-keys "\\[erc-bug]") "."))) + (require 'erc-button) + (erc-button--display-error-notice-with-keys + parsed "Failed to determine server name. Using \"" + (setq erc-server-announced-name (erc-response.sender parsed)) "\" instead" + ". If this was unexpected, consider reporting it via \\[erc-bug]" ".")) nil) (defun erc-unset-network-name (_nick _ip _reason) @@ -1493,9 +1495,9 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let (memq (erc--target-symbol erc--target) erc-networks--bouncer-targets))) proc) - (let ((m (concat "Unexpected state detected. Please report via " - (substitute-command-keys "\\[erc-bug]") "."))) - (erc-display-error-notice parsed m)))) + (require 'erc-button) + (erc-button--display-error-notice-with-keys + parsed "Unexpected state detected. Please report via \\[erc-bug]."))) ;; For now, retain compatibility with erc-server-NNN-functions. (or (erc-networks--ensure-announced proc parsed) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 6e66de53edd..b155f85ab8a 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1790,4 +1790,65 @@ connection." (put 'erc-mname-enable 'definition-name 'mname) (put 'erc-mname-disable 'definition-name 'mname)))))) + +;; XXX move erc-button tests to new file if more added. +(require 'erc-button) + +;; See also `erc-scenarios-networks-announced-missing' in +;; erc-scenarios-misc.el for a more realistic example. +(ert-deftest erc-button--display-error-notice-with-keys () + (with-current-buffer (get-buffer-create "*fake*") + (let ((mode erc-button-mode) + (inhibit-message noninteractive) + erc-modules + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (erc-mode) + (erc-tests--set-fake-server-process "sleep" "1") + (erc--initialize-markers (point) nil) + (erc-button-mode +1) + (should (equal (erc-button--display-error-notice-with-keys + "If \\[erc-bol] fails, " + "see \\[erc-bug] or `erc-mode-map'.") + "*** If C-a fails, see M-x erc-bug or `erc-mode-map'.")) + (goto-char (point-min)) + + (ert-info ("Keymap substitution succeeds") + (erc-button-next) + (should (looking-at "C-a")) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (erc-button-press-button) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "erc-bol" nil t))) + (erc-button-next) + (erc-button-previous) ; end of interval correct + (should (looking-at "a fails"))) + + (ert-info ("Extended command mapping succeeds") + (erc-button-next) + (should (looking-at "M-x erc-bug")) + (erc-button-press-button) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "erc-bug" nil t)))) + + (ert-info ("Symbol-description face preserved") ; mutated by d-e-n-w-k + (erc-button-next) + (should (equal (get-text-property (point) 'font-lock-face) + '(erc-button erc-error-face))) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (should (eq erc-button-face 'erc-button))) ; extent evaporates + + (ert-info ("Format when trailing args include non-strings") + (should (equal (erc-button--display-error-notice-with-keys + "abc" " %d def" " 45%s" 123 '\6) + "*** abc 123 def 456"))) + + (when noninteractive + (unless mode + (erc-button-mode -1)) + (kill-buffer "*Help*") + (kill-buffer))))) + ;;; erc-tests.el ends here diff --git a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld index 58df79e19fa..f34ae02f4e4 100644 --- a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld +++ b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld @@ -27,6 +27,7 @@ (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:02] alice: Here come the lovers, full of joy and mirth.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:07] bob: According to the fool's bolt, sir, and such dulcet diseases.") (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:10] alice: And hang himself. I pray you, do my greeting.") + (0 ":someone!~u@abcdefg.irc PRIVMSG #chan :[07:04:10] hi everyone.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:18] bob: And you sat smiling at his cruel prey.") (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:21] alice: Or never after look me in the face.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:25] bob: If that may be, than all is well. Come, sit down, every mother's son, and rehearse your parts. Pyramus, you begin: when you have spoken your speech, enter into that brake; and so every one according to his cue.")