From 5d97ec5342327e03f042cd88ec24609a73bcdd42 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 18 Dec 2022 19:01:40 -0800 Subject: [PATCH 2/3] [5.6] Add erc-button helper for substituting command keys TODO: add ERC-NEWS entry for `erc-button-alist' field-type deprecation once ERC 5.5 is released and a new section for 5.6 is added. * lisp/erc/erc-button.el (erc-button-buttonize-nicks): Change type to include functions. (erc-button-alist): Deprecate arbitrary sexp form for third item of entries and offer more useful bounds-modifying function in its place. (erc-button--maybe-warn-arbitrary-sexp): Add helper for validating third `erc-button-alist' field. (erc-button-add-nickname-buttons): Accommodate function variant for "form" field of `erc-button-alist' entries. Minor optimizations. (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 new function to serve as default key-substitution function item in `erc-button-alist'. (erc-button--display-error-notice-with-keys): Add new helper function for displaying ad hoc warnings that possibly require key substitution. * 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. --- lisp/erc/erc-button.el | 94 +++++++++++++++++++++++++++++++++----- lisp/erc/erc-networks.el | 20 ++++---- test/lisp/erc/erc-tests.el | 55 ++++++++++++++++++++++ 3 files changed, 148 insertions(+), 21 deletions(-) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 979d6e7e94..c2fde7c268 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -102,8 +102,15 @@ erc-button-wrap-long-urls :type '(choice integer boolean)) (defcustom erc-button-buttonize-nicks t - "Flag indicating whether nicks should be buttonized or not." - :type 'boolean) + "Flag indicating whether nicks should be buttonized or not. +When the value is a function, it must accept four arguments: the +bounds of the nick in the current message (as a cons), the nick +itself (case-mapped and without text properties), the nick's +`erc-server-users' entry, and a (possibly nil) `erc-channel-user' +object. It must return replacement bounds when buttonizing +should proceed and nil otherwise." + :package-version '(ERC . "5.6") + :type '(choice boolean function)) (defcustom erc-button-rfc-url "https://tools.ietf.org/html/rfc%s" "URL used to browse RFC references. @@ -165,8 +172,16 @@ erc-button-alist 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, it 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. Important: different arguments are passed + when REGEXP is `nickname'; see `erc-button-buttonize-nicks' for + details. 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 +191,7 @@ erc-button-alist 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." - :version "29.1" + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(repeat (list :tag "Button" (choice :tag "Matches" @@ -275,22 +290,47 @@ erc-button-add-buttons (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-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 'erc-button-buttonize-nicks form) + (setq form (symbol-value form))) + (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 (and user + (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." @@ -302,7 +342,14 @@ erc-button-add-buttons-1 (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 () @@ -511,6 +558,29 @@ erc-button-beats-to-time (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))) + +(defun erc-button--display-error-notice-with-keys (parsed &rest strings) + "Add help keys to STRING for corner-case admonishments." + (when (stringp parsed) + (push parsed strings) + (setq parsed nil)) + (let ((string (apply #'concat strings)) + (erc-button-alist + `((,(rx "\\[" (group (+ (not "]"))) "]") 0 + erc-button--substitute-command-keys-in-region + erc-button-describe-symbol 1) + ,@erc-button-alist))) + (erc-display-error-notice parsed string))) + (provide 'erc-button) ;;; erc-button.el ends here diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 4337d633cf..dd481032e7 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -67,6 +67,9 @@ erc-session-server (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 @@ erc-networks--ensure-announced 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 @@ erc-networks-on-MOTD-end (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 85506c3d27..cbe9d04d05 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1359,4 +1359,59 @@ define-erc-module--local (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-button-mode +1) + (erc-tests--set-fake-server-process "sleep" "1") + (erc-tests--send-prep) + (erc-button--display-error-notice-with-keys + "If \\[erc-bol] fails, " + "see \\[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 + + (when noninteractive + (unless mode + (erc-button-mode -1)) + (kill-buffer "*Help*") + (kill-buffer))))) + ;;; erc-tests.el ends here -- 2.38.1