* bug#73798: 31.0.50; ERC 5.7: New extensibility focused match API
@ 2024-10-14 2:21 J.P.
0 siblings, 0 replies; only message in thread
From: J.P. @ 2024-10-14 2:21 UTC (permalink / raw)
To: 73798; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 16543 bytes --]
Tags: patch
This follows loosely from bug#73580 and bug#68265.
It's well known that a favorite pastime of ERC users is griping about
its lack of an easily exploitable API for analyzing and manipulating
message content. The current landscape is indeed regrettably sparse,
with avenues either too rough and tumble, like at the protocol handling
level, or too zoomed out and refined, like at the user options level.
The traditional go-to solution (one certainly not known for its stellar
UX) lies somewhere in between. Often called the "message insertion"
phase (by me), this somewhat nebulous and often feared limbo period
between message receipt and display is home to the infamous
`erc-insert-modify-hook' and friends, where a good many modules,
including `match', do their dirty work.
Anyone familiar with the aforementioned bug#68265 will know that it's
very much about offering access before initial formatting takes place,
meaning just prior to insertion. Another TBD bug to be opened eventually
will explore the flip side: an easier way to examine and influence a
message's fate during insertion (e.g., determining which insertion hooks
run and how their arguments and return values take shape). As mentioned,
this current bug is meant to address modification immediately after
insertion, while a message's content and format are less violently in
flux but still being finalized in the narrowed buffer.
Here's the proposed documentation:
File: erc.info, Node: Match API, Next: Options, Prev: Module Loading,
Up: Advanced Usage
5.6 Match API
=============
This section describes the low-level ‘match’ API introduced in ERC 5.7.
For basic, options-oriented usage, please see the doc strings for option
‘erc-pal-highlight-type’ and friends in the ‘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 ‘erc-match’ API, which centers around a ‘cl-defstruct’
“type” of the same name:
-- Struct: erc-match predicate spkr-beg spkr-end body-beg sender nick
command handler
This is a ‘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
‘erc-match’ instance. To use this interface, you add a
“constructor”-like function to the list ‘erc-match-types’:
-- User Option: erc-match-types
A hook-like list of functions, where each accepts the
parameters named above as an ‘&rest’-style plist and returns a
new ‘erc-match’ instance. A function can also be a
traditional ‘cl-defstruct’-provided constructor belonging to a
“subtype” you've defined.
The only slot you definitely need to specify is ‘predicate’. Both
it and ‘handler’ are functions that take a single argument: the
instance itself. As its name implies, ‘predicate’ must return
non-‘nil’ if ‘handler’, whose return value ERC ignores, should run.
A few slots, like ‘spkr-beg’, ‘spkr-end’, and ‘nick’, may surprise
you. The first two are ‘nil’ for non-chat messages, like those
displayed for ‘JOIN’ events. The ‘nick’ slot can likewise be ‘nil’
if the sender of the message is a domain-style host name, such as
‘irc.example.org’, which it often is for informational messages,
like ‘*** #chan was created on 2023-12-26 00:36:42’.
To locate the start of the just-inserted message, use ‘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
‘erc-match-get-message-body’:
-- Function: erc-match-get-message-body match
Takes an ‘erc-match’ instance and returns a string containing
the message body, sans trailing newline and any leading
speaker or decorative component, such as ‘erc-notice-prefix’.
Although module authors may want to subclass this struct, everyday users
can just instantiate it directly (it's “concrete”). This is especially
handy for one-off tasks or simple customizations in your ‘init.el’. 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))
(setopt erc-match-types (add-to-list 'erc-match-types #'my-match)
erc-prompt (lambda () (format "%d!" my-mentions)))
Here, the user could just as well shove the incrementer into the
‘predicate’ body, since ‘handler’ is set to ‘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-‘PRIVMSG’ messages via the slot
‘command’.
For a detailed example showing how to use this API for more involved
matching that doesn't involve highlighting, see the ‘notifications’
module, which lives in ‘erc-desktop-notifications.el’. Ignore the parts
that involve adapting the global setup (and teardown) business to a
buffer-local context. Since your module is declared ‘local’, as per the
modern convention, you won't be needing such code, so feel free to use
utility functions like ‘erc-match-add-local-type’ directly in your
module's definition.
5.6.1 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 ‘match’ 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-keywords))
((cdr (assoc (erc-target) chans)))))
:face 'my-face
plist))
(setopt erc-match-types (add-to-list 'erc-match-types #'my-match))
Here, the user leverages a handy subtype of ‘erc-match’, called
‘erc-match-opt-keyword’, which actually descends directly from another,
intermediate ‘erc-match’ type:
-- Struct: erc-match-traditional category face data part
Use this type or one of its descendants (see below) if you want
‘erc-text-matched-hook’ to run alongside (after) the ‘handler’
slot's default highlighter, ‘erc-match-highlight’, on every match
for which the ‘category’ slot's value is non-‘nil’ (it becomes the
argument provided for the hook's MATCH-TYPE parameter).
Much more important, however, is ‘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
‘nick’, ‘message’, ‘all’, ‘keyword’, ‘nick-or-keyword’, and
‘nick-or-mention’.
The default handler, ‘erc-match-highlight’, does its work by
deferring to a purpose-built “method” meant to handle ‘part’-based
highlighting:
-- Method on erc-match-traditional: erc-match-highlight-by-part
instance part
You can override this method by “specializing” on any
subclassed ‘erc-match-traditional’ type and/or non-reserved
PART, such as one known only to your ‘init.el’ or (informally)
associated with your package by its library “namespace”.
You likely won't be needing these, but for the sake of completeness,
other options-based types similar to ‘erc-match-opt-keyword’ include
‘erc-match-opt-current-nick’, ‘erc-match-opt-fool’, ‘erc-match-opt-pal’,
and ‘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 ‘erc-match-traditional’ type:
;; -*- 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))))))
(cl-defstruct (my-match (:include erc-match-opt-keyword
(part 'keyword)
(data (my-get-keyword))
(face 'my-keyword))
(:constructor my-match)))
(setopt erc-match-types (add-to-list 'erc-match-types #'my-match))
(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)))))
(Note that in the method body, you _could_ technically skip to the
beginning of the last match for the first go around because the match
data from the ‘predicate’ is still fresh.)
Some canned Q&As:
1. ERC is already famously bogged down by ill-conceived contracts, why
add another?
This isn't just some new feature. It's a revamping and refactoring of
the `match' library that exposes much needed foundational seams to
users while encapsulating some compat-related business and other
unruly minutiae, such as text-property twiddling. It also includes a
partial refactoring of the `notifications' module (housed in
erc-desktop-notifications.el) that makes heavy use of this new API
and thus serves as a reference implementation for certain flavors of
non-highlight-centric matching.
But TBF, the "extensibility focused" bit from this bug's subject line
is somewhat of a stretch. In reality, such extensibility is merely a
knock-on effect of bending over backward to prioritize compatibility.
But that doesn't mean it can't also help tamp down on contracts
proliferation in ERC. For those unfamiliar, users often rightly call
for some existing option to be expanded or spun off into a variant
more attuned to a specific context: e.g., option erc-foo needs to be
network/channel/nickname aware. One way to push back on such demands
is to point to a not-too-painful existing workaround.
2. Why not combine the predicate and handler slots of match objects?
We certainly could (and very well still might), in which case this
would end up looking more like a traditional hook arrangement. The
original idea was to promote code reuse and separation of concerns by
enforcing a bit of structure. However, it's certainly true that hook
members could just as easily perform the predicate and handler logic
themselves.
3. Why the separate message-body getter instead of a dedicated slot?
To retain that state in match objects would mean having to update it
between handler runs because users are invited to modify the text.
(This will be mentioned in a code comment.)
4. Why not EIEIO?
While such a move might help "consumers" of the API to some degree,
the expanded feature set won't really have the same impact on
implementation and upkeep of the library. And though ERC does
currently pull in dependencies that in turn require EIEIO, that may
not always be so.
(Note that while the attached patches target ERC 5.7, they don't include
changes to bump the version, etc.)
For anyone interested in this bug, feedback of any form is always
welcome.
Thanks!
In GNU Emacs 31.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version
3.24.43, cairo version 1.18.0) of 2024-10-07 built on localhost
Repository revision: ff4de9eff30ade164655354f71e7cbca48135858
Repository branch: master
Windowing system distributor 'The X.Org Foundation', version 11.0.12401002
System Description: Fedora Linux 40 (Workstation Edition)
Configured using:
'configure --enable-check-lisp-object-type --enable-checking=yes,glyphs
'CFLAGS=-O0 -g3'
PKG_CONFIG_PATH=:/usr/lib64/pkgconfig:/usr/share/pkgconfig'
Configured features:
ACL CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GPM GSETTINGS HARFBUZZ JPEG
LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 M17N_FLT MODULES NATIVE_COMP
NOTIFY INOTIFY PDUMPER PNG RSVG SECCOMP SOUND SQLITE3 THREADS TIFF
TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM XINPUT2 XPM GTK3 ZLIB
Important settings:
value of $LANG: en_US.UTF-8
value of $XMODIFIERS: @im=ibus
locale-coding-system: utf-8-unix
Major mode: Lisp Interaction
Minor modes in effect:
tooltip-mode: t
global-eldoc-mode: t
eldoc-mode: t
show-paren-mode: t
electric-indent-mode: t
mouse-wheel-mode: t
tool-bar-mode: t
menu-bar-mode: t
file-name-shadow-mode: t
global-font-lock-mode: t
font-lock-mode: t
blink-cursor-mode: t
minibuffer-regexp-mode: t
line-number-mode: t
indent-tabs-mode: t
transient-mark-mode: t
auto-composition-mode: t
auto-encryption-mode: t
auto-compression-mode: t
Load-path shadows:
None found.
Features:
(shadow sort mail-extr compile comint ansi-osc ansi-color ring comp-run
bytecomp byte-compile comp-common rx emacsbug message mailcap yank-media
puny dired dired-loaddefs rfc822 mml mml-sec password-cache epa derived
epg rfc6068 epg-config gnus-util text-property-search time-date subr-x
mm-decode mm-bodies mm-encode mail-parse rfc2231 mailabbrev gmm-utils
mailheader cl-loaddefs cl-lib sendmail rfc2047 rfc2045 ietf-drums
mm-util mail-prsvr mail-utils rmc iso-transl tooltip cconv eldoc paren
electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode mwheel
term/x-win x-win term/common-win x-dnd touch-screen tool-bar dnd fontset
image regexp-opt fringe tabulated-list replace newcomment text-mode
lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow isearch
easymenu timer select scroll-bar mouse jit-lock font-lock syntax
font-core term/tty-colors frame minibuffer nadvice seq simple cl-generic
indonesian philippine cham georgian utf-8-lang misc-lang vietnamese
tibetan thai tai-viet lao korean japanese eucjp-ms cp51932 hebrew greek
romanian slovak czech european ethiopic indian cyrillic chinese
composite emoji-zwj charscript charprop case-table epa-hook
jka-cmpr-hook help abbrev obarray oclosure cl-preloaded button loaddefs
theme-loaddefs faces cus-face macroexp files window text-properties
overlay sha1 md5 base64 format env code-pages mule custom widget keymap
hashtable-print-readable backquote threads dbusbind inotify lcms2
dynamic-setting system-font-setting font-render-setting cairo gtk
x-toolkit xinput2 x multi-tty move-toolbar make-network-process
native-compile emacs)
Memory information:
((conses 16 59412 9167) (symbols 48 6747 0) (strings 32 16822 4165)
(string-bytes 1 492565) (vectors 16 11411)
(vector-slots 8 139223 13079) (floats 8 21 4) (intervals 56 248 0)
(buffers 984 11))
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-5.7-Use-speaker-prefix-end-marker-in-ERC-insertion-h.patch --]
[-- Type: text/x-patch, Size: 9591 bytes --]
From 84951100aef9776b39d7ee9d1ffbe2ae307b5141 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 6 Oct 2024 23:17:40 -0700
Subject: [PATCH 1/3] [5.7] Use speaker/prefix-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 1e81adbf6ba..abf3bbbb556 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 63aeaea9c46..ed7babbb6d1 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -3187,7 +3187,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."
@@ -3211,6 +3212,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."
@@ -3325,6 +3331,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))
@@ -3449,6 +3462,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.
@@ -3506,8 +3533,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)
@@ -8367,8 +8396,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.46.2
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-5.7-Introduce-lower-level-erc-match-API.patch --]
[-- Type: text/x-patch, Size: 53645 bytes --]
From 15396eac72595374091c362d3c6fee3e3f4f5d87 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
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-types): New variable.
(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): New function.
(erc-match--type): New variable.
(erc-match-add-local-type, erc-match-remove-local-types): New functions.
(erc-match-type-get-message-body): 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.
(erc-match--setup): Tear down `erc-match--types'.
* 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): New tests.
---
doc/misc/erc.texi | 332 +++++++++++++++++++-----
lisp/erc/erc-match.el | 421 +++++++++++++++++++++++++++++--
test/lisp/erc/erc-match-tests.el | 212 +++++++++++++++-
3 files changed, 879 insertions(+), 86 deletions(-)
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index 9368c9ce070..67f8fbe77e6 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
@@ -663,63 +665,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
@@ -732,6 +677,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
@@ -2055,6 +2002,277 @@ 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 list @code{erc-match-types}:
+
+ @defopt erc-match-types
+
+ A hook-like list of functions, where each 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))
+
+(setopt erc-match-types (add-to-list 'erc-match-types #'my-match)
+ 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). Likewise, 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 showing how to use this API for more involved
+matching that doesn't involve highlighting, see the @samp{notifications}
+module, which lives in @file{erc-desktop-notifications.el}. 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 use utility functions like @code{erc-match-add-local-type} directly
+in your module's definition.
+
+@anchor{highlighting}
+@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.
+
+@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))
+
+(setopt erc-match-types (add-to-list 'erc-match-types #'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 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 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},
+@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:
+
+@lisp
+;; -*- 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))))))
+
+(cl-defstruct (my-match (:include erc-match-opt-keyword
+ (part 'keyword)
+ (data (my-get-keyword))
+ (face 'my-keyword))
+ (:constructor my-match)))
+
+(setopt erc-match-types (add-to-list 'erc-match-types #'my-match))
+
+(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)))))
+@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.)
+
+
@node Options
@section Options
@cindex options
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index e28e7122cce..56d74ebf7c9 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)))
@@ -263,6 +270,23 @@ erc-match-quote-when-adding
(const t)
(const nil)))
+(defcustom erc-match-types '(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
+further details."
+ :package-version '(ERC . "5.7") ; FIXME sync on release
+ :type '(set (function-item erc-match-opt-pal)
+ (function-item erc-match-opt-fool)
+ (function-item erc-match-opt-dangerous-host)
+ (function-item erc-match-opt-keyword)
+ (function-item erc-match-opt-current-nick)
+ (repeat :tag "User-specified constructor" :inline t function)))
+
+
;; Internal variables:
;; This is exactly the same as erc-button-syntax-table. Should we
@@ -318,6 +342,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
@@ -341,6 +366,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
@@ -464,7 +490,348 @@ 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 list `erc-match-types'. 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))
+ "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)))
+
+(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))))
+ (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))))))
+
+(defvar-local erc-match--types nil
+ "Additional `erc-match-types' for use by other modules.")
+
+(defun erc-match-add-local-type (function)
+ "Add FUNCTION to registered type in current buffer."
+ (push function erc-match--types))
+
+(defun erc-match-remove-local-type (function)
+ "Remove FUNCTION from registered types in current buffer."
+ (unless (setq erc-match--types (delete function erc-match--types))
+ (kill-local-variable 'erc-match--types)))
+
+(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--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)))
+ (with-syntax-table erc-match-syntax-table
+ (dolist (type (if erc-match--types
+ (append erc-match--types erc-match-types)
+ erc-match-types))
+ (when-let ((instance (funcall type
+ :spkr-beg spkr-beg
+ :spkr-end spkr-end
+ :body-beg body-beg
+ :nick nick
+ :sender (erc-response.sender response)
+ :command command))
+ ((or user-nuh (not (erc-match-user-p instance))))
+ ((goto-char (point-min)))
+ ((funcall (erc-match-predicate instance) instance)))
+ (funcall (erc-match-handler instance) instance))))
+ (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)
+ ;; FIXME only run when `erc--skip' does not include `match'.
+ (unless (or (and erc-match-exclude-server-buffer (erc--server-buffer-p))
+ (null (erc--check-msg-prop 'erc--cmd)))
+ (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.
@@ -587,27 +954,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."
@@ -693,7 +1058,9 @@ erc-match--setup
;; invisible properties managed by this module.
(if erc-match-mode
(erc-match-toggle-hidden-fools +1)
- (erc-match-toggle-hidden-fools -1)))
+ (erc-match-toggle-hidden-fools -1)
+ (when (null erc-match--types)
+ (kill-local-variable 'erc-match--types))))
(defun erc-match-toggle-hidden-fools (arg)
"Toggle fool visibility.
diff --git a/test/lisp/erc/erc-match-tests.el b/test/lisp/erc/erc-match-tests.el
index d22a945724b..8ac53527a09 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@@]"))
@@ -588,5 +718,83 @@ 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-types' API that opts
+;; out of the "parts-based" framework. 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-types/api/non-parts-based ()
+ (let* ((results ())
+ (erc-text-matched-hook (lambda (&rest r) (push r results)))
+ (erc-match-types
+ (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-types/api/parts-based ()
+ (let* ((results ())
+ (erc-text-matched-hook (lambda (&rest r) (push r results)))
+ (erc-match-types ()))
+
+ (erc-match-tests--perform
+ (lambda ()
+
+ ;; Use local setter for no particular reason.
+ (erc-match-add-local-type
+ (lambda (&rest plist)
+ (apply #'erc-match-traditional
+ :category 'keyword
+ :part 'keyword
+ :data '("alice")
+ :face 'error
+ :predicate (lambda (_) (search-forward "alice" nil t))
+ plist)))
+
+ (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 "bob!~bob@fsf.org" "hi ALICE\n")
+ ( keyword "Server:353"
+ "*** Users on #chan: Alice bob tester\n"))))))))
;;; erc-match-tests.el ends here
--
2.46.2
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0003-5.7-Use-erc-match-type-API-for-erc-desktop-notificat.patch --]
[-- Type: text/x-patch, Size: 13299 bytes --]
From f09a63f1a052fa8f33562e7a59c229318592f77a Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
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 | 68 +++++++++--
.../erc/erc-desktop-notifications-tests.el | 115 ++++++++++++++++++
3 files changed, 197 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 ea65a170b38..6b8bbb95ed1 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.
+\f
+* 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.
+
\f
* Changes in ERC 5.6.1
diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el
index 9bb89fbfc81..adc90e1f544 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,63 @@ 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
+ (erc-match-add-local-type #'erc-desktop-notifications--match-type-query)
+ (erc-match-remove-local-type
+ #'erc-desktop-notifications--match-type-query)))
+
+(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 ":bob!~bob@fsf.org 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 ":bob!~bob@fsf.org 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
+ ":bob!~bob@fsf.org PRIVMSG tester yo"))
+
+ (should-not (funcall check))))))
+
+;;; erc-desktop-notifications-tests.el ends here
--
2.46.2
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2024-10-14 2:21 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-10-14 2:21 bug#73798: 31.0.50; ERC 5.7: New extensibility focused match API J.P.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.