Re: bug#73798: 31.0.50; ERC 5.7: New extensibility focused match API
"J.P." <[email protected]> Thu, 05 Dec 2024 22:54:02 -0800
| Newsgroups | gmane.emacs.erc.general |
|---|---|
| Message-ID | <[email protected]> |
--=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable v4. Improve examples in manual. Add utility for match predicates and handlers to retrieve prior (successful) match objects. "J.P." <[email protected]> writes: > In the imagined use cases described up thread, it likely won't be > uncommon for a module to manage multiple match types, with multiple > members in `erc-match-functions' and `erc-text-matched-hook'. > > Related predicates, handlers, and methods may therefore need to > communicate across matches, for example, to know whether a match has > already occurred for the current message. So it may well make sense to > add another slot to the base type whose value is shared among all > objects during matching and filtering. An alist probably makes the most > sense for this. I didn't end up adding such a slot, although I still think one would likely be useful. > If knowledge of prior matches turns out to be desirable and commonplace > enough, we can keep and expose a record of all successful matches. > (Doing this might further justify the current "split" design with its > distinct predicate and handler phases.) One slight challenge here would > be the necessity for some form of indirection to access such a record > (because tacking on a list of prior match objects as a visible "has a" > property of later objects would make printing them somewhat nasty). So, > instead of another slot, we could maybe offer an object-retrieval > utility keyed by constructor function. This I did add, provisionally naming it `erc-match-get-match'. The revised documentation follows. See attached diff for changes. File: erc.info, Node: Match API, Next: Options, Prev: Module Loading, Up: Advanced Usage 5.6 Match API =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D This section describes the low-level =E2=80=98match=E2=80=99 API introduc= ed in ERC 5.7. For basic, options-oriented usage, please see the doc strings for option =E2=80=98erc-pal-highlight-type=E2=80=99 and friends in the =E2=80=98erc-= match=E2=80=99 group. Unfortunately, those options often prove insufficient for more granular filtering and highlighting needs, and advanced users eventually outgrow them. However, under the hood, those options all use the same foundational =E2=80=98erc-match=E2=80=99 API, which centers around a =E2= =80=98cl-defstruct=E2=80=99 =E2=80=9Ctype=E2=80=9D of the same name: -- Struct: erc-match predicate spkr-beg spkr-end body-beg sender nick command handler This is a =E2=80=98cl-struct=E2=80=99 type that contains some handy = facts about the message being processed. That message's formatted body occupies the narrowed buffer when ERC creates and provides access to each =E2=80=98erc-match=E2=80=99 instance. To use this interface, you ad= d a =E2=80=9Cconstructor=E2=80=9D-like function to the hook =E2=80=98erc= -match-functions=E2=80=99: -- User Option: erc-match-functions An abnormal hook for which each member accepts the parameters named above as an =E2=80=98&rest=E2=80=99-style plist and retur= ns a new =E2=80=98erc-match=E2=80=99 instance. A function can also be a= traditional =E2=80=98cl-defstruct=E2=80=99-provided constructor belonging t= o a =E2=80=9Csubtype=E2=80=9D you've defined. The only slot you definitely need to specify is =E2=80=98predicate= =E2=80=99. Both it and =E2=80=98handler=E2=80=99 are functions that take a single ar= gument: the instance itself. As its name implies, =E2=80=98predicate=E2=80=99 m= ust return non-=E2=80=98nil=E2=80=99 if =E2=80=98handler=E2=80=99, whose return= value ERC ignores, should run. A few slots, like =E2=80=98spkr-beg=E2=80=99, =E2=80=98spkr-end=E2= =80=99, and =E2=80=98nick=E2=80=99, may surprise you. The first two are =E2=80=98nil=E2=80=99 for non-chat messages,= like those displayed for =E2=80=98JOIN=E2=80=99 events. The =E2=80=98nick=E2= =80=99 slot can likewise be =E2=80=98nil=E2=80=99 if the sender of the message is a domain-style host name, such as =E2=80=98irc.example.org=E2=80=99, which it often is for information= al messages, like =E2=80=98*** #chan was created on 2023-12-26 00:36:42=E2=80=99. To locate the start of the just-inserted message, use =E2=80=98body-= beg=E2=80=99, a marker indicating the beginning of the message proper. Don't forget: all inserted messages include a trailing newline. If you want to extract just the message body's text, use the function =E2=80=98erc-match-get-message-body=E2=80=99: -- Function: erc-match-get-message-body match Takes an =E2=80=98erc-match=E2=80=99 instance and returns a str= ing containing the message body, sans trailing newline and any leading speaker or decorative component, such as =E2=80=98erc-notice-pr= efix=E2=80=99. Although module authors may want to subclass this struct, everyday users can just instantiate it directly (it's =E2=80=9Cconcrete=E2=80=9D). This= is especially handy for one-off tasks or simple customizations in your =E2=80=98init.el= =E2=80=99. To do this, define a function that invokes its constructor: (require 'erc-match) (defvar my-mentions 0) (defun my-match (&rest plist) (apply #'erc-match :predicate (lambda (_) (search-forward "my-project" nil t)) :handler (lambda (_) (cl-incf my-mentions)) plist)) (add-hook 'erc-match-functions #'my-match) (setopt erc-prompt (lambda () (format "%d!" my-mentions))) Here, the user could just as well shove the incrementer into the =E2=80=98predicate=E2=80=99 body, since =E2=80=98handler=E2=80=99 is set = to =E2=80=98ignore=E2=80=99 by default (however, some frown at the notion of a predicate exhibiting side effects). The user could also choose to concentrate only on chat content by filtering out non-=E2=80=98PRIVMSG=E2=80=99 messages via the s= lot =E2=80=98command=E2=80=99. In cases where you need a handler to only run when some other match type appearing earlier in =E2=80=98erc-match-functions=E2=80=99 has _not_= yielded a match, use: -- Function: erc-match-get-match constructor When called from a =E2=80=98handler=E2=80=99 or a =E2=80=98predicate= =E2=80=99 body, this utility returns instances of prior =E2=80=98erc-match-functions=E2=80=99 tha= t have already successfully matched the current message. Use this for deduplication and to share data between match instances. For a detailed example of matching for non-highlighting purposes, see the =E2=80=98jabbycat=E2=80=99 demo module, available on ERC's dev-orient= ed package archive: <https://emacs-erc.gitlab.io/bugs/archive/jabbycat.html>. If you're in a hurry, check out =E2=80=98erc-desktop-notifications.el=E2=80= =99, which ships with ERC, but please ignore the parts that involve adapting the global setup (and teardown) business to a buffer-local context. Since your module is declared =E2=80=98local=E2=80=99, as per the modern convention,= you won't be needing such code, so feel free to do things like add local members to =E2=80=98erc-match-functions=E2=80=99 in your module's definition. 5.6.1 Highlighting ------------------ End users and third-party modules likely want to manage and apply faces themselves. If that's you, feel free to skip to the more extensive examples further below. However, for the sake of completeness, it's worth mentioning that in a pinch, you can likely piggyback atop the highlighting functionality already provided by =E2=80=98match=E2=80=99 to= support its many high-level options. (require 'erc-match) (defvar my-keywords `((foonet ("#chan" ,(rx bow (or "foo" "bar" "baz") eow))))) (defface my-face '((t (:inherit font-lock-constant-face :weight bold))) "My face.") (defun my-match (&rest plist) (apply #'erc-match-opt-keyword :data (and-let* ((chans (alist-get (erc-network) my-keyword= s)) ((cdr (assoc (erc-target) chans))))) :face 'my-face plist)) (add-hook 'erc-match-functions #'my-match) Here, the user leverages a handy subtype of =E2=80=98erc-match=E2=80=99, = called =E2=80=98erc-match-opt-keyword=E2=80=99, which actually descends directly= from another, intermediate =E2=80=98erc-match=E2=80=99 type: -- Struct: erc-match-traditional category face data part Use this type or one of its descendants (see below) if you want =E2=80=98erc-text-matched-hook=E2=80=99 to run alongside (after) the= =E2=80=98handler=E2=80=99 slot's default highlighter, =E2=80=98erc-match-highlight=E2=80=99, o= n every match for which the =E2=80=98category=E2=80=99 slot's value is non-=E2=80= =98nil=E2=80=99 (it becomes the argument provided for the hook's MATCH-TYPE parameter). Much more important, however, is =E2=80=98part=E2=80=99. This slot = determines what portion of the message is being highlighted or otherwise operated on. It can be any symbol, but the ones with predefined methods are =E2=80=98nick=E2=80=99, =E2=80=98message=E2=80=99, =E2=80=98all=E2= =80=99, =E2=80=98keyword=E2=80=99, =E2=80=98nick-or-keyword=E2=80=99, and =E2=80=98nick-or-mention=E2=80=99. The complement to the =E2=80=98part=E2=80=99 slot is =E2=80=98data= =E2=80=99, which holds the value of the module's option corresponding to the specific type. For example, ERC initializes the =E2=80=98data=E2=80=99 slot for the =E2=80=98erc-match-opt-pal=E2=80=99 type with the value of =E2=80=98= erc-pals=E2=80=99. The default handler, =E2=80=98erc-match-highlight=E2=80=99, does its= work by deferring to a purpose-built =E2=80=9Cmethod=E2=80=9D meant to handl= e =E2=80=98part=E2=80=99-based highlighting: -- Method on erc-match-traditional: erc-match-highlight-by-part instance part You can override this method by =E2=80=9Cspecializing=E2=80=9D = on any subclassed =E2=80=98erc-match-traditional=E2=80=99 type and/or = non-reserved PART, such as one known only to your =E2=80=98init.el=E2=80=99 = or (informally) associated with your package by its library =E2=80=9Cnamespace= =E2=80=9D. You likely won't be needing these, but just for the record, other options-based types similar to =E2=80=98erc-match-opt-keyword=E2=80=99 in= clude =E2=80=98erc-match-opt-current-nick=E2=80=99, =E2=80=98erc-match-opt-fool= =E2=80=99, =E2=80=98erc-match-opt-pal=E2=80=99, and =E2=80=98erc-match-opt-dangerous-host=E2=80=99. (If you're familiar = with this module's user options, you'll notice some parallels here.) 5.6.1.1 Complete Highlighting Examples ...................................... As mentioned, most users needn't bother with the piggybacking approach detailed above, which can oftentimes be more complicated than starting afresh. Here's a more elaborate, module-like example demoing some highlighting with a bespoke =E2=80=98erc-match=E2=80=99-derived type: ;;; erc-org-markup.el --- Org Markup for ERC -*- lexical-binding: t;= -*- (require 'erc-match) (require 'org) (defgroup erc-org-markup nil "Highlight messages written in Org markup." :group 'erc) (defcustom erc-org-markup-targets '("#org") "List of buffers in which to highlight messages." :type '(repeat string)) (define-erc-module org-markup nil "Local module that treats messages as having Org markup." ((erc-org-markup-ensure-buffer) (if (member (erc-target) erc-org-markup-targets) (progn (add-hook 'erc-match-functions #'erc-org-markup 0 t) (add-to-invisibility-spec '(org-link))) (erc-org-markup-mode -1))) ((remove-hook 'erc-match-functions #'erc-org-markup t) (remove-from-invisibility-spec '(org-link))) 'local) (cl-defstruct (erc-org-markup (:include erc-match (predicate #'erc-org-markup--should-p) (handler #'erc-org-markup--fontify)) (:constructor erc-org-markup)) "Match type to highlight messages written in Org markup.") (defun erc-org-markup--should-p (match) "Return non-nil if MATCH describes an Org-markup worthy message." (and erc-org-markup-mode (erc-match-nick match))) (defun erc-org-markup-ensure-buffer () "Return existing global work buffer or create it anew." (or (get-buffer "*erc-org-markup*") (with-current-buffer (get-buffer-create "*erc-org-markup*") (org-mode) (make-local-variable 'org-link-parameters) (setf (plist-get (cdr (assoc "https" org-link-parameters)) :activate-func) #'erc-org-markup-activate-link) (setq-local org-hide-emphasis-markers t) (current-buffer)))) (defun erc-org-markup--fontify (match) "Overwrite text properties in MATCH'd message with Org's." (save-restriction (narrow-to-region (erc-match-body-beg match) (1- (point-max))) (let ((buffer (current-buffer))) (with-current-buffer (erc-org-markup-ensure-buffer) (save-window-excursion (buffer-swap-text buffer) (font-lock-ensure) (buffer-swap-text buffer)))))) (defun erc-org-markup-activate-link (beg end path _) "Ensure Org https link between BEG and END has `erc-button' props." (erc-button-add-button beg end #'browse-url-button-open-url nil (list (concat "https:" path)) "")) (provide 'erc-org-markup) ;;; erc-org-markup.el ends here Finally, here's a slightly more complete demo module: a superficial rewrite of =E2=80=98erc-colorize.el=E2=80=99 by Sylvain Rousseau <https://github.com/thisirs/erc-colorize.git>. ;;; erc-colorize.el --- Per-user message faces -*- lexical-binding: = t; -*- (require 'ring) (require 'erc-match) (require 'erc-button) ; for `erc-button-add-face' (defgroup erc-colorize nil "Highlight messages with per-user faces from a limited pool." :group 'erc) (defface erc-colorize-1 '((t :inherit font-lock-keyword-face)) "Auto-assigned face for distinguishing between messages.") (defface erc-colorize-2 '((t :inherit font-lock-type-face)) "Auto-assigned face for distinguishing between messages.") (defface erc-colorize-3 '((t :inherit font-lock-string-face)) "Auto-assigned face for distinguishing between messages.") (defface erc-colorize-4 '((t :inherit font-lock-constant-face)) "Auto-assigned face for distinguishing between messages.") (defface erc-colorize-5 '((t :inherit font-lock-preprocessor-face)) "Auto-assigned face for distinguishing between messages.") (defface erc-colorize-6 '((t :inherit font-lock-variable-name-face)) "Auto-assigned face for distinguishing between messages.") (defface erc-colorize-7 '((t :inherit font-lock-warning-face)) "Auto-assigned face for distinguishing between messages.") (defvar erc-colorize-faces '(erc-colorize-1 erc-colorize-2 erc-colorize-3 erc-colorize-4 erc-colorize-5 erc-colorize-6 erc-colorize-7) "List of faces to apply to chat messages.") (defvar-local erc-colorize-ring nil "Ring of cons cells of the form (NICK . FACE).") (define-erc-module colorize nil "Highlight messages from a speaker with the same face in target bu= ffers." ((when (erc-target) (add-hook 'erc-match-functions 'erc-colorize 0 t) (setq erc-colorize-ring (make-ring (length erc-colorize-faces))= ))) ((remove-hook 'erc-match-functions 'erc-colorize t)) 'local) (defun erc-colorize-color (ring nick) "Return a face to use for string NICK. Prefer an existing entry in RING. If there isn't one, pick the first unused face in `erc-colorize-faces'. Otherwise, pick the least used face." (cond ((and-let* ((i (catch 'found (dotimes (i (ring-length ring)) (when (equal (car (ring-ref ring i)) nick) (throw 'found i)))))) (ring-insert ring (ring-remove ring i)) (cdr (ring-ref ring 0)))) ((let ((used (mapcar #'cdr (ring-elements ring)))) (and-let* ((face (catch 'found (dolist (face erc-colorize-faces) (unless (member face used) (throw 'found face)))))) (prog1 face (ring-insert ring (cons nick face)))))) ((let ((older (ring-remove ring))) (ring-insert ring (cons nick (cdr older))) (cdr older))))) (cl-defstruct (erc-colorize ( :include erc-match (predicate #'erc-colorize-nick) (handler #'erc-colorize-message)) (:constructor erc-colorize)) "An `erc-match' type for the `erc-colorize' module.") (defun erc-colorize-message (match) "Highlight MATCH's full message with a face from `erc-colorize-fac= es'." (erc-button-add-face (point-min) (1- (point-max)) (erc-colorize-color erc-colorize-ring (erc-colorize-nick match)= ))) (provide 'erc-colorize) ;;; erc-colorize.el ends here --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0000-v3-v4.diff From 08b84a699644ccbc08e1c3e630090297f259269a Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Thu, 5 Dec 2024 20:23:23 -0800 Subject: [PATCH 0/3] *** NOT A PATCH *** *** BLURB HERE *** F. Jason Park (3): [5.7] Use speaker-end marker in ERC insertion hooks [5.7] Introduce lower level erc-match API [5.7] Use erc-match-type API for erc-desktop-notifications doc/misc/erc.texi | 490 ++++++++++++++++-- etc/ERC-NEWS | 22 + lisp/erc/erc-desktop-notifications.el | 69 ++- lisp/erc/erc-fill.el | 20 +- lisp/erc/erc-match.el | 428 ++++++++++++++- lisp/erc/erc.el | 48 +- .../erc/erc-desktop-notifications-tests.el | 115 ++++ test/lisp/erc/erc-match-tests.el | 214 +++++++- 8 files changed, 1296 insertions(+), 110 deletions(-) create mode 100644 test/lisp/erc/erc-desktop-notifications-tests.el Interdiff: diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 49dbfe3623a..995254d544e 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -2150,12 +2150,26 @@ Match API Here, the user could just as well shove the incrementer into the @samp{predicate} body, since @samp{handler} is set to @code{ignore} by default (however, some frown at the notion of a predicate exhibiting -side effects). Likewise, the user could also choose to concentrate only -on chat content by filtering out non-@samp{PRIVMSG} messages via the -slot @samp{command}. +side effects). The user could also choose to concentrate only on chat +content by filtering out non-@samp{PRIVMSG} messages via the slot +@samp{command}. -For a detailed example of matching without highlighting, see the -@samp{jabbycat} demo module, available on ERC's dev-oriented package +In cases where you need a handler to only run when some other match type +appearing earlier in @code{erc-match-functions} has _not_ yielded a +match, use: + +@defun erc-match-get-match constructor + +When called from a @samp{handler} or a @samp{predicate} body, this +utility returns instances of prior @code{erc-match-functions} that have +already successfully matched the current message. Use this for +deduplication and to share data between match instances. + +@end defun + +@noindent +For a detailed example of matching for non-highlighting purposes, see +the @samp{jabbycat} demo module, available on ERC's dev-oriented package archive: @uref{https://emacs-erc.gitlab.io/bugs/archive/jabbycat.html}. If you're in a hurry, check out @file{erc-desktop-notifications.el}, which ships with ERC, but please ignore the parts that involve adapting @@ -2169,10 +2183,12 @@ Match API @subsection Highlighting @cindex highlighting -Third-party modules likely want to manage and apply faces themselves. -However, in a pinch you can just piggyback atop the highlighting -functionality already provided by @samp{match} to support its many -high-level options. +End users and third-party modules likely want to manage and apply faces +themselves. If that's you, feel free to skip to the more extensive +examples further below. However, for the sake of completeness, it's +worth mentioning that in a pinch, you can likely piggyback atop the +highlighting functionality already provided by @samp{match} to support +its many high-level options. @lisp (require 'erc-match) @@ -2235,58 +2251,189 @@ Match API @end deftp @noindent -You likely won't be needing these, but for the sake of completeness, -other options-based types similar to @code{erc-match-opt-keyword} -include @code{erc-match-opt-current-nick}, @code{erc-match-opt-fool}, +You likely won't be needing these, but just for the record, other +options-based types similar to @code{erc-match-opt-keyword} include +@code{erc-match-opt-current-nick}, @code{erc-match-opt-fool}, @code{erc-match-opt-pal}, and @code{erc-match-opt-dangerous-host}. (If you're familiar with this module's user options, you'll notice some parallels here.) -And, finally, here's a more elaborate, module-like example demoing -highlighting based on the @code{erc-match-traditional} type: +@anchor{highlighting examples} +@subsubsection Complete Highlighting Examples +@cindex highlighting examples + +As mentioned, most users needn't bother with the piggybacking approach +detailed above, which can oftentimes be more complicated than starting +afresh. Here's a more elaborate, module-like example demoing some +highlighting with a bespoke @code{erc-match}-derived type: @lisp -;; -*- lexical-binding: t; -*- +;;; erc-org-markup.el --- Org Markup for ERC -*- lexical-binding: t; -*- (require 'erc-match) -(require 'erc-button) - -(defvar my-keywords - `((foonet ("#chan" ,(rx bow (or "foo" "bar" "baz") eow))))) - -(defface my-keyword '((t (:underline (:color "tomato" :style wave)))) - "My face.") - -(defun my-get-keyword () - (and-let* ((chans (alist-get (erc-network) my-keywords)) - ((cdr (assoc (erc-target) chans)))))) +(require 'org) + +(defgroup erc-org-markup nil + "Highlight messages written in Org markup." + :group 'erc) + +(defcustom erc-org-markup-targets '("#org") + "List of buffers in which to highlight messages." + :type '(repeat string)) + +(define-erc-module org-markup nil + "Local module that treats messages as having Org markup." + ((erc-org-markup-ensure-buffer) + (if (member (erc-target) erc-org-markup-targets) + (progn + (add-hook 'erc-match-functions #'erc-org-markup 0 t) + (add-to-invisibility-spec '(org-link))) + (erc-org-markup-mode -1))) + ((remove-hook 'erc-match-functions #'erc-org-markup t) + (remove-from-invisibility-spec '(org-link))) + 'local) + +(cl-defstruct (erc-org-markup + (:include erc-match + (predicate #'erc-org-markup--should-p) + (handler #'erc-org-markup--fontify)) + (:constructor erc-org-markup)) + "Match type to highlight messages written in Org markup.") + +(defun erc-org-markup--should-p (match) + "Return non-nil if MATCH describes an Org-markup worthy message." + (and erc-org-markup-mode (erc-match-nick match))) + +(defun erc-org-markup-ensure-buffer () + "Return existing global work buffer or create it anew." + (or (get-buffer "*erc-org-markup*") + (with-current-buffer (get-buffer-create "*erc-org-markup*") + (org-mode) + (make-local-variable 'org-link-parameters) + (setf (plist-get (cdr (assoc "https" org-link-parameters)) + :activate-func) + #'erc-org-markup-activate-link) + (setq-local org-hide-emphasis-markers t) + (current-buffer)))) + +(defun erc-org-markup--fontify (match) + "Overwrite text properties in MATCH'd message with Org's." + (save-restriction + (narrow-to-region (erc-match-body-beg match) (1- (point-max))) + (let ((buffer (current-buffer))) + (with-current-buffer (erc-org-markup-ensure-buffer) + (save-window-excursion + (buffer-swap-text buffer) + (font-lock-ensure) + (buffer-swap-text buffer)))))) + +(defun erc-org-markup-activate-link (beg end path _) + "Ensure Org https link between BEG and END has `erc-button' props." + (erc-button-add-button beg end #'browse-url-button-open-url nil + (list (concat "https:" path)) "")) + +(provide 'erc-org-markup) + +;;; erc-org-markup.el ends here +@end lisp -(cl-defstruct (my-match (:include erc-match-opt-keyword - (data (my-get-keyword)) - (face 'my-keyword)) - (:constructor my-match))) +@noindent +Finally, here's a slightly more complete demo module: a superficial +rewrite of @file{erc-colorize.el} by Sylvain Rousseau +@uref{https://github.com/thisirs/erc-colorize.git}. -(add-hook 'erc-match-functions #'my-match) +@lisp +;;; erc-colorize.el --- Per-user message faces -*- lexical-binding: t; -*- -(cl-defmethod erc-match-highlight-by-part ((instance my-match) - (_ (eql keyword))) - "Highlight keywords by merging instead of clobbering." - (dolist (pat (my-match-data instance)) - (goto-char (my-match-body-beg instance)) - (while (re-search-forward pat nil t) - (erc-button-add-face (match-beginning 0) (match-end 0) - (my-match-face instance))))) +(require 'ring) +(require 'erc-match) +(require 'erc-button) ; for `erc-button-add-face' + +(defgroup erc-colorize nil + "Highlight messages with per-user faces from a limited pool." + :group 'erc) + +(defface erc-colorize-1 '((t :inherit font-lock-keyword-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-2 '((t :inherit font-lock-type-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-3 '((t :inherit font-lock-string-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-4 '((t :inherit font-lock-constant-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-5 '((t :inherit font-lock-preprocessor-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-6 '((t :inherit font-lock-variable-name-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-7 '((t :inherit font-lock-warning-face)) + "Auto-assigned face for distinguishing between messages.") + +(defvar erc-colorize-faces '(erc-colorize-1 + erc-colorize-2 + erc-colorize-3 + erc-colorize-4 + erc-colorize-5 + erc-colorize-6 + erc-colorize-7) + "List of faces to apply to chat messages.") + +(defvar-local erc-colorize-ring nil + "Ring of cons cells of the form (NICK . FACE).") + +(define-erc-module colorize nil + "Highlight messages from a speaker with the same face in target buffers." + ((when (erc-target) + (add-hook 'erc-match-functions 'erc-colorize 0 t) + (setq erc-colorize-ring (make-ring (length erc-colorize-faces))))) + ((remove-hook 'erc-match-functions 'erc-colorize t)) + 'local) + +(defun erc-colorize-color (ring nick) + "Return a face to use for string NICK. +Prefer an existing entry in RING. If there isn't one, pick the first +unused face in `erc-colorize-faces'. Otherwise, pick the least used +face." + (cond + ((and-let* ((i (catch 'found + (dotimes (i (ring-length ring)) + (when (equal (car (ring-ref ring i)) nick) + (throw 'found i)))))) + (ring-insert ring (ring-remove ring i)) + (cdr (ring-ref ring 0)))) + ((let ((used (mapcar #'cdr (ring-elements ring)))) + (and-let* ((face (catch 'found + (dolist (face erc-colorize-faces) + (unless (member face used) + (throw 'found face)))))) + (prog1 face + (ring-insert ring (cons nick face)))))) + ((let ((older (ring-remove ring))) + (ring-insert ring (cons nick (cdr older))) + (cdr older))))) + +(cl-defstruct (erc-colorize ( :include erc-match + (predicate #'erc-colorize-nick) + (handler #'erc-colorize-message)) + (:constructor erc-colorize)) + "An `erc-match' type for the `erc-colorize' module.") + +(defun erc-colorize-message (match) + "Highlight MATCH's full message with a face from `erc-colorize-faces'." + (erc-button-add-face (point-min) (1- (point-max)) + (erc-colorize-color erc-colorize-ring + (erc-colorize-nick match)))) + +(provide 'erc-colorize) + +;;; erc-colorize.el ends here @end lisp -@noindent -Note that in the method body, you @emph{could} technically skip to the -beginning of the last match for the first go around because the match -data from the @samp{predicate} is still fresh. Also, while the method -could simply call @code{my-get-keyword} directly instead of accessing -the @samp{data} slot and also reference the @code{my-keyword} face -instead of using the @samp{face} slot, other methods may need to share -@samp{data} or alter @samp{face}. - @node Options @section Options diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index dba7a708567..8fcb83bb471 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -751,6 +751,9 @@ erc-match-highlight-by-part (defvar erc-match-highlight-matched nil "Matched `erc-match' instance in `erc-text-matched-hook'.") +(defvar erc-match--instances nil + "Alist mapping constructors to successful `erc-match' instances.") + (defun erc-match-highlight (instance) "Dispatch `erc-match-highlight-by-part' on INSTANCE's `:part' slot. Run `erc-text-matched-hook' when INSTANCE's `category' slot is non-nil." @@ -775,6 +778,12 @@ erc-match-get-message-body "Return the message body in the narrowed buffer for match INSTANCE." (buffer-substring (erc-match-body-beg instance) (1- (point-max)))) +(defun erc-match-get-match (constructor) + "Return successful `erc-match' instance for CONSTRUCTOR, if any. +Expect to be called only from `erc-match' :predicate and :handler +functions as well as `erc-text-matched-hook' members." + (alist-get constructor erc-match--instances)) + (defun erc-match--run-match (constructor spkr-beg spkr-end body-beg nick sender command) "Run :handler for for `erc-match' instance if :predicate returns non-nil. @@ -791,6 +800,7 @@ erc-match--run-match ((goto-char (point-min))) ((funcall (erc-match-predicate instance) instance))) (funcall (erc-match-handler instance) instance) + (push (cons constructor instance) erc-match--instances) nil)) (defun erc-match--message () @@ -812,7 +822,8 @@ erc-match--message (skip-syntax-forward "-") (point))) ((point-min))))) - (command (erc--check-msg-prop 'erc--cmd))) + (command (erc--check-msg-prop 'erc--cmd)) + (erc-match--instances ())) (with-syntax-table erc-match-syntax-table (run-hook-wrapped 'erc-match-functions #'erc-match--run-match spkr-beg spkr-end body-beg nick -- 2.47.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.7-Use-speaker-end-marker-in-ERC-insertion-hooks.patch From 32433800695a358da1d81b0a02388adedf619948 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Sun, 6 Oct 2024 23:17:40 -0700 Subject: [PATCH 1/3] [5.7] Use speaker-end marker in ERC insertion hooks * lisp/erc/erc-fill.el (erc-fill-wrap): Use `erc--offset-marker' instead of heuristics for finding the beginning of the message proper. * lisp/erc/erc.el (erc--send-action-display): Use `erc--ensure-offset-prop'. (erc--ensure-offset-prop): New function. Only works for `erc--message-speaker-catalog' entries, which all (currently) end in "%m". If any were to gain a "footer" component after their "%m", this would need to be modified, possibly to require an extra `catalog-key' parameter that could then be queried at runtime for a symbol property specifying the footer length as a negative offset. (erc--add-msg-prop): New function. (erc--offset-marker): New variable. (erc--with-offset-marker): New macro. (erc-insert-line): Run insertion hooks in `erc--with-offset-marker'. (erc--determine-speaker-message-format-args) (erc--format-speaker-input-message) (erc-ctcp-query-ACTION): Use `erc--ensure-offset-prop'. In the latter, don't set statusmsg "%s" to the target name. (erc-make-notice): Set `erc--offset' msg prop to the length of the `erc--notice-prefix', which includes a trailing space. Don't do the same for the fallback case of `erc-display-message-highlight' because some format specs contain leading characters that are basically analogs of `erc-notice-prefix'. Examining each prematurely to formulate a guess that may never be used is wasteful, and just going with 0 would sometimes be wrong or destructive, such as on subsequent passes for "compound" `erc-display-message' type parameters specified by `erc-display-error-notice', etc. (erc-display-msg): Run send hooks in `erc--with-offset-marker'. --- lisp/erc/erc-fill.el | 20 ++++++++++-------- lisp/erc/erc.el | 48 +++++++++++++++++++++++++++++++++++--------- 2 files changed, 51 insertions(+), 17 deletions(-) diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index 13f1dbf266c..338008d442b 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -707,14 +707,18 @@ erc-fill-wrap (funcall erc-fill--wrap-length-function)) (and-let* ((msg-prop (erc--check-msg-prop 'erc--msg)) ((not (eq msg-prop 'unknown)))) - (when-let* ((e (erc--get-speaker-bounds)) - (b (pop e)) - ((or erc-fill--wrap-action-dedent-p - (not (erc--check-msg-prop 'erc--ctcp - 'ACTION))))) - (goto-char e)) - (skip-syntax-forward "^-") - (forward-char) + (let ((dedentp (or erc-fill--wrap-action-dedent-p + (not (erc--check-msg-prop 'erc--ctcp + 'ACTION))))) + (if (and dedentp erc--offset-marker) + (goto-char erc--offset-marker) + ;; No marker means `datestamp' or refilling via + ;; `erc-fill--wrap-unmerge-on-date-stamp', etc. + (when-let* ((dedentp) + (bounds (erc--get-speaker-bounds))) + (goto-char (cdr bounds))) + (skip-syntax-forward "^-") + (forward-char))) (cond ((eq msg-prop 'datestamp) (when erc-fill--wrap-rejigger-last-message (set-marker erc-fill--wrap-last-msg (point-min))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index ad279a0ff66..3425f4ad021 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3188,7 +3188,8 @@ erc--send-action-display (let ((erc-current-message-catalog erc--message-speaker-catalog)) (erc-display-message nil nil (current-buffer) 'ctcp-action-input ?p (erc-get-channel-membership-prefix nick) - ?n (erc--speakerize-nick nick) ?m string))))) + ?n (erc--speakerize-nick nick) + ?m (erc--ensure-offset-prop string)))))) (defun erc--send-action (target string force) "Display STRING, then send to TARGET as a \"CTCP ACTION\" message." @@ -3212,6 +3213,11 @@ erc--ensure-spkr-prop `((erc--spkr . ,nick) ,@overrides ,@erc--msg-prop-overrides)))) nick) +(defun erc--ensure-offset-prop (message) + "Add `erc--offset' msg prop for string MESSAGE." + (erc--add-msg-prop 'erc--offset (- (length message))) + message) + (defun erc-string-invisible-p (string) "Check whether STRING is invisible or not. I.e. any char in it has the `invisible' property set." @@ -3326,6 +3332,13 @@ erc--memq-msg-prop ((consp haystack))) (memq needle haystack))) +(defun erc--add-msg-prop (prop val) + "Add PROP and VAL to `erc--msg-props' or `erc--msg-prop-overrides'." + (cond (erc--msg-props + (puthash prop val erc--msg-props)) + (erc--msg-prop-overrides + (setf (alist-get prop erc--msg-prop-overrides) val)))) + (defmacro erc--get-inserted-msg-beg-at (point at-start-p) (macroexp-let2* nil ((point point) (at-start-p at-start-p)) @@ -3450,6 +3463,20 @@ erc--insert-line-function (defvar erc--insert-marker nil "Internal override for `erc-insert-marker'.") +(defvar erc--offset-marker nil + "Demarcates the header/body partition in a message.") + +(defmacro erc--with-offset-marker (&rest body) + "Run BODY in insertion-narrowed buffer with `erc--offset-marker' present." + `(let ((erc--offset-marker + (and-let* ((offset (erc--check-msg-prop 'erc--offset)) + (side (if (natnump offset) (point-min) (1- (point-max))))) + (remhash 'erc--offset erc--msg-props) + (copy-marker (+ side offset))))) + ,@body + (when erc--offset-marker + (set-marker erc--offset-marker nil)))) + (define-obsolete-function-alias 'erc-display-line-1 'erc-insert-line "30.1") (defun erc-insert-line (string buffer) "Insert STRING in an `erc-mode' BUFFER. @@ -3507,8 +3534,9 @@ erc-insert-line ;; run insertion hook, with point at restored location (save-restriction (narrow-to-region insert-position (point)) - (run-hooks 'erc-insert-modify-hook) - (run-hooks 'erc-insert-post-hook) + (erc--with-offset-marker + (run-hooks 'erc-insert-modify-hook) + (run-hooks 'erc-insert-post-hook)) (when erc-remove-parsed-property (remove-text-properties (point-min) (point-max) '(erc-parsed nil tags nil))) @@ -6435,7 +6463,7 @@ erc--determine-speaker-message-format-args (if inputp 'input-query-notice 'query-notice) (if inputp 'input-chan-notice 'chan-notice)))) ?p (or prefix "") ?n (erc--speakerize-nick nick disp-nick) - ?s (or statusmsg "") ?m message)) + ?s (or statusmsg "") ?m (erc--ensure-offset-prop message))) (defcustom erc-show-speaker-membership-status nil "Whether to prefix speakers with their channel status. @@ -6569,7 +6597,7 @@ erc--format-speaker-input-message (erc--msg-prop-overrides (push (cons 'erc--msg key) erc--msg-prop-overrides))) (erc-format-message key ?p pfx ?n (erc--speakerize-nick nick) - ?m message)) + ?m (erc--ensure-offset-prop message))) (propertize (concat "> " message) 'font-lock-face 'erc-input-face))) (defun erc-echo-notice-in-default-buffer (s parsed buffer _sender) @@ -6879,12 +6907,12 @@ erc-ctcp-query-ACTION (if selfp (if stsmsg 'ctcp-action-statusmsg-input 'ctcp-action-input) (if stsmsg 'ctcp-action-statusmsg 'ctcp-action)) - ?s (or stsmsg to) + ?s (or stsmsg "") ?p (or (and (erc-channel-user-p prefix) (erc-get-channel-membership-prefix prefix)) "") ?n (erc--speakerize-nick nick dispnm) - ?m s)))))) + ?m (erc--ensure-offset-prop s))))))) (defvar erc-ctcp-query-CLIENTINFO-hook '(erc-ctcp-query-CLIENTINFO)) @@ -7867,6 +7895,7 @@ erc-make-notice "Notify the user of MESSAGE." (when erc-minibuffer-notice (message "%s" message)) + (erc--add-msg-prop 'erc--offset (length erc-notice-prefix)) (erc-highlight-notice (concat erc-notice-prefix message))) (defun erc-highlight-error (s) @@ -8366,8 +8395,9 @@ erc-display-msg (insert (erc--format-speaker-input-message line) "\n") (save-restriction (narrow-to-region insert-position (point)) - (run-hooks 'erc-send-modify-hook) - (run-hooks 'erc-send-post-hook) + (erc--with-offset-marker + (run-hooks 'erc-send-modify-hook) + (run-hooks 'erc-send-post-hook)) (cl-assert (> (- (point-max) (point-min)) 1)) (add-text-properties (point-min) (1+ (point-min)) (erc--order-text-properties-from-hash -- 2.47.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-5.7-Introduce-lower-level-erc-match-API.patch From 21e7bb341e971617367246e491f70cbbf0bcb8aa Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Sat, 3 Jun 2023 02:01:29 -0700 Subject: [PATCH 2/3] [5.7] Introduce lower level erc-match API * doc/misc/erc.texi (Module Loading): move this portion of the Modules chapter to a new node under the Advanced chapter. (Match API): New node under the Advanced chapter. Update menus. * lisp/erc/erc-match.el (erc-pal-highlight-type) (erc-fool-highlight-type) (erc-dangerous-host-highlight-type): Add `nick-or-mention' variant. (erc-text-matched-hook): Doc. (erc-match-functions): New option. (erc-add-entry-to-list) (erc-remove-entry-from-list): Clear options cache. (erc-match) (erc-match-traditional) (erc-match-opt-current-nick) (erc-match-opt-keyword) (erc-match-opt-user) (erc-match-opt-fool) (erc-match-opt-pal) (erc-match-opt-dangerous-host): New struct types. (erc-match--opt-pat-cache): New variable. (erc-match--opt-pat-ttl): New variable. (erc-match--opt-pat): New struct type. (erc-match--opt-pat-cache-clear) (erc-match--opt-pat-cache-clear-all) (erc-match--opt-pat-get) (erc-match--opt-pat-make) (erc-match--opt-pat-kw-make) (erc-match--opt-pat-addr-beg-make) (erc-match--opt-pat-addr-end-make) (erc-match--current-nick-p) (erc-match--keyword-p) (erc-match--user-nuh-or-mention-p): New functions. (erc-match-highlight-by-part): New generic function and methods. (erc-match-highlight-matched): New variable. (erc-match--instances): New variable. (erc-match-highlight): New function. (erc-match-get-message-body): New function. (erc-match-get-match): New function (erc-match--run-match): New function. (erc-match--message): New function. (erc-match-use-legacy-logic-p): New variable. (erc-match-message): Move body to `erc-match--message-legacy. Rework as thin wrapper. (erc-match--message-legacy): New function with body of former `erc-match-message'. (erc-log-matches): Rework to be slightly less wasteful. * test/lisp/erc/erc-match-tests.el (erc-match-tests--perform): Shadow `erc-match--opt-pat-cache'. (erc-match-message/pal/nick/legacy) (erc-match-message/fool/nick/legacy) (erc-match-message/dangerous-host/nick/legacy): New tests. (erc-match-tests--hl-type-nick-or-mention): New function. (erc-match-message/pal/nick-or-mention) (erc-match-message/fool/nick-or-mention) (erc-match-message/dangerous-host/nick-or-mention) (erc-match-message/pal/message/legacy) (erc-match-message/fool/message/legacy) (erc-match-message/dangerous-host/message/legacy) (erc-match-message/pal/all/legacy) (erc-match-message/fool/all/legacy) (erc-match-message/dangerous-host/all/legacy) (erc-match-message/current-nick/nick-or-keyword/legacy) (erc-match-message/keyword/keyword/legacy) (erc-log-matches/legacy) (erc-match-functions/api/non-parts-based) (erc-match-functions/api/parts-based): New tests. (Bug#73798) --- doc/misc/erc.texi | 490 +++++++++++++++++++++++++++---- lisp/erc/erc-match.el | 428 +++++++++++++++++++++++++-- test/lisp/erc/erc-match-tests.el | 214 +++++++++++++- 3 files changed, 1047 insertions(+), 85 deletions(-) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 0f6b6b8c5be..995254d544e 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -81,6 +81,8 @@ Top * SASL:: Authenticating via SASL. * Sample Configuration:: An example configuration file. * Integrations:: Integrations available for ERC. +* Module Loading:: How ERC loads modules. +* Match API:: Custom matching and highlighting. * Options:: Options that are available for ERC. @end detailmenu @@ -664,63 +666,6 @@ Modules And unlike global toggles, none of these ever mutates @code{erc-modules}. -@c FIXME add section to Advanced chapter for creating modules, and -@c move this there. -@anchor{Module Loading} -@subheading Loading -@cindex module loading - -ERC loads internal modules in alphabetical order and third-party -modules as they appear in @code{erc-modules}. When defining your own -module, take care to ensure ERC can find it. An easy way to do that -is by mimicking the example in the doc string for -@code{define-erc-module} (also shown below). For historical reasons, -ERC falls back to @code{require}ing features. For example, if some -module @code{my-module} in @code{erc-modules} lacks a corresponding -@code{erc-my-module-mode} command, ERC will attempt to load the -library @code{erc-my-module} prior to connecting. If this fails, ERC -signals an error. Users defining personal modules in an init file -should @code{(provide 'erc-my-module)} somewhere to placate ERC. -Dynamically generating modules on the fly is not supported. - -Some older built-in modules have a second name along with a second -minor-mode toggle, which is just a function alias for its primary -counterpart. For practical reasons, ERC does not define a -corresponding variable alias because contending with indirect -variables complicates bookkeeping tasks, such as persisting module -state across IRC sessions. New modules should definitely avoid -defining aliases without a good reason. - -Some packages have been known to autoload a module's definition -instead of its minor-mode command, which severs the link between the -library and the module. This means that enabling the mode by invoking -its command toggle isn't enough to load its defining library. As -such, packages should only supply module-related autoload cookies with -an actual @code{autoload} form for their module's minor-mode command, -like so: - -@lisp -;;;###autoload(autoload 'erc-my-module-mode "erc-my-module" nil t) -(define-erc-module my-module nil - "My doc string." - ((add-hook 'erc-insert-post-hook #'erc-my-module-on-insert-post)) - ((remove-hook 'erc-insert-post-hook #'erc-my-module-on-insert-post))) -@end lisp - -@noindent -As implied earlier, packages can usually omit such cookies entirely so -long as their module's prefixed name matches that of its defining -library and the library's provided feature. - -Finally, packages have also been observed to run -@code{erc-update-modules} in top-level forms, forcing ERC to take -special precautions to avoid recursive invocations. Another -unfortunate practice is mutating @code{erc-modules} itself upon -loading @code{erc}, possibly by way of an autoload. Doing this tricks -Customize into displaying the widget for @code{erc-modules} -incorrectly, with built-in modules moved from the predefined checklist -to the user-provided free-form area. - @c PRE5_4: Document every option of every module in its own subnode @@ -733,6 +678,8 @@ Advanced Usage * SASL:: Authenticating via SASL. * Sample Configuration:: An example configuration file. * Integrations:: Integrations available for ERC. +* Module Loading:: How ERC loads modules. +* Match API:: Custom matching and highlighting. * Options:: Options that are available for ERC. @detailmenu @@ -2059,6 +2006,435 @@ display-buffer @end itemize @end table +@node Module Loading +@section Module Loading +@cindex module loading + +ERC loads internal modules in alphabetical order and third-party +modules as they appear in @code{erc-modules}. When defining your own +module, take care to ensure ERC can find it. An easy way to do that +is by mimicking the example in the doc string for +@code{define-erc-module} (also shown below). For historical reasons, +ERC falls back to @code{require}ing features. For example, if some +module @code{my-module} in @code{erc-modules} lacks a corresponding +@code{erc-my-module-mode} command, ERC will attempt to load the +library @code{erc-my-module} prior to connecting. If this fails, ERC +signals an error. Users defining personal modules in an init file +should @code{(provide 'erc-my-module)} somewhere to placate ERC. +Dynamically generating modules on the fly is not supported. + +Some older built-in modules have a second name along with a second +minor-mode toggle, which is just a function alias for its primary +counterpart. For practical reasons, ERC does not define a +corresponding variable alias because contending with indirect +variables complicates bookkeeping tasks, such as persisting module +state across IRC sessions. New modules should definitely avoid +defining aliases without a good reason. + +Some packages have been known to autoload a module's definition +instead of its minor-mode command, which severs the link between the +library and the module. This means that enabling the mode by invoking +its command toggle isn't enough to load its defining library. As +such, packages should only supply module-related autoload cookies with +an actual @code{autoload} form for their module's minor-mode command, +like so: + +@lisp +;;;###autoload(autoload 'erc-my-module-mode "erc-my-module" nil t) +(define-erc-module my-module nil + "My doc string." + ((add-hook 'erc-insert-post-hook #'erc-my-module-on-insert-post)) + ((remove-hook 'erc-insert-post-hook #'erc-my-module-on-insert-post))) +@end lisp + +@noindent +As implied earlier, packages can usually omit such cookies entirely so +long as their module's prefixed name matches that of its defining +library and the library's provided feature. + +Finally, packages have also been observed to run +@code{erc-update-modules} in top-level forms, forcing ERC to take +special precautions to avoid recursive invocations. Another +unfortunate practice is mutating @code{erc-modules} itself upon +loading @code{erc}, possibly by way of an autoload. Doing this tricks +Customize into displaying the widget for @code{erc-modules} +incorrectly, with built-in modules moved from the predefined checklist +to the user-provided free-form area. + +@node Match API +@section Match API +@cindex low-level match + +This section describes the low-level @samp{match} @acronym{API} +introduced in ERC 5.7. For basic, options-oriented usage, please see +the doc strings for option @code{erc-pal-highlight-type} and friends in +the @code{erc-match} group. Unfortunately, those options often prove +insufficient for more granular filtering and highlighting needs, and +advanced users eventually outgrow them. However, under the hood, those +options all use the same foundational @code{erc-match} API, which +centers around a @code{cl-defstruct} @dfn{type} of the same name: + +@deftp {Struct} erc-match @ + predicate spkr-beg spkr-end body-beg sender nick command handler + + This is a @code{cl-struct} type that contains some handy facts about + the message being processed. That message's formatted body occupies + the narrowed buffer when ERC creates and provides access to each + @code{erc-match} instance. To use this interface, you add a + @dfn{constructor}-like function to the hook + @code{erc-match-functions}: + + @defopt erc-match-functions + + An abnormal hook for which each member accepts the parameters named + above as an @samp{&rest}-style plist and returns a new + @code{erc-match} instance. A function can also be a traditional + @code{cl-defstruct}-provided constructor belonging to a @dfn{subtype} + you've defined. + + @end defopt + + The only slot you definitely need to specify is @samp{predicate}. + Both it and @samp{handler} are functions that take a single argument: + the instance itself. As its name implies, @samp{predicate} must + return non-@code{nil} if @samp{handler}, whose return value ERC + ignores, should run. + + A few slots, like @samp{spkr-beg}, @samp{spkr-end}, and @samp{nick}, + may surprise you. The first two are @code{nil} for non-chat messages, + like those displayed for @samp{JOIN} events. The @samp{nick} slot can + likewise be @code{nil} if the sender of the message is a domain-style + host name, such as @samp{irc.example.org}, which it often is for + informational messages, like @samp{*** #chan was created on 2023-12-26 + 00:36:42}. + + To locate the start of the just-inserted message, use @samp{body-beg}, + a marker indicating the beginning of the message proper. Don't + forget: all inserted messages include a trailing newline. If you want + to extract just the message body's text, use the function + @code{erc-match-get-message-body}: + + @defun erc-match-get-message-body match + + Takes an @code{erc-match} instance and returns a string containing the + message body, sans trailing newline and any leading speaker or + decorative component, such as @code{erc-notice-prefix}. + + @end defun + +@end deftp + +@noindent +Although module authors may want to subclass this struct, everyday users +can just instantiate it directly (it's @dfn{concrete}). This is +especially handy for one-off tasks or simple customizations in your +@file{init.el}. To do this, define a function that invokes its +constructor: + +@lisp +(require 'erc-match) + +(defvar my-mentions 0) + +(defun my-match (&rest plist) + (apply #'erc-match + :predicate (lambda (_) (search-forward "my-project" nil t)) + :handler (lambda (_) (cl-incf my-mentions)) + plist)) + +(add-hook 'erc-match-functions #'my-match) +(setopt erc-prompt (lambda () (format "%d!" my-mentions))) +@end lisp + +@noindent +Here, the user could just as well shove the incrementer into the +@samp{predicate} body, since @samp{handler} is set to @code{ignore} by +default (however, some frown at the notion of a predicate exhibiting +side effects). The user could also choose to concentrate only on chat +content by filtering out non-@samp{PRIVMSG} messages via the slot +@samp{command}. + +In cases where you need a handler to only run when some other match type +appearing earlier in @code{erc-match-functions} has _not_ yielded a +match, use: + +@defun erc-match-get-match constructor + +When called from a @samp{handler} or a @samp{predicate} body, this +utility returns instances of prior @code{erc-match-functions} that have +already successfully matched the current message. Use this for +deduplication and to share data between match instances. + +@end defun + +@noindent +For a detailed example of matching for non-highlighting purposes, see +the @samp{jabbycat} demo module, available on ERC's dev-oriented package +archive: @uref{https://emacs-erc.gitlab.io/bugs/archive/jabbycat.html}. +If you're in a hurry, check out @file{erc-desktop-notifications.el}, +which ships with ERC, but please ignore the parts that involve adapting +the global setup (and teardown) business to a buffer-local context. +Since your module is declared @code{local}, as per the modern +convention, you won't be needing such code, so feel free to do things +like add local members to @code{erc-match-functions} in your module's +definition. + +@anchor{highlighting} +@subsection Highlighting +@cindex highlighting + +End users and third-party modules likely want to manage and apply faces +themselves. If that's you, feel free to skip to the more extensive +examples further below. However, for the sake of completeness, it's +worth mentioning that in a pinch, you can likely piggyback atop the +highlighting functionality already provided by @samp{match} to support +its many high-level options. + +@lisp +(require 'erc-match) + +(defvar my-keywords + `((foonet ("#chan" ,(rx bow (or "foo" "bar" "baz") eow))))) + +(defface my-face + '((t (:inherit font-lock-constant-face :weight bold))) + "My face.") + +(defun my-match (&rest plist) + (apply #'erc-match-opt-keyword + :data (and-let* ((chans (alist-get (erc-network) my-keywords)) + ((cdr (assoc (erc-target) chans))))) + :face 'my-face + plist)) + +(add-hook 'erc-match-functions #'my-match) +@end lisp + +@noindent +Here, the user leverages a handy subtype of @code{erc-match}, called +@code{erc-match-opt-keyword}, which actually descends directly from +another, intermediate @code{erc-match} type: + +@deftp {Struct} erc-match-traditional category face data part + +Use this type or one of its descendants (see below) if you want +@code{erc-text-matched-hook} to run alongside (after) the @samp{handler} +slot's default highlighter, @code{erc-match-highlight}, on every match +for which the @samp{category} slot's value is non-@code{nil} (it becomes +the argument provided for the hook's @var{match-type} parameter). + +Much more important, however, is @samp{part}. This slot determines what +portion of the message is being highlighted or otherwise operated on. +It can be any symbol, but the ones with predefined methods are +@code{nick}, @code{message}, @code{all}, @code{keyword}, +@code{nick-or-keyword}, and @code{nick-or-mention}. + +The complement to the @samp{part} slot is @samp{data}, which holds the +value of the module's option corresponding to the specific type. For +example, ERC initializes the @samp{data} slot for the +@code{erc-match-opt-pal} type with the value of @code{erc-pals}. + +The default handler, @code{erc-match-highlight}, does its work by +deferring to a purpose-built @dfn{method} meant to handle +@samp{part}-based highlighting: + +@defop {Method} erc-match-traditional erc-match-highlight-by-part @ + instance part + + You can override this method by @dfn{specializing} on any subclassed + @code{erc-match-traditional} type and/or non-reserved @var{part}, such + as one known only to your @file{init.el} or (informally) associated + with your package by its library @dfn{namespace}. + +@end defop + +@end deftp + +@noindent +You likely won't be needing these, but just for the record, other +options-based types similar to @code{erc-match-opt-keyword} include +@code{erc-match-opt-current-nick}, @code{erc-match-opt-fool}, +@code{erc-match-opt-pal}, and @code{erc-match-opt-dangerous-host}. (If +you're familiar with this module's user options, you'll notice some +parallels here.) + +@anchor{highlighting examples} +@subsubsection Complete Highlighting Examples +@cindex highlighting examples + +As mentioned, most users needn't bother with the piggybacking approach +detailed above, which can oftentimes be more complicated than starting +afresh. Here's a more elaborate, module-like example demoing some +highlighting with a bespoke @code{erc-match}-derived type: + +@lisp +;;; erc-org-markup.el --- Org Markup for ERC -*- lexical-binding: t; -*- + +(require 'erc-match) +(require 'org) + +(defgroup erc-org-markup nil + "Highlight messages written in Org markup." + :group 'erc) + +(defcustom erc-org-markup-targets '("#org") + "List of buffers in which to highlight messages." + :type '(repeat string)) + +(define-erc-module org-markup nil + "Local module that treats messages as having Org markup." + ((erc-org-markup-ensure-buffer) + (if (member (erc-target) erc-org-markup-targets) + (progn + (add-hook 'erc-match-functions #'erc-org-markup 0 t) + (add-to-invisibility-spec '(org-link))) + (erc-org-markup-mode -1))) + ((remove-hook 'erc-match-functions #'erc-org-markup t) + (remove-from-invisibility-spec '(org-link))) + 'local) + +(cl-defstruct (erc-org-markup + (:include erc-match + (predicate #'erc-org-markup--should-p) + (handler #'erc-org-markup--fontify)) + (:constructor erc-org-markup)) + "Match type to highlight messages written in Org markup.") + +(defun erc-org-markup--should-p (match) + "Return non-nil if MATCH describes an Org-markup worthy message." + (and erc-org-markup-mode (erc-match-nick match))) + +(defun erc-org-markup-ensure-buffer () + "Return existing global work buffer or create it anew." + (or (get-buffer "*erc-org-markup*") + (with-current-buffer (get-buffer-create "*erc-org-markup*") + (org-mode) + (make-local-variable 'org-link-parameters) + (setf (plist-get (cdr (assoc "https" org-link-parameters)) + :activate-func) + #'erc-org-markup-activate-link) + (setq-local org-hide-emphasis-markers t) + (current-buffer)))) + +(defun erc-org-markup--fontify (match) + "Overwrite text properties in MATCH'd message with Org's." + (save-restriction + (narrow-to-region (erc-match-body-beg match) (1- (point-max))) + (let ((buffer (current-buffer))) + (with-current-buffer (erc-org-markup-ensure-buffer) + (save-window-excursion + (buffer-swap-text buffer) + (font-lock-ensure) + (buffer-swap-text buffer)))))) + +(defun erc-org-markup-activate-link (beg end path _) + "Ensure Org https link between BEG and END has `erc-button' props." + (erc-button-add-button beg end #'browse-url-button-open-url nil + (list (concat "https:" path)) "")) + +(provide 'erc-org-markup) + +;;; erc-org-markup.el ends here +@end lisp + +@noindent +Finally, here's a slightly more complete demo module: a superficial +rewrite of @file{erc-colorize.el} by Sylvain Rousseau +@uref{https://github.com/thisirs/erc-colorize.git}. + +@lisp +;;; erc-colorize.el --- Per-user message faces -*- lexical-binding: t; -*- + +(require 'ring) +(require 'erc-match) +(require 'erc-button) ; for `erc-button-add-face' + +(defgroup erc-colorize nil + "Highlight messages with per-user faces from a limited pool." + :group 'erc) + +(defface erc-colorize-1 '((t :inherit font-lock-keyword-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-2 '((t :inherit font-lock-type-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-3 '((t :inherit font-lock-string-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-4 '((t :inherit font-lock-constant-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-5 '((t :inherit font-lock-preprocessor-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-6 '((t :inherit font-lock-variable-name-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-7 '((t :inherit font-lock-warning-face)) + "Auto-assigned face for distinguishing between messages.") + +(defvar erc-colorize-faces '(erc-colorize-1 + erc-colorize-2 + erc-colorize-3 + erc-colorize-4 + erc-colorize-5 + erc-colorize-6 + erc-colorize-7) + "List of faces to apply to chat messages.") + +(defvar-local erc-colorize-ring nil + "Ring of cons cells of the form (NICK . FACE).") + +(define-erc-module colorize nil + "Highlight messages from a speaker with the same face in target buffers." + ((when (erc-target) + (add-hook 'erc-match-functions 'erc-colorize 0 t) + (setq erc-colorize-ring (make-ring (length erc-colorize-faces))))) + ((remove-hook 'erc-match-functions 'erc-colorize t)) + 'local) + +(defun erc-colorize-color (ring nick) + "Return a face to use for string NICK. +Prefer an existing entry in RING. If there isn't one, pick the first +unused face in `erc-colorize-faces'. Otherwise, pick the least used +face." + (cond + ((and-let* ((i (catch 'found + (dotimes (i (ring-length ring)) + (when (equal (car (ring-ref ring i)) nick) + (throw 'found i)))))) + (ring-insert ring (ring-remove ring i)) + (cdr (ring-ref ring 0)))) + ((let ((used (mapcar #'cdr (ring-elements ring)))) + (and-let* ((face (catch 'found + (dolist (face erc-colorize-faces) + (unless (member face used) + (throw 'found face)))))) + (prog1 face + (ring-insert ring (cons nick face)))))) + ((let ((older (ring-remove ring))) + (ring-insert ring (cons nick (cdr older))) + (cdr older))))) + +(cl-defstruct (erc-colorize ( :include erc-match + (predicate #'erc-colorize-nick) + (handler #'erc-colorize-message)) + (:constructor erc-colorize)) + "An `erc-match' type for the `erc-colorize' module.") + +(defun erc-colorize-message (match) + "Highlight MATCH's full message with a face from `erc-colorize-faces'." + (erc-button-add-face (point-min) (1- (point-max)) + (erc-colorize-color erc-colorize-ring + (erc-colorize-nick match)))) + +(provide 'erc-colorize) + +;;; erc-colorize.el ends here +@end lisp + + @node Options @section Options @cindex options diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 6dc18bf250e..8fcb83bb471 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -122,10 +122,15 @@ erc-pal-highlight-type `all' - highlight the entire message (including the nick) from pal + `nick-or-mention' - highlight a matching speaker or all matching + mentions as quasi keywords + A value of `nick' only highlights a matching sender's nick in the bracketed speaker portion of the message. A value of \\+`message' basically highlights its complement: the message-body alone, after the -speaker tag. All values for this option require a matching sender to be +speaker tag. A value of `nick-or-mention' works like `nick' but also +matches \"mentions,\" which `erc-fool-highlight-type' explains in its +doc string. All values for this option require a matching sender to be an actual user on the network \(or a bot/service) as opposed to a host name, such as that of the server itself \(e.g. \"irc.gnu.org\"). When patterns from other user-based categories \(namely, \\+`fool' and @@ -135,6 +140,7 @@ erc-pal-highlight-type \\+`fool'-related invisibility may not survive such collisions.)" :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -148,12 +154,12 @@ erc-fool-highlight-type <speaker> USER: hi. <speaker> USER, hi. -However, at present, this option doesn't offer a means of highlighting -matched mentions alone. See `erc-pal-highlight-type' for a summary of -possible values and additional details common to categories like -\\+`fool' that normally match against a message's sender." +See `erc-pal-highlight-type' for a summary of possible values and +additional details common to categories like \\+`fool' that normally +match against a message's sender." :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -182,6 +188,7 @@ erc-dangerous-host-highlight-type normally match against a message's sender." :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -267,6 +274,22 @@ erc-match-quote-when-adding (const t) (const nil))) +(defcustom erc-match-functions '(erc-match-opt-pal + erc-match-opt-fool + erc-match-opt-dangerous-host + erc-match-opt-keyword + erc-match-opt-current-nick) + "Type constructors for \\+`match' processing. +See the struct `erc-match' as well as Info node `(erc) Match API' for +details." + :package-version '(ERC . "5.7") ; FIXME sync on release + :type '(hook :options (erc-match-opt-pal + erc-match-opt-fool + erc-match-opt-dangerous-host + erc-match-opt-keyword + erc-match-opt-current-nick))) + + ;; Internal variables: ;; This is exactly the same as erc-button-syntax-table. Should we @@ -322,6 +345,7 @@ erc-add-entry-to-list LIST must be passed as a symbol The query happens using PROMPT. Completion is performed on the optional alist COMPLETIONS." + (erc-match--opt-pat-cache-clear-all list) (let ((entry (completing-read prompt completions @@ -345,6 +369,7 @@ erc-remove-entry-from-list LIST must be passed as a symbol. The elements of LIST can be strings, or cons cells where the car is the string." + (erc-match--opt-pat-cache-clear-all list) (let* ((alist (mapcar (lambda (x) (if (listp x) x @@ -468,7 +493,360 @@ erc-match-directed-at-fool-p (or (erc-list-match fools-beg msg) (erc-list-match fools-end msg)))) +(cl-defstruct (erc-match (:constructor erc-match)) + "Base type for text and user matching performed by the \\+`match' module. +Users wishing to perform custom matching should add a constructor that +returns an instance of this type to the hook `erc-match-functions'. If +the `:predicate' slot's predicate returns non-nil after being called +with its own instance in the narrowed single-message buffer, ERC calls +the `:handler' slot's function with the same instance and with the match +data still intact. More details in Info node `(erc) Match API'." + ( predicate (error "Keyword `:predicate' missing") :type function + :documentation "Called in narrowed buffer with own instance.") + ( spkr-beg nil :type (or null natnum) + :documentation "Position of the beginning of speaker's nick, if known.") + ( spkr-end nil :type (or null natnum) + :documentation "Position of the end of speaker's nick, if known.") + ( body-beg (error "Keyword `:body-beg' missing") :type marker + :documentation "Marker residing at the beginning of the message body.") + ( sender (error "Keyword `:sender' missing") :type string + :documentation "The sender's n!u@h.") + ( nick nil :type (or null string) + :documentation "The sender's nick if they're a user and not the server.") + ( command (error "Keyword `:command' missing") :type (or symbol natnum) + :documentation "Protocol command or numeric, like `PRIVMSG' or 353.") + ( handler #'ignore :type function + :documentation "Called on `:predicate' match with own instance.")) + +(cl-defstruct (erc-match-traditional + (:constructor erc-match-traditional) + (:include erc-match (handler #'erc-match-highlight))) + "Match type for user-option based on \"categories\" and \"parts\". +The `:category' slot exists for the benefit of `erc-text-matched-hook', +which receives its value as a second parameter (the hook only runs when +the slot is non-nil)." + ( category (error "Keyword `:category' missing") :type symbol + :documentation "Traditional \\+`match' \"category\", like `pal'.") + ( face 'erc-default-face :type face + :documentation "Face to highlight the matched portion with.") + ( part nil :type symbol + :documentation "Symbol for the portion of the message to highlight.") + ( data nil :type list + :documentation "User-specified patterns or other type-specific data.")) + +(cl-defstruct (erc-match-opt-current-nick + (:include erc-match-traditional + (category 'current-nick) + (predicate #'erc-match--current-nick-p) + (part erc-current-nick-highlight-type) + (face 'erc-current-nick-face) + (data (list (concat "\\b" + (regexp-quote (erc-current-nick)) + "\\b")))) + (:constructor erc-match-opt-current-nick)) + "An options-based type for the `current-nick' category.") + +(cl-defstruct (erc-match-opt-keyword + (:include erc-match-traditional + (category 'keyword) + (predicate #'erc-match--keyword-p) + (part erc-keyword-highlight-type) + (face 'erc-keyword-face) + (data erc-keywords)) + (:constructor erc-match-opt-keyword)) + "An options-based type for the `keyword' category.") + +(cl-defstruct (erc-match-user (:include erc-match-traditional) + (:constructor erc-match-user)) + "An `erc-match' that's only processed when `:nick' is non-nil.") + +(cl-defstruct (erc-match-opt-fool + (:include erc-match-user + (category 'fool) + (predicate #'erc-match--user-nuh-or-mention-p) + (part erc-fool-highlight-type) + (face 'erc-fool-face) + (data erc-fools)) + (:constructor erc-match-opt-fool)) + "An options-based type for the `fool' category.") + +(cl-defstruct (erc-match-opt-pal + (:include erc-match-user + (category 'pal) + (predicate #'erc-match--user-nuh-or-mention-p) + (part erc-pal-highlight-type) + (face 'erc-pal-face) + (data erc-pals)) + (:constructor erc-match-opt-pal)) + "An options-based type for the `pal' category.") + +(cl-defstruct (erc-match-opt-dangerous-host + (:include erc-match-user + (category 'dangerous-host) + (predicate #'erc-match--user-nuh-or-mention-p) + (part erc-dangerous-host-highlight-type) + (face 'erc-dangerous-host-face) + (data erc-dangerous-hosts)) + (:constructor erc-match-opt-dangerous-host)) + "An options-based type for the `dangerous-host' category.") + +(defvar erc-match--opt-pat-cache nil + "Hash table of computed `regexp-opt' patterns from match-list options. +Keys are cons cells of (CATEGORY . COMPUTE-FN). Values are +`erc-match--opt-pat' objects. The table also contains an auxiliary item +whose key is CATEGORY and whose value is a list of (COMPUTE-FN-1 +COMPUTE-FN-2 ... COMPUTE-FN-N). ERC uses this when clearing the cache +for CATEGORY.") + +(defvar erc-match--opt-pat-ttl 300.0 + "Seconds to retain cached `regexp-opt' patterns between hits.") + +(cl-defstruct erc-match--opt-pat ts in out) + +(defun erc-match--opt-pat-cache-clear (base-key) + "Remove items for BASE-KEY from `erc-match--opt-pat-cache'." + (when-let* ((table erc-match--opt-pat-cache) + (keys (gethash base-key table))) + (remhash base-key table) + (dolist (key keys) + (remhash (cons base-key key) table)))) + +;; FIXME have :set functions of user options also break cache. +(defun erc-match--opt-pat-cache-clear-all (list-option) + "Remove items for LIST-OPTION from `erc-match--opt-pat-cache'." + (let ((base-key (pcase-exhaustive list-option + ('erc-fools 'fool) + ('erc-pals 'pal) + ('erc-keywords 'keyword) + ('erc-dangerous-hosts 'dangerous-host)))) + (erc-match--opt-pat-cache-clear base-key))) + +(defun erc-match--opt-pat-get (base-key compute-fn input) + "Retrieve cached results for computing INPUT with COMPUTE-FN. +Use BASE-KEY for `erc-match--opt-pat-cache' transactions." + (unless erc-match--opt-pat-cache + (setq erc-match--opt-pat-cache + (make-hash-table :test #'equal))) + (if-let* ((key (cons base-key compute-fn)) + (entry (gethash key erc-match--opt-pat-cache)) + (ct (erc-current-time)) + ((> ct (+ (erc-match--opt-pat-ts entry) + erc-match--opt-pat-ttl))) + ((equal (erc-match--opt-pat-in entry) input))) + (progn + (setf (erc-match--opt-pat-ts entry) ct) + (erc-match--opt-pat-out entry)) + (let ((output (funcall compute-fn input))) + (prog1 output + (cl-pushnew compute-fn (gethash base-key erc-match--opt-pat-cache)) + (puthash key + (make-erc-match--opt-pat :ts (or ct (erc-current-time)) + :in input + :out output) + erc-match--opt-pat-cache))))) + +(defun erc-match--opt-pat-make (patterns) + (string-join patterns "\\|")) + +(defun erc-match--opt-pat-kw-make (patterns) + (mapconcat (lambda (w) (or (car-safe w) w)) patterns "\\|")) + +(defun erc-match--opt-pat-addr-beg-make (patterns) + (concat "\\<\\(" (erc-match--opt-pat-make patterns) "\\)[:,] ")) + +(defun erc-match--opt-pat-addr-end-make (patterns) + (concat "\\s. \\(" (erc-match--opt-pat-make patterns) "\\)\\s.")) + +(defun erc-match--current-nick-p (instance) + (re-search-forward (car (erc-match-traditional-data instance)) nil t)) + +(defun erc-match--keyword-p (instance) + (and-let* ((patterns (erc-match-traditional-data instance)) + (regexp (erc-match--opt-pat-get + (erc-match-traditional-category instance) + #'erc-match--opt-pat-kw-make patterns))) + (goto-char (erc-match-body-beg instance)) + (re-search-forward regexp nil t))) + +(defun erc-match--user-nuh-or-mention-p (instance) + "Return non-nil on NUH match for `erc-match' INSTANCE. +Also do so on mentions if the category is `fool' or the corresponding +\"part\" option is `nick-or-mention'." + (and-let* ((patterns (erc-match-traditional-data instance)) + (category (erc-match-traditional-category instance))) + (or (string-match (erc-match--opt-pat-get + category #'erc-match--opt-pat-make patterns) + (erc-match-sender instance)) + (and (or (eq category 'fool) + (eq (erc-match-traditional-part instance) 'nick-or-mention)) + ;; Mimic `erc-match-directed-at-fool-p', but search + ;; the narrowed buffer instead of a string argument. + (goto-char (erc-match-body-beg instance)) + (or (looking-at (erc-match--opt-pat-get + category #'erc-match--opt-pat-addr-beg-make + patterns)) + (search-forward-regexp + (erc-match--opt-pat-get + category #'erc-match--opt-pat-addr-end-make patterns) + nil t)))))) + +(cl-defgeneric erc-match-highlight-by-part (instance part) + "Highlight PART of narrowed buffer for `erc-match' INSTANCE.") + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql nick))) + "Highlight nick in the bracketed speaker portion of the message." + (when (erc-match-spkr-beg instance) + (erc-put-text-property (erc-match-spkr-beg instance) + (erc-match-spkr-end instance) + 'font-lock-face + (erc-match-traditional-face instance)))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql message))) + "Highlight the message body, not including the leading speaker tag." + (erc-put-text-property (erc-match-body-beg instance) (point-max) + 'font-lock-face + (erc-match-traditional-face instance))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql all))) + "Highlight the whole message, including the speaker tag." + (erc-put-text-property (point-min) (point-max) + 'font-lock-face + (erc-match-traditional-face instance))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql keyword))) + "Highlight all occurrences of all keyword patterns." + (dolist (pat (erc-match-traditional-data instance)) + (let ((regex (if (consp pat) (car pat) pat)) + (face (if (consp pat) + (cdr pat) + (erc-match-traditional-face instance)))) + (goto-char (erc-match-body-beg instance)) + (while (re-search-forward regex nil t) + (erc-put-text-property (match-beginning 0) (match-end 0) + 'font-lock-face face))))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql nick-or-keyword))) + "Highlight speaker-tag nick of matching users, otherwise all mentions." + (if (erc-match-spkr-end instance) + (erc-put-text-property (erc-match-spkr-beg instance) + (erc-match-spkr-end instance) + 'font-lock-face + (erc-match-traditional-face instance)) + (erc-match-highlight-by-part instance 'keyword))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql nick-or-mention))) + "Highlight speaker-tag nick of matching users or all mentions." + (let ((body-beg (erc-match-body-beg instance))) + (setf (erc-match-body-beg instance) + (or (erc-match-spkr-beg instance) (point-min))) + (erc-match-highlight-by-part instance 'keyword) + (setf (erc-match-body-beg instance) body-beg))) + +(defvar erc-match-highlight-matched nil + "Matched `erc-match' instance in `erc-text-matched-hook'.") + +(defvar erc-match--instances nil + "Alist mapping constructors to successful `erc-match' instances.") + +(defun erc-match-highlight (instance) + "Dispatch `erc-match-highlight-by-part' on INSTANCE's `:part' slot. +Run `erc-text-matched-hook' when INSTANCE's `category' slot is non-nil." + (unless (erc-match-traditional-p instance) + (signal 'wrong-type-argument (list 'erc-match-traditional instance))) + (erc-match-highlight-by-part instance (erc-match-traditional-part instance)) + (when (erc-match-traditional-category instance) + (let ((user-nuh (and (erc-match-nick instance) + (erc-match-sender instance))) + (erc-match-highlight-matched instance)) + (run-hook-with-args 'erc-text-matched-hook + (erc-match-traditional-category instance) + (or user-nuh (format "Server:%s" + (erc-match-command instance))) + ;; For compatibility, include a leading "*** ". + (buffer-substring (if user-nuh + (erc-match-body-beg instance) + (point-min)) + (point-max)))))) + +(defun erc-match-get-message-body (instance) + "Return the message body in the narrowed buffer for match INSTANCE." + (buffer-substring (erc-match-body-beg instance) (1- (point-max)))) + +(defun erc-match-get-match (constructor) + "Return successful `erc-match' instance for CONSTRUCTOR, if any. +Expect to be called only from `erc-match' :predicate and :handler +functions as well as `erc-text-matched-hook' members." + (alist-get constructor erc-match--instances)) + +(defun erc-match--run-match (constructor spkr-beg spkr-end body-beg + nick sender command) + "Run :handler for for `erc-match' instance if :predicate returns non-nil. +Call CONSTRUCTOR with SPKR-BEG, SPKR-END, BODY-BEG, NICK SENDER, and +COMMAND to create said instance." + (when-let* ((instance (funcall constructor + :spkr-beg spkr-beg + :spkr-end spkr-end + :body-beg body-beg + :nick nick + :sender sender + :command command)) + ((or nick (not (erc-match-user-p instance)))) + ((goto-char (point-min))) + ((funcall (erc-match-predicate instance) instance))) + (funcall (erc-match-handler instance) instance) + (push (cons constructor instance) erc-match--instances) + nil)) + +(defun erc-match--message () + "Highlight matches in narrowed buffer's current message." + (goto-char (point-min)) + (let* ((response erc--parsed-response) + ;; Sender has a valid (non-domain) nickname of a likely user. + (user-nuh (and response (erc-get-parsed-vector-nick response))) + (nick (and user-nuh (or (erc--check-msg-prop 'erc--spkr) + (erc-extract-nick user-nuh)))) + (spkr-end (and nick (erc--get-speaker-bounds))) + (spkr-beg (and spkr-end (pop spkr-end))) + (body-beg (copy-marker + (cond (erc--offset-marker + (marker-position erc--offset-marker)) + (spkr-end + (save-excursion (goto-char spkr-end) + (skip-syntax-forward "^-") + (skip-syntax-forward "-") + (point))) + ((point-min))))) + (command (erc--check-msg-prop 'erc--cmd)) + (erc-match--instances ())) + (with-syntax-table erc-match-syntax-table + (run-hook-wrapped 'erc-match-functions #'erc-match--run-match + spkr-beg spkr-end body-beg nick + (erc-response.sender response) command)) + (when (and erc--offset-marker (/= body-beg erc--offset-marker)) + (setq erc--offset-marker body-beg)))) + +(defvar erc-match-use-legacy-logic-p nil + "When non-nil, use the non-`erc-match' variant of `erc-match-message'.") +(make-obsolete 'erc-match-use-legacy-logic-p + "non-nil behavior is missing features and integrations" "31.1") + (defun erc-match-message () + "Highlight matched portions of the narrowed buffer." + (if (or erc-match-use-legacy-logic-p (null erc--parsed-response)) + (erc-match--message-legacy) + (unless (or (and erc-match-exclude-server-buffer (erc--server-buffer-p)) + (null (erc--check-msg-prop 'erc--cmd)) + (erc--check-msg-prop 'erc--echo) + (erc--memq-msg-prop 'erc--skip 'match)) + (erc-match--message)))) + +(defun erc-match--message-legacy () "Mark certain keywords in a region. Use this defun with `erc-insert-modify-hook'." ;; This needs some refactoring. @@ -591,27 +969,25 @@ erc-log-matches Specify the match types which should be logged in the former, and deactivate/activate match logging in the latter. See `erc-log-match-format'." - (let ((match-buffer-name (cdr (assq match-type - erc-log-matches-types-alist))) - (nick (nth 0 (erc-parse-user nickuserhost)))) - (when (and - (or (eq erc-log-matches-flag t) - (and (eq erc-log-matches-flag 'away) - (erc-away-time))) - match-buffer-name) - (let ((line (format-spec - erc-log-match-format - `((?n . ,nick) - (?t . ,(format-time-string - (or (bound-and-true-p erc-timestamp-format) - "[%Y-%m-%d %H:%M] "))) - (?c . ,(or (erc-default-target) "")) - (?m . ,message) - (?u . ,nickuserhost))))) - (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) - (let ((inhibit-read-only t)) - (goto-char (point-max)) - (insert line))))))) + (when-let* + ((erc-log-matches-flag) + ((or (eq erc-log-matches-flag t) (erc-away-time))) + (match-buffer-name (cdr (assq match-type erc-log-matches-types-alist))) + (line (format-spec + erc-log-match-format + (erc-compat--defer-format-spec-in-buffer + (?n . (or (erc--check-msg-prop 'erc--spkr) + (erc-extract-nick nickuserhost))) + (?t . (format-time-string + (or (bound-and-true-p erc-timestamp-format) + "[%Y-%m-%d %H:%M] "))) + (?c erc-default-target) + (?m . message) + (?u . nickuserhost))))) + (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) + (with-silent-modifications + (goto-char (point-max)) + (insert line))))) (defun erc-log-matches-make-buffer (name) "Create or get a log-matches buffer named NAME and return it." diff --git a/test/lisp/erc/erc-match-tests.el b/test/lisp/erc/erc-match-tests.el index fb92a153c95..0b90867b32d 100644 --- a/test/lisp/erc/erc-match-tests.el +++ b/test/lisp/erc/erc-match-tests.el @@ -242,8 +242,9 @@ erc-match-tests--assert-speaker-only-highlighted (defun erc-match-tests--perform (test) (erc-tests-common-make-server-buf) (setq erc-server-current-nick "tester") - (with-current-buffer (erc--open-target "#chan") - (funcall test)) + (let (erc-match--opt-pat-cache) + (with-current-buffer (erc--open-target "#chan") + (funcall test))) (when noninteractive (erc-tests-common-kill-buffers))) @@ -337,6 +338,77 @@ erc-match-message/dangerous-host/nick (let ((erc-dangerous-hosts (list "bob"))) (erc-match-tests--hl-type-nick 'erc-dangerous-host-face))) +(ert-deftest erc-match-message/pal/nick/legacy () + (should (eq erc-pal-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-pals (list "bob"))) + (erc-match-tests--hl-type-nick 'erc-pal-face)))) + +(ert-deftest erc-match-message/fool/nick/legacy () + (should (eq erc-fool-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-fools (list "bob"))) + (erc-match-tests--hl-type-nick/mention 'erc-fool-face)))) + +(ert-deftest erc-match-message/dangerous-host/nick/legacy () + (should (eq erc-dangerous-host-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-dangerous-hosts (list "bob"))) + (erc-match-tests--hl-type-nick 'erc-dangerous-host-face)))) + +;; Mentions are treated as keywords, even in the speaker portion. +;; Contrast this with `erc-match-tests--hl-type-nick/mention', where the +;; speakers are highlighted despite "mention" matches occurring in the +;; message body. +(defun erc-match-tests--hl-type-nick-or-mention (face) + (erc-match-tests--hl-type-nick + face + (lambda () + (erc-tests-common-simulate-privmsg "alice" "bob: one bob ONE") + (erc-tests-common-simulate-privmsg "alice" "bob, two") + (erc-tests-common-simulate-privmsg "alice" "three, bob.") + + (search-forward "<alice> bob: one") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent face "bob: one") + (erc-match-tests--assert-face-present face ": one ") + (erc-match-tests--assert-face-absent face "bob ONE") + (erc-match-tests--assert-face-present face " ONE") + (erc-match-tests--assert-face-absent face (pos-eol)) + + (search-forward "<alice> bob, two") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent face "bob, two") + (erc-match-tests--assert-face-present face ", two") + (erc-match-tests--assert-face-absent face (pos-eol)) + + (search-forward "<alice> three, bob.") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent face "bob.") + (erc-match-tests--assert-face-present face ".") + (erc-match-tests--assert-face-absent face (pos-eol))))) + +(ert-deftest erc-match-message/pal/nick-or-mention () + (should (eq erc-pal-highlight-type 'nick)) + (let ((erc-pal-highlight-type 'nick-or-mention) + (erc-pals (list "bob"))) + (erc-match-tests--hl-type-nick-or-mention 'erc-pal-face))) + +(ert-deftest erc-match-message/fool/nick-or-mention () + (should (eq erc-fool-highlight-type 'nick)) + (let ((erc-fool-highlight-type 'nick-or-mention) + (erc-fools (list "bob"))) + (erc-match-tests--hl-type-nick-or-mention 'erc-fool-face))) + +(ert-deftest erc-match-message/dangerous-host/nick-or-mention () + (should (eq erc-dangerous-host-highlight-type 'nick)) + (let ((erc-dangerous-host-highlight-type 'nick-or-mention) + (erc-dangerous-hosts (list "bob"))) + (erc-match-tests--hl-type-nick-or-mention 'erc-dangerous-host-face))) + (defun erc-match-tests--hl-type-message (face) (should (eq erc-current-nick-highlight-type 'keyword)) (should (eq erc-keyword-highlight-type 'keyword)) @@ -402,6 +474,30 @@ erc-match-message/dangerous-host/message (erc-dangerous-host-highlight-type 'message)) (erc-match-tests--hl-type-message 'erc-dangerous-host-face))) +(ert-deftest erc-match-message/pal/message/legacy () + (should (eq erc-pal-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-pals (list "bob")) + (erc-pal-highlight-type 'message)) + (erc-match-tests--hl-type-message 'erc-pal-face)))) + +(ert-deftest erc-match-message/fool/message/legacy () + (should (eq erc-fool-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-fools (list "bob")) + (erc-fool-highlight-type 'message)) + (erc-match-tests--hl-type-message 'erc-fool-face)))) + +(ert-deftest erc-match-message/dangerous-host/message/legacy () + (should (eq erc-dangerous-host-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-dangerous-hosts (list "bob")) + (erc-dangerous-host-highlight-type 'message)) + (erc-match-tests--hl-type-message 'erc-dangerous-host-face)))) + (defun erc-match-tests--hl-type-all (face) (should (eq erc-current-nick-highlight-type 'keyword)) (should (eq erc-keyword-highlight-type 'keyword)) @@ -467,6 +563,30 @@ erc-match-message/dangerous-host/all (erc-dangerous-host-highlight-type 'all)) (erc-match-tests--hl-type-all 'erc-dangerous-host-face))) +(ert-deftest erc-match-message/pal/all/legacy () + (should (eq erc-pal-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-pals (list "bob")) + (erc-pal-highlight-type 'all)) + (erc-match-tests--hl-type-all 'erc-pal-face)))) + +(ert-deftest erc-match-message/fool/all/legacy () + (should (eq erc-fool-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-fools (list "bob")) + (erc-fool-highlight-type 'all)) + (erc-match-tests--hl-type-all 'erc-fool-face)))) + +(ert-deftest erc-match-message/dangerous-host/all/legacy () + (should (eq erc-dangerous-host-highlight-type 'nick)) + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t) + (erc-dangerous-hosts (list "bob")) + (erc-dangerous-host-highlight-type 'all)) + (erc-match-tests--hl-type-all 'erc-dangerous-host-face)))) + (defun erc-match-tests--hl-type-nick-or-keyword () (should (eq erc-current-nick-highlight-type 'keyword)) @@ -511,6 +631,11 @@ erc-match-tests--hl-type-nick-or-keyword (ert-deftest erc-match-message/current-nick/nick-or-keyword () (erc-match-tests--hl-type-nick-or-keyword)) +(ert-deftest erc-match-message/current-nick/nick-or-keyword/legacy () + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t)) + (erc-match-tests--hl-type-nick-or-keyword)))) + (defun erc-match-tests--hl-type-keyword () (should (eq erc-keyword-highlight-type 'keyword)) @@ -567,6 +692,11 @@ erc-match-tests--hl-type-keyword (ert-deftest erc-match-message/keyword/keyword () (erc-match-tests--hl-type-keyword)) +(ert-deftest erc-match-message/keyword/keyword/legacy () + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t)) + (erc-match-tests--hl-type-keyword)))) + (defun erc-match-tests--log-matches () (let ((erc-log-matches-flag t) (erc-timestamp-format "[@@TS@@]") @@ -589,5 +719,85 @@ erc-match-tests--log-matches (ert-deftest erc-log-matches () (erc-match-tests--log-matches)) +(ert-deftest erc-log-matches/legacy () + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t)) + (erc-match-tests--log-matches)))) + +;; This demos bare-bones usage of the `erc-match' API that implicitly +;; opts out of the traditional options and "parts"-based mechanism. The +;; user does not have to provide a `:part' keyword because they've +;; overridden the `:handler', meaning `erc-match-highlight-by-part' +;; never runs. This is somewhat analogous but ultimately orthogonal to +;; `erc-text-matched-hook' not running because that happens on account +;; of the user not specifying a `:category' field. +(ert-deftest erc-match-functions/api/non-parts-based () + (let* ((results ()) + (erc-text-matched-hook (lambda (&rest r) (push r results))) + (erc-match-functions + (list + (lambda (&rest plist) + ;; Doing everything in `:pred' would also work if + ;; specifying `ignore' for `:handler'. And you wouldn't + ;; even need to return non-nil on matches. + (apply #'erc-match + :predicate (lambda (_) (search-forward "alice" nil t)) + :handler (lambda (_) (push (match-string 0) results)) + plist))))) + + (erc-match-tests--perform + (lambda () + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "Alice") + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :bob tester Alice") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-privmsg "bob" "hi ALICE") + (goto-char (point-min)) + + (should (equal results '("ALICE" "Alice"))))))) + +;; This one piggybacks on infrastructure supporting the traditional +;; `match' interface. +(ert-deftest erc-match-functions/api/parts-based () + (let* ((results ()) + (erc-text-matched-hook (lambda (&rest r) (push r results))) + (erc-match-functions ())) + + (erc-match-tests--perform + (lambda () + + ;; Use local setter for no particular reason. + (add-hook 'erc-match-functions + (lambda (&rest plist) + (apply #'erc-match-traditional + :category 'keyword + :part 'keyword + :data '("alice") + :face 'error + :predicate (lambda (_) + (search-forward "alice" nil t)) + plist)) + 0 t) + + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "Alice") + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :Alice bob tester") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-privmsg "bob" "hi ALICE") + (goto-char (point-min)) + + (search-forward "*** Users on #chan:") + (erc-match-tests--assert-face-absent 'error "Alice") + (erc-match-tests--assert-face-present 'error " bob") + (erc-match-tests--assert-face-absent 'error (pos-eol)) + + (should (equal results + '(( keyword "[email protected]" "hi ALICE\n") + ( keyword "Server:353" + "*** Users on #chan: Alice bob tester\n")))))))) ;;; erc-match-tests.el ends here -- 2.47.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0003-5.7-Use-erc-match-type-API-for-erc-desktop-notificat.patch From 08b84a699644ccbc08e1c3e630090297f259269a Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Sat, 12 Oct 2024 17:44:30 -0700 Subject: [PATCH 3/3] [5.7] Use erc-match-type API for erc-desktop-notifications * etc/ERC-NEWS: New section for 5.7 and new entries for the `erc-match-type' API and `erc-notifications-focused-context' option. * lisp/erc/erc-desktop-notifications.el (erc-notifications-focused-contexts): New option. (erc-notifications-notify): Address ancient comment regarding PRIVP parameter possibly being unneeded when the current target matches the nick. (erc-notifications-PRIVMSG): Deprecate. (erc-notifications-notify-on-match): Account for new option. (erc-notifications-mode) (erc-notifications-enable, erc-notifications-disable): Instead of the "PRIVMSG" response-handler hook, use the `erc-match-type' API. (erc-desktop-notifications--setup): New function (erc-desktop-notifications-match-query-commands): New variable. (erc-desktop-notifications--match-type-query): New struct type. (erc-desktop-notifications--query-p): New function. (erc-desktop-notification--query-notify): New function. * test/lisp/erc/erc-desktop-notifications-tests.el: New file. --- etc/ERC-NEWS | 22 ++++ lisp/erc/erc-desktop-notifications.el | 69 +++++++++-- .../erc/erc-desktop-notifications-tests.el | 115 ++++++++++++++++++ 3 files changed, 198 insertions(+), 8 deletions(-) create mode 100644 test/lisp/erc/erc-desktop-notifications-tests.el diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index f3c8645f02d..ff1ae82e710 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -11,6 +11,28 @@ This file is about changes in ERC, the powerful, modular, and extensible IRC (Internet Relay Chat) client distributed with GNU Emacs since Emacs version 22.1. + +* Changes in ERC 5.7 + +** An extensibility focused 'match' API. +Users have often expressed frustration over ERC's lack of a simple API +for matching, highlighting, and filtering based on a message's content +and metadata, like the sender or associated IRC command. While it's +true that discussions have been ongoing for a more powerful message +formatting and construction API that will hopefully one day offer access +to the various parts of a message before they're assembled, users will +be needing something practical and effective in the interim. Enter the +'erc-match-type' API, which is based on a simple hook-like handler +system. You subscribe by enrolling a function that takes a special +'erc-match-type' object with useful fields to help with matching, +filtering, and applying faces. See Info node 'Match API' to find out +more. + +** Opt out of desktop notifications from the active buffer. +Option 'erc-notifications-focused-contexts' can help spare you from +seeing desktop alerts for messages you're reading or those inserted +while you're typing. + * Changes in ERC 5.6.1 diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index 9bb89fbfc81..2d605ced5f5 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -47,6 +47,11 @@ erc-notifications-icon "Icon to use for notification." :type '(choice (const :tag "No icon" nil) file)) +(defcustom erc-notifications-focused-contexts '(query mention) + "Where to notify even if a match appears in the selected window." + :package-version '(ERC . "5.7") ; FIXME sync on release + :type '(set (const query) (const mention))) + (defcustom erc-notifications-bus :session "D-Bus bus to use for notification." :version "25.1" @@ -60,12 +65,15 @@ dbus-debug (defun erc-notifications-notify (nick msg &optional privp) "Notify that NICK send some MSG, where PRIVP should be non-nil for PRIVMSGs. This will replace the last notification sent with this function." - ;; TODO: can we do this without PRIVP? (by "fixing" ERC's not - ;; setting the current buffer to the existing query buffer) (dbus-ignore-errors (setq erc-notifications-last-notification - (let* ((channel (if privp (erc-get-buffer nick) (current-buffer))) - (title (format "%s in %s" (xml-escape-string nick t) channel)) + (let* ((channel (or (and privp (not (equal nick (erc-target))) + (erc-get-buffer nick)) + (current-buffer))) + (title (if (or privp (equal nick (erc-target))) + (xml-escape-string nick t) + (format "%s in %s" + (xml-escape-string nick t) channel))) (body (xml-escape-string (erc-controls-strip msg) t))) (funcall (cond ((featurep 'android) #'android-notifications-notify) @@ -82,6 +90,7 @@ erc-notifications-notify (pop-to-buffer channel))))))) (defun erc-notifications-PRIVMSG (_proc parsed) + (declare (obsolete "switched to `erc-match-type' API" "31.1")) (let ((nick (car (erc-parse-user (erc-response.sender parsed)))) (target (car (erc-response.command-args parsed))) (msg (erc-response.contents parsed))) @@ -97,20 +106,64 @@ erc-notifications-notify-on-match (when (eq match-type 'current-nick) (let ((nick (nth 0 (erc-parse-user nickuserhost)))) (unless (or (string-match-p "^Server:" nick) - (when (boundp 'erc-track-exclude) - (member nick erc-track-exclude))) + (and (eq (current-buffer) (window-buffer)) + (frame-focus-state) ; t or unknown + (not (memq 'mention + erc-notifications-focused-contexts))) + (and (boundp 'erc-track-exclude) + (member nick erc-track-exclude))) (erc-notifications-notify nick msg))))) ;;;###autoload(autoload 'erc-notifications-mode "erc-desktop-notifications" "" t) (define-erc-module notifications nil "Send notifications on private message reception and mentions." ;; Enable - ((add-hook 'erc-server-PRIVMSG-functions #'erc-notifications-PRIVMSG) + ((unless erc--updating-modules-p + (erc-buffer-do #'erc-desktop-notifications--setup)) + (add-hook 'erc-mode-hook #'erc-desktop-notifications--setup) (add-hook 'erc-text-matched-hook #'erc-notifications-notify-on-match)) ;; Disable - ((remove-hook 'erc-server-PRIVMSG-functions #'erc-notifications-PRIVMSG) + ((erc-buffer-do #'erc-desktop-notifications--setup) (remove-hook 'erc-text-matched-hook #'erc-notifications-notify-on-match))) +(defun erc-desktop-notifications--setup () + (if erc-notifications-mode + (add-hook 'erc-match-functions + #'erc-desktop-notifications--match-type-query 0 t) + (remove-hook 'erc-match-functions + #'erc-desktop-notifications--match-type-query t))) + +(defvar erc-desktop-notifications-match-query-commands '(PRIVMSG) + "IRC commands considered in query buffers for notification. +Omits \"NOTICE\"s by default because they're typically reserved for bots +and services that you interact with directly.") + +(cl-defstruct (erc-desktop-notifications--match-type-query + (:constructor erc-desktop-notifications--match-type-query) + (:include erc-match-user + (category nil) + (data erc-desktop-notifications-match-query-commands) + (predicate #'erc-desktop-notifications--query-p) + (handler #'erc-desktop-notifications--query-notify))) + "Notification match type for queries.") + +(defun erc-desktop-notifications--query-p (match) + "Return non-nil if MATCH object describes a \"PRIVMSG\" query." + (and (erc-query-buffer-p) + (or (memq 'query erc-notifications-focused-contexts) + (null (frame-focus-state)) + (not (eq (current-buffer) (window-buffer)))) + (memq (erc-match-command match) (erc-match-user-data match)) + (always (cl-assert (erc-match-nick match))) + (not (and (boundp 'erc-track-exclude) + (member (erc-target) erc-track-exclude))))) + +(defun erc-desktop-notifications--query-notify (match) + ;; No need to pass argument PRIVP because current buffer is correct. + (erc-notifications-notify (erc-target) + (erc-match-get-message-body match))) + + (provide 'erc-desktop-notifications) ;;; erc-desktop-notifications.el ends here diff --git a/test/lisp/erc/erc-desktop-notifications-tests.el b/test/lisp/erc/erc-desktop-notifications-tests.el new file mode 100644 index 00000000000..5a9ad0ff5ba --- /dev/null +++ b/test/lisp/erc/erc-desktop-notifications-tests.el @@ -0,0 +1,115 @@ +;;; erc-desktop-notifications-tests.el --- Notifications tests -*- lexical-binding:t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;;; Code: +(require 'erc-desktop-notifications) + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) + +(defun erc-desktop-notifications-tests--perform (test) + (erc-tests-common-make-server-buf) + (erc-notifications-mode +1) + (setq erc-server-current-nick "tester") + + (cl-letf* ((calls nil) + ((frame-parameter nil 'last-focus-update) + t) + ((symbol-function 'erc-notifications-notify) + (lambda (&rest r) (push r calls)))) + (with-current-buffer (erc--open-target "#chan") + (funcall test (lambda () (prog1 calls (setq calls nil)))))) + + (when noninteractive + (erc-notifications-mode -1) + (erc-tests-common-kill-buffers))) + +(defun erc-desktop-notifications-tests--populate-chan (test) + (erc-desktop-notifications-tests--perform + (lambda (check) + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "alice") + + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :alice bob tester") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-privmsg "bob" "hi tester") + + (should (equal (current-buffer) (get-buffer "#chan"))) + (should (not (eq (current-buffer) (window-buffer)))) ; *ert* or *scratch* + (funcall test check)))) + +(ert-deftest erc-notifications-focused-contexts/default () + (should (equal erc-notifications-focused-contexts '(query mention))) + + (erc-desktop-notifications-tests--populate-chan + (lambda (check) + + ;; A private query triggers a notification. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester yo") + (should (eq (current-buffer) (get-buffer "bob"))) + + ;; A NOTICE command doesn't trigger a notification because it's + ;; absent from `erc-desktop-notifications-match-query-commands'. + (erc-tests-common-simulate-line ":irc.foonet.org NOTICE tester nope") + + (should (equal (funcall check) + '(("bob" "yo") + ("bob" "hi tester\n")))) + + ;; Setting the window to the buffer where insertions are happening + ;; makes no difference: notifications are still sent. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester ho") + + (set-window-buffer nil (set-buffer "#chan")) + (erc-tests-common-simulate-privmsg "alice" "hi tester") + + (should (equal (funcall check) + '(("alice" "hi tester\n") + ("bob" "ho"))))))) + +(ert-deftest erc-notifications-focused-contexts/unselected () + (should (equal erc-notifications-focused-contexts '(query mention))) + + (let ((erc-notifications-focused-contexts)) + + (erc-desktop-notifications-tests--populate-chan + (lambda (check) + (should (equal (funcall check) '(("bob" "hi tester\n")))) + + ;; Buffer #chan is current and displayed in the selected window, + ;; so no notification is sent. + (set-window-buffer nil "#chan") ; #chan + (erc-tests-common-simulate-privmsg "alice" "hi tester") + + ;; A new query comes in for a buffer that doesn't exist. The + ;; option `erc-receive-query-display' tells ERC to switch to that + ;; buffer and show it before insertion. Therefore, no + ;; notification is sent. + (let ((erc-receive-query-display 'buffer)) + (erc-tests-common-simulate-line + ":[email protected] PRIVMSG tester yo")) + + (should-not (funcall check)))))) + +;;; erc-desktop-notifications-tests.el ends here -- 2.47.0 --=-=-=--