master 3c0fa74ca9a 5/9: Introduce lower level erc-match API
"F. Jason Park" <[email protected]> Tue, 30 Jun 2026 23:37:21 -0400 (EDT)
| Newsgroups | gmane.emacs.diffs |
|---|---|
| Message-ID | <[email protected]> |
branch: master commit 3c0fa74ca9a1d1338cb0cd0208cbb58ce3308465 Author: F. Jason Park <[email protected]> Commit: F. Jason Park <[email protected]> Introduce lower level erc-match API * doc/misc/erc.texi (Match API): New node under the Advanced chapter. Update menus. * lisp/erc/erc-match.el (erc-match--opt-pat-cache): New variable. (erc-match--opt-pat-custom-set): New function. (erc-pals, erc-fools, erc-keywords, erc-dangerous-hosts): Specify `erc-match--opt-pat-custom-set' as `custom-set' function. (erc-pal-highlight-type, erc-fool-highlight-type) (erc-dangerous-host-highlight-type): Add `nick-or-mention' variant. (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-user, erc-match-opt-fool) (erc-match-opt-pal, erc-match-opt-dangerous-host): New struct types. (erc-match--opt-pat-get, erc-match--opt-pat-make) (erc-match--opt-pat-make-kw, erc-match--opt-pat-make-addr-beg) (erc-match--opt-pat-make-addr-end, 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 former body of `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) (ert-deftest erc-match--opt-pat-cache) (erc-match-functions/api/non-parts-based) (erc-match-functions/api/parts-based): New tests. * test/lisp/erc/erc-scenarios-match-api.el: New file. * test/lisp/erc/resources/match/functions/custom-match-log: New file. * test/lisp/erc/resources/match/functions/custom.eld: New file. (Bug#73798) --- doc/misc/erc.texi | 318 ++++++++++++++++ lisp/erc/erc-match.el | 408 +++++++++++++++++++-- test/lisp/erc/erc-match-tests.el | 259 ++++++++++++- test/lisp/erc/erc-scenarios-match-api.el | 127 +++++++ .../erc/resources/match/functions/custom-match-log | 39 ++ test/lisp/erc/resources/match/functions/custom.eld | 49 +++ 6 files changed, 1166 insertions(+), 34 deletions(-) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 9b75ac6a83c..e8b1724ef5f 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -89,6 +89,7 @@ Advanced Usage * SASL:: Authenticating via SASL. * Sample Configuration:: An example configuration file. * Integrations:: Integrations available for ERC. +* Match API:: Custom matching and highlighting. * Options:: Options that are available for ERC. @end detailmenu @@ -1021,6 +1022,7 @@ list or the bug tracker. * SASL:: Authenticating via SASL. * Sample Configuration:: An example configuration file. * Integrations:: Integrations available for ERC. +* Match API:: Custom matching and highlighting. * Options:: Options that are available for ERC. @detailmenu @@ -2355,6 +2357,322 @@ All keys are symbols, as are values, unless otherwise noted. @end itemize @end table +@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 configuration help, 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 may come to 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 newlinep + + This is a @code{cl-struct} type that contains some handy facts about + the message being processed. That formatted message 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 function accepts the parameters + named above as an @samp{&rest}-style plist and returns a new + @code{erc-match} instance. Conforming to this interface are, of + course, traditional constructors automatically provided by a + @code{cl-defstruct} definition derived from @code{erc-match}, such as + @samp{make-my-match} for some @dfn{subtype} @samp{my-match}. + + @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 null 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}. This includes, for example, server-sent @samp{NOTICE}s and + @samp{221} user-mode changes. + + To locate the start of the just-inserted message, use slot + @samp{body-beg}, a marker indicating the beginning of the message + proper. Locating the end depends on whether the narrowed buffer + includes a trailing newline, which it does if the slot @samp{newlinep} + is non-nil. 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}. The match + buffer must be current. + + @end defun + +@end deftp + +@noindent +Unless you're writing a module, there's often no need to subclass +@code{erc-match}. For everyday tasks or simple customizations in your +@file{init.el}, you can often just instantiate it directly (it's +@dfn{concrete}). 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 the @code{erc-match} instance from the last successful +match by @code{erc-match-functions} member @var{constructor} for 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. Just be aware that it's full of potentially +confusing compatibility-related fuss you'll want to ignore, such as +adapting the global setup and teardown business to a buffer-local +context. (New modules most likely adhere to the modern convention of +being defined as @code{local} in order to allow things like adding local +members to @code{erc-match-functions} in their @dfn{enable body}.) + +@anchor{highlighting} +@subsection Highlighting +@cindex highlighting + +Module authors and normal users alike will often want to manage and +apply faces themselves. If that's you, feel free to skip to the more +extensive examples in the subsection below. However, for the sake of +completeness, it's worth mentioning that (especially in a pinch) you can +likely piggyback atop the highlighting functionality already provided by +@samp{match} to support its traditional 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 right 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). + +The @samp{part} 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}. + +Accompanying 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 + +Note that when the handler runs, the narrowed buffer contains a trailing +newline after the inserted message because, unlike with a normal +@code{erc-match} object, the @samp{newlinep} slot is non-nil. + +@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 custom @code{erc-match}-derived type. It's 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)) + localp) + +(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." + (or + (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) (point-max) + (erc-colorize-color erc-colorize-ring + (erc-colorize-nick match)))) + +(provide 'erc-colorize) + +;;; erc-colorize.el ends here +@end lisp + +@noindent +Finally, for an even more thorough example in the form of a package, +check out @uref{https://emacs-erc.gitlab.io/bugs/archive/erc-link.html}, +which demos some good practices for integrating with other modules and +passing data from predicate to handler. + + @node Options @section Options @cindex options diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index b003cb1f49e..7c77960994d 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -63,14 +63,28 @@ highlighted." (erc-buffer-do #'erc-match--setup) (erc--modify-local-map nil "C-c C-k" #'erc-go-to-log-matches-buffer))) +;; This caches the result of applying `regexp-opt' analogs to the +;; regexp-based user options, mainly for history playback bursts. +(defvar erc-match--opt-pat-cache nil + "Alist of (COMPUTE-FN . PAIRS) where PAIRS is an alist of (IN . OUT).") + +(defun erc-match--opt-pat-custom-set (sym val &optional _) + "Assign VAL to SYM via `set'." + (when erc-match--opt-pat-cache + (setq erc-match--opt-pat-cache nil)) + (set sym val)) + + ;; Remaining customizations (defcustom erc-pals nil "List of pals on IRC." + :set #'erc-match--opt-pat-custom-set :type '(repeat regexp)) (defcustom erc-fools nil "List of fools on IRC." + :set #'erc-match--opt-pat-custom-set :type '(repeat regexp)) (defcustom erc-keywords nil @@ -78,12 +92,14 @@ highlighted." Each entry in the list is either a regexp, or a cons cell with the regexp in the car and the face to use in the cdr. If no face is specified, `erc-keyword-face' is used." + :set #'erc-match--opt-pat-custom-set :type '(repeat (choice regexp (list regexp face)))) (defcustom erc-dangerous-hosts nil "List of regexps for hosts to highlight. Useful to mark nicks from dangerous hosts." + :set #'erc-match--opt-pat-custom-set :type '(repeat regexp)) (defcustom erc-current-nick-highlight-type 'keyword @@ -122,10 +138,15 @@ The following values are allowed: `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 +156,7 @@ which in turn clobbers `erc-pal-face'. \(Other effects, such as \\+`fool'-related invisibility may not survive such collisions.)" :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -148,12 +170,12 @@ IRC-style \"mentions\" in which a speaker addresses a USER directly: <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 +204,7 @@ additional details common to categories like \\+`dangerous-host' that normally match against a message's sender." :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -241,12 +264,12 @@ for beeping to work." (defcustom erc-text-matched-hook '(erc-log-matches) "Abnormal hook for visiting text matching a predefined \"type\". ERC calls members with the arguments (MATCH-TYPE NUH MESSAGE), where -MATCH-TYPE is a symbol among `current-nick', `keyword', `pal', -`dangerous-host', and `fool'; and NUH is an `erc-response' sender, like -\"[email protected]\" or an IRC command prefixed with the string -\"Server:\", as in \"Server:353\". MESSAGE is the current incarnation -of the just-inserted message minus a leading speaker, like \"<bob> \". -For traditional reasons, MESSAGE always includes a leading +MATCH-TYPE is a \"category\" symbol, one of `current-nick', `keyword', +`pal', `dangerous-host', and `fool'; and NUH is an `erc-response' +sender, like \"[email protected]\" or an IRC command prefixed with +the string \"Server:\", as in \"Server:353\". MESSAGE is the current +incarnation of the just-inserted message minus a leading speaker, like +\"<bob> \". For traditional reasons, MESSAGE always includes a leading `erc-notice-prefix' and a trailing newline." :options '(erc-log-matches erc-hide-fools erc-beep-on-match) :type 'hook) @@ -267,6 +290,22 @@ available via universal argument." (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 +361,8 @@ Note that this is the default face to use if LIST must be passed as a symbol The query happens using PROMPT. Completion is performed on the optional alist COMPLETIONS." + (when erc-match--opt-pat-cache + (setq erc-match--opt-pat-cache nil)) (let ((entry (completing-read prompt completions @@ -345,6 +386,8 @@ Completion is performed on the optional alist COMPLETIONS." LIST must be passed as a symbol. The elements of LIST can be strings, or cons cells where the car is the string." + (when erc-match--opt-pat-cache + (setq erc-match--opt-pat-cache nil)) (let* ((alist (mapcar (lambda (x) (if (listp x) x @@ -468,7 +511,310 @@ In any of the following situations, MSG is directed at an entry FOOL: (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.") + ( newlinep nil :type boolean + :documentation "Whether narrowed buffer includes trailing newline.")) + +(cl-defstruct (erc-match-traditional + (:constructor erc-match-traditional) + (:include erc-match + (handler #'erc-match-highlight) + (newlinep t))) + "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). For compatibility, the narrowed buffer includes a +trailing newline." + ( 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.") + +(defun erc-match--opt-pat-get (compute-fn input) + "Retrieve cached results for computing INPUT with COMPUTE-FN." + (with-memoization (alist-get input (alist-get compute-fn + erc-match--opt-pat-cache nil t) + nil t) + (funcall compute-fn input))) + +(defun erc-match--opt-pat-make (patterns) + "Act like `regexp-opt' but for regexp PATTERNS, not fixed strings." + (string-join patterns "\\|")) + +(defun erc-match--opt-pat-make-kw (patterns) + (mapconcat (lambda (w) (or (car-safe w) w)) patterns "\\|")) + +(defun erc-match--opt-pat-make-addr-beg (patterns) + (concat "\\<\\(" (erc-match--opt-pat-make patterns) "\\)[:,] ")) + +(defun erc-match--opt-pat-make-addr-end (patterns) + (concat "\\s. \\(" (erc-match--opt-pat-make patterns) "\\)\\s.")) + +(defun erc-match--current-nick-p (match) + (re-search-forward (car (erc-match-traditional-data match)) nil t)) + +(defun erc-match--keyword-p (match) + "Return non-nil if the pattern given for MATCH's user option matches." + (and-let* ((patterns (erc-match-traditional-data match))) + (goto-char (erc-match-body-beg match)) + (re-search-forward (erc-match--opt-pat-get #'erc-match--opt-pat-make-kw + patterns) + nil t))) + +(defun erc-match--user-nuh-or-mention-p (match) + "Return non-nil on matching \"NUH\" for MATCH object. +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 match))) + (or (string-match (erc-match--opt-pat-get #'erc-match--opt-pat-make + patterns) + (erc-match-sender match)) + (and (or (eq (erc-match-traditional-category match) 'fool) + (eq (erc-match-traditional-part match) '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 match)) + (or (looking-at (erc-match--opt-pat-get + #'erc-match--opt-pat-make-addr-beg + patterns)) + (search-forward-regexp + (erc-match--opt-pat-get #'erc-match--opt-pat-make-addr-end + patterns) + nil t)))))) + +(cl-defgeneric erc-match-highlight-by-part (match part) + "Highlight PART of narrowed buffer for `erc-match' object MATCH.") + +(cl-defmethod erc-match-highlight-by-part ((match erc-match-traditional) + (_ (eql nick))) + "Highlight MATCH's nick in the bracketed speaker portion of the message." + (when (erc-match-spkr-beg match) + (erc-put-text-property (erc-match-spkr-beg match) + (erc-match-spkr-end match) + 'font-lock-face + (erc-match-traditional-face match)))) + +(cl-defmethod erc-match-highlight-by-part ((match erc-match-traditional) + (_ (eql message))) + "Highlight MATCH's message body, not including the leading speaker tag." + (erc-put-text-property (erc-match-body-beg match) (point-max) + 'font-lock-face (erc-match-traditional-face match))) + +(cl-defmethod erc-match-highlight-by-part ((match erc-match-traditional) + (_ (eql all))) + "Highlight MATCH's whole message, including the speaker tag." + (erc-put-text-property (point-min) (point-max) + 'font-lock-face (erc-match-traditional-face match))) + +(cl-defmethod erc-match-highlight-by-part ((match erc-match-traditional) + (_ (eql keyword))) + "Highlight all occurrences of all keyword patterns for MATCH." + (dolist (pat (erc-match-traditional-data match)) + (let ((regex (if (consp pat) (car pat) pat)) + (face (if (consp pat) (cdr pat) (erc-match-traditional-face match)))) + (goto-char (erc-match-body-beg match)) + (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 ((match erc-match-traditional) + (_ (eql nick-or-keyword))) + "Highlight MATCH's speaker-tag nick if applicable, otherwise all mentions." + (if (erc-match-spkr-end match) + (erc-put-text-property (erc-match-spkr-beg match) + (erc-match-spkr-end match) + 'font-lock-face + (erc-match-traditional-face match)) + (erc-match-highlight-by-part match 'keyword))) + +(cl-defmethod erc-match-highlight-by-part ((match erc-match-traditional) + (_ (eql nick-or-mention))) + "Highlight MATCH's speaker tag nick of matching users or all mentions." + (cl-letf (((erc-match-body-beg match) + (or (erc-match-spkr-beg match) (point-min)))) + (erc-match-highlight-by-part match 'keyword))) + +(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 (match) + "Dispatch `erc-match-highlight-by-part' on MATCH's `:part' slot. +Run `erc-text-matched-hook' when MATCH's `category' slot is non-nil." + (unless (erc-match-traditional-p match) + (signal 'wrong-type-argument (list 'erc-match-traditional match))) + (cl-assert (erc-match-newlinep match)) + (erc-match-highlight-by-part match (erc-match-traditional-part match)) + (when (erc-match-traditional-category match) + (let ((user-nuh (and (erc-match-nick match) (erc-match-sender match))) + (erc-match-highlight-matched match)) + (run-hook-with-args 'erc-text-matched-hook + (erc-match-traditional-category match) + (or user-nuh (format "Server:%s" + (erc-match-command match))) + ;; For compatibility, include a leading "*** ". + (buffer-substring (if user-nuh + (erc-match-body-beg match) + (point-min)) + (point-max)))))) + +(defun erc-match-get-message-body (match) + "Return the message body for MATCH in the current narrowed buffer." + (with-restriction (point-min) + (if (erc-match-newlinep match) (point-max) (1+ (point-max))) + (buffer-substring (erc-match-body-beg match) (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 `erc-match' handler if its predicate returns non-nil. +Call CONSTRUCTOR with SPKR-BEG, SPKR-END, BODY-BEG, NICK SENDER, and +COMMAND to create the `erc-match' 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))) + (if (erc-match-newlinep instance) + (funcall (erc-match-handler instance) instance) + (with-restriction (point-min) (1- (point-max)) + (funcall (erc-match-handler instance) instance))) + (push (cons constructor instance) erc-match--instances) + nil)) + +(defun erc-match--message () + "Run `erc-match-functions' against contents of narrowed buffer." + (goto-char (point-min)) + (let* ((response erc--parsed-response) + (user-nuh (and response (erc-get-parsed-vector-nick response))) + ;; Nick of sender's NUH if they are not the server itself. + (nick (and user-nuh (or (erc--check-msg-prop 'erc--spkr) + (erc-extract-nick user-nuh)))) + (unknownp (erc--check-msg-prop 'erc--msg 'unknown)) + (spkr-end (and (not unknownp) (erc--get-speaker-bounds))) + (spkr-beg (and spkr-end (pop spkr-end))) + (body-beg (save-excursion + (unless unknownp + (when-let* ((fn (erc--check-msg-prop 'erc--pfx))) + (funcall fn))) + (point-marker))) + (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)))) + +(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 mostly replicated bug for bug" "32.1") + (defun erc-match-message () + "Run handlers for matched patterns in 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--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 +937,25 @@ The behavior of this function is controlled by the variables 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 178addeb604..0bb347785c6 100644 --- a/test/lisp/erc/erc-match-tests.el +++ b/test/lisp/erc/erc-match-tests.el @@ -251,8 +251,9 @@ (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))) @@ -346,6 +347,77 @@ (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)) @@ -411,6 +483,30 @@ (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)) @@ -476,6 +572,30 @@ (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)) @@ -520,6 +640,11 @@ (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)) @@ -576,6 +701,11 @@ (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@@]") @@ -598,5 +728,130 @@ (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)))) + +(ert-deftest erc-match--opt-pat-cache () + (let ((erc-match--opt-pat-cache ())) + (let ((erc-keywords '("foo"))) + (erc-match--keyword-p (erc-match-opt-keyword :body-beg 1 + :sender "" + :command 'fake))) + (let ((erc-keywords '("bar"))) + (erc-match--keyword-p (erc-match-opt-keyword :body-beg 1 + :sender "" + :command 'fake))) + (let ((erc-fools '("baz"))) + (erc-match--user-nuh-or-mention-p (erc-match-opt-fool :body-beg 1 + :sender "" + :command 'fake))) + (should (equal erc-match--opt-pat-cache + '((erc-match--opt-pat-make-addr-end + (("baz") . "\\s. \\(baz\\)\\s.")) + (erc-match--opt-pat-make-addr-beg + (("baz") . "\\<\\(baz\\)[:,] ")) + (erc-match--opt-pat-make + (("baz") . "baz")) + (erc-match--opt-pat-make-kw + (("bar") . "bar") (("foo") . "foo"))))))) + +;; 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 (m) + (should (eq (erc-match-newlinep m) + (= ?\n (char-before (point-max))))) + (push (match-string 0) results) + (push (erc-match-get-message-body m) results)) + :newlinep (zerop (random 2)) + 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)) + + ;; Trailing newline doesn't affect `erc-match-get-message-body'. + (should (equal results '("hi ALICE" + "ALICE" + "Users on #chan: bob tester Alice" + "Alice"))))))) + +;; This one piggybacks on infrastructure supporting the traditional +;; `match' interface. +(ert-deftest erc-match-functions/api/parts-based () + (let* ((results ()) + (bodies ()) + (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)) + ;; Override `erc-match-highlight'. + :handler (lambda (m) + (push (erc-match-get-message-body m) + bodies) + (erc-match-highlight m)) + 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)) + + ;; Prefixes detected for notices and spoken messages. + (should (equal bodies + '("hi ALICE" + "Users on #chan: Alice bob tester"))) + + (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 diff --git a/test/lisp/erc/erc-scenarios-match-api.el b/test/lisp/erc/erc-scenarios-match-api.el new file mode 100644 index 00000000000..0a8afbf33f2 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-match-api.el @@ -0,0 +1,127 @@ +;;; erc-scenarios-match-api.el --- `erc-match-functions' scenarios -*- lexical-binding: t -*- + +;; Copyright (C) 2026 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-match) +(require 'erc-stamp) + +(defun erc-scenarios-match-api--test-fn (&rest plist) + (apply #'erc-match + :predicate #'always + :handler (lambda (m) + (let ((body (erc-match-get-message-body m)) + (cmd (format (if (numberp (erc-match-command m)) + "%03i" + "%s") + (erc-match-command m))) + (nick (or (erc-match-nick m) "?"))) + (with-current-buffer "*erc-match test matches*" + (save-excursion + (goto-char (point-max)) + (insert cmd " " nick ": " body "\n"))))) + plist)) + +(defun erc-scenarios-match-api--custom-match-functions () + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "match/functions") + (dumb-server (erc-d-run "localhost" t 'custom)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter)) + (erc-server-flood-penalty 0.1) + (erc-autojoin-channels-alist '((foonet "#chan"))) + (match-buffer (get-buffer-create "*erc-match test matches*")) + (erc-match-functions + (cons #'erc-scenarios-match-api--test-fn erc-match-functions)) + ;; Shadow this date stamp instead of mocking the time function. + ;; The version numbers in the QUIT message don't need this + ;; because they're printed verbatim from the server response. + (erc-message-english-s329 "%c was created on @@DATESTAMP@@")) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :user "tester" + :nick "tester") + (funcall expect 5 "debug"))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 10 "<alice> There were none principal") + (erc-scenarios-common-say "/query bob")) + + (with-current-buffer "bob" + (erc-scenarios-common-say "hi") + (funcall expect 10 "<bob> As much as ever Coriolanus did")) + + (with-current-buffer "foonet" + (erc-scenarios-common-say "/msg NickServ help identify") + (funcall expect 10 "End of NickServ HELP")) + + (with-current-buffer "#chan" + (funcall expect 10 "<alice> bob: Thus men may grow wiser") + (erc-scenarios-common-say "/quit") + (funcall expect 10 "quit: Quit:")) + + (with-current-buffer "foonet" + (funcall expect 10 "==> ERROR")) + + (with-temp-buffer + (insert-file-contents + (expand-file-name "match/functions/custom-match-log" + (ert-resource-directory))) + (let ((expected (buffer-string))) + (with-current-buffer "*erc-match test matches*" + (should (equal expected (buffer-string)))))))) + +;; These tests primarily ensure that the various fields of the +;; `erc-match' object, like `spkr-beg', as well as associated utilities, +;; like `erc-match-get-message-body', work as expected. It defines a +;; custom `erc-match-functions' member that prints a summary of every +;; displayed message to its own buffer. That buffer's contents appear +;; in the file resources/match/functions/custom-match-log. + +(ert-deftest erc-scenarios-match-api--custom-functions/basic () + :tags '(:expensive-test) + (erc-scenarios-match-api--custom-match-functions)) + +(ert-deftest erc-scenarios-match-api--custom-functions/fill-wrap () + :tags '(:expensive-test) + (let ((erc-modules (cons 'fill-wrap erc-modules))) + (erc-scenarios-match-api--custom-match-functions))) + +(ert-deftest erc-scenarios-match-api--custom-functions/left-stamps () + :tags '(:expensive-test) + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-left) + (erc-timestamp-only-if-changed-flag nil)) + (erc-scenarios-match-api--custom-match-functions))) + +(ert-deftest erc-scenarios-match-api--custom-functions/left-stamps/fill-wrap () + :tags '(:expensive-test) + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-left) + (erc-timestamp-only-if-changed-flag nil) + (erc-modules (cons 'fill-wrap erc-modules))) + (erc-scenarios-match-api--custom-match-functions))) + +;;; erc-scenarios-match-api.el ends here diff --git a/test/lisp/erc/resources/match/functions/custom-match-log b/test/lisp/erc/resources/match/functions/custom-match-log new file mode 100644 index 00000000000..4b07e4c4fe6 --- /dev/null +++ b/test/lisp/erc/resources/match/functions/custom-match-log @@ -0,0 +1,39 @@ +001 ?: Welcome to the foonet IRC Network tester +002 ?: Your host is irc.foonet.org, running version ergo-v2.17.0 +003 ?: This server was created Sat, 25 Apr 2026 06:08:20 UTC +004 ?: irc.foonet.org ergo-v2.17.0 BERTZios CEIMRUabefhiklmnoqstuv +005 ?: AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=25 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX are supported by this server +005 ?: KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 MSGREFTYPES=msgid,timestamp NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ SAFELIST SAFERATE STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 are supported by this server +005 ?: TOPICLEN=390 UTF8ONLY WHOX draft/CHATHISTORY=25 are supported by this server +251 ?: There are 0 users and 4 invisible on 1 server(s) +252 ?: 0 operator(s) online +253 ?: 0 unknown connection(s) +254 ?: 2 channels formed +255 ?: I have 4 clients and 0 servers +265 ?: Current local users 4, max 4 +266 ?: Current global users 4, max 4 +422 ?: MOTD File is missing +221 ?: User modes for tester: +i +NOTICE ?: This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. +221 ?: User modes for tester: +i +JOIN tester: You have joined channel #chan +353 ?: Users on #chan: @fsbot alice bob tester +PRIVMSG alice: tester, welcome! +PRIVMSG bob: tester, welcome! +PRIVMSG bob: alice: No tearing, lady; I perceive you know it. +324 ?: #chan modes: +Cnt +329 ?: #chan was created on @@DATESTAMP@@ +PRIVMSG alice: There were none principal; they were all like one another as half-pence are; every one fault seeming monstrous till his fellow fault came to match it. +PRIVMSG bob: As much as ever Coriolanus did. +NOTICE NickServ: *** NickServ HELP *** +NOTICE NickServ: Syntax: IDENTIFY <username> [password] +NOTICE NickServ: IDENTIFY lets you login to the given username using either password auth, or +NOTICE NickServ: certfp (your client certificate) if a password is not given. +NOTICE NickServ: *** End of NickServ HELP *** +PRIVMSG bob: alice: Deceive me not now, Navarre is infected. +PRIVMSG bob: Bear me to prison, where I am committed. +PRIVMSG alice: Wisely and slow; they stumble that run fast. +PRIVMSG alice: bob: Thus men may grow wiser every day: it is the first time that ever I heard breaking of ribs was sport for ladies. +QUIT tester: tester ([email protected]) has quit: Quit: ERC 5.6.2-git (IRC client for GNU Emacs 31.0.50) +QUIT tester: tester ([email protected]) has quit: Quit: ERC 5.6.2-git (IRC client for GNU Emacs 31.0.50) +ERROR ?: ERROR from 127.0.0.1: Quit: ERC 5.6.2-git (IRC client for GNU Emacs 31.0.50) diff --git a/test/lisp/erc/resources/match/functions/custom.eld b/test/lisp/erc/resources/match/functions/custom.eld new file mode 100644 index 00000000000..073c1e403bb --- /dev/null +++ b/test/lisp/erc/resources/match/functions/custom.eld @@ -0,0 +1,49 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.00 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.17.0") + (0.00 ":irc.foonet.org 003 tester :This server was created Sat, 25 Apr 2026 06:08:20 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.17.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=25 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.00 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 MSGREFTYPES=msgid,timestamp NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ SAFELIST SAFERATE STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 :are supported by this server") + (0.00 ":irc.foonet.org 005 tester TOPICLEN=390 UTF8ONLY WHOX draft/CHATHISTORY=25 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.10 ":irc.foonet.org 254 tester 2 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4") + (0.00 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") + (0.00 ":irc.foonet.org 422 tester :MOTD File is missing") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) +((mode 10 "MODE tester +i")) +((join 10 "JOIN #chan") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":[email protected] JOIN #chan") + (0.01 ":irc.foonet.org 353 tester = #chan :@fsbot alice bob tester") + (0.00 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.01 ":[email protected] PRIVMSG #chan :tester, welcome!") + (0.00 ":[email protected] PRIVMSG #chan :tester, welcome!") + (0.03 ":[email protected] PRIVMSG #chan :alice: No tearing, lady; I perceive you know it.")) +((mode-chan 10 "MODE #chan") + (0.00 ":irc.foonet.org 324 tester #chan +Cnt") + (0.00 ":irc.foonet.org 329 tester #chan 1777097304") + (0.01 ":[email protected] PRIVMSG #chan :There were none principal; they were all like one another as half-pence are; every one fault seeming monstrous till his fellow fault came to match it.")) +((privmsg-bob 10 "PRIVMSG bob :hi") + (0.03 ":[email protected] PRIVMSG tester :As much as ever Coriolanus did.")) +((privmsg-nickserv 10 "PRIVMSG NickServ :help identify") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :*** \2NickServ HELP\2 ***") + (0.00 ":NickServ!NickServ@localhost NOTICE tester :Syntax: \2IDENTIFY <username> [password]\2") + (0.00 ":NickServ!NickServ@localhost NOTICE tester :IDENTIFY lets you login to the given username using either password auth, or") + (0.00 ":NickServ!NickServ@localhost NOTICE tester :certfp (your client certificate) if a password is not given.") + (0.00 ":NickServ!NickServ@localhost NOTICE tester :*** \2End of NickServ HELP\2 ***") + ;; + (0.07 ":[email protected] PRIVMSG #chan :alice: Deceive me not now, Navarre is infected.") + (0.04 ":[email protected] PRIVMSG #chan :Bear me to prison, where I am committed.") + (0.07 ":[email protected] PRIVMSG #chan :Wisely and slow; they stumble that run fast.") + (0.03 ":[email protected] PRIVMSG #chan :bob: Thus men may grow wiser every day: it is the first time that ever I heard breaking of ribs was sport for ladies.")) +((quit 10 "QUIT :") + (0.01 ":[email protected] QUIT :Quit: \2ERC\2 5.6.2-git (IRC client for GNU Emacs 31.0.50)") + (0.00 "ERROR :Quit: \2ERC\2 5.6.2-git (IRC client for GNU Emacs 31.0.50)"))