Re: bug#73798: 31.0.50; ERC 5.7: New extensibility focused match API
"J.P." <[email protected]> Tue, 04 Mar 2025 05:32:16 -0800
| Newsgroups | gmane.emacs.erc.general |
|---|---|
| Message-ID | <[email protected]> |
--=-=-= Content-Type: text/plain v6. Add hook option to desktop-notifications for suppressing messages based on contents, categories, etc. User k4r4b3y on Libera.Chat mentioned wanting to skip notifications from members of `erc-fools'. This makes that possible and also demos the use of the `erc-match-get-match' API function. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0000-v5-v6.diff From 641b7a11d23821ad5ab20c252544fa7eff4dc84d Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Tue, 4 Mar 2025 05:18:00 -0800 Subject: [PATCH 0/3] *** NOT A PATCH *** *** BLURB HERE *** F. Jason Park (3): [5.7] Use speaker-end marker in ERC insertion hooks [5.7] Introduce lower level erc-match API [5.7] Use erc-match-type API for erc-desktop-notifications doc/misc/erc.texi | 376 +++++++++++++++ etc/ERC-NEWS | 27 ++ lisp/erc/erc-desktop-notifications.el | 87 +++- lisp/erc/erc-fill.el | 20 +- lisp/erc/erc-match.el | 428 ++++++++++++++++-- lisp/erc/erc.el | 48 +- .../erc/erc-desktop-notifications-tests.el | 139 ++++++ test/lisp/erc/erc-match-tests.el | 214 ++++++++- 8 files changed, 1286 insertions(+), 53 deletions(-) create mode 100644 test/lisp/erc/erc-desktop-notifications-tests.el Interdiff: diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index fd4124a06d9..fd12cb8843b 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -28,6 +28,11 @@ system. You subscribe by enrolling a function that takes a special filtering, and applying faces. See Info node 'Match API' to find out more. +** Exercise more control in skipping certain desktop notifications. +Elect to skip select notifications that ERC would otherwise emit with +new hook option 'erc-desktop-notifications-skip-predicates'. Its +default members skip messages by fools and those in untracked buffers. + ** 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 diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index 20bcd543dc2..36e57a7dd15 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -52,6 +52,14 @@ erc-notifications-focused-contexts :package-version '(ERC . "5.7") ; FIXME sync on release :type '(set (const query) (const mention))) +(defcustom erc-desktop-notifications-skip-predicates + '(erc-desktop-notifications-skip-untracked + erc-desktop-notifications-skip-fools) + "Abnormal hook whose members return non-nil to suppress notification. +Called in match buffer with a matching `erc-match-user' object." + :package-version '(ERC . "5.7") ; FIXME sync on release + :type 'hook) + (defcustom erc-notifications-bus :session "D-Bus bus to use for notification." :version "25.1" @@ -102,6 +110,14 @@ erc-notifications-PRIVMSG ;; Return nil to continue processing by ERC nil) +(defun erc-desktop-notifications-skip-untracked (_) + "Return non-nil when current buffer's target appears in `erc-track-exclude'." + (and (boundp 'erc-track-exclude) (member (erc-target) erc-track-exclude))) + +(defun erc-desktop-notifications-skip-fools (_) + "Return non-nil if the current message has a \"match type\" of `fool'." + (erc-match-get-match 'erc-match-opt-fool)) + (defun erc-notifications-notify-on-match (match-type nickuserhost msg) (when (eq match-type 'current-nick) (let ((nick (nth 0 (erc-parse-user nickuserhost)))) @@ -110,8 +126,9 @@ erc-notifications-notify-on-match (frame-focus-state) ; t or unknown (not (memq 'mention erc-notifications-focused-contexts))) - (and (boundp 'erc-track-exclude) - (member nick erc-track-exclude))) + (run-hook-with-args-until-success + 'erc-desktop-notifications-skip-predicates + erc-match-highlight-matched)) (erc-notifications-notify nick msg))))) ;;;###autoload(autoload 'erc-notifications-mode "erc-desktop-notifications" "" t) @@ -129,7 +146,8 @@ notifications (defun erc-desktop-notifications--setup () (if erc-notifications-mode (add-hook 'erc-match-functions - #'erc-desktop-notifications--match-type-query 0 t) + ;; Run after default value to detect fools. + #'erc-desktop-notifications--match-type-query 20 t) (remove-hook 'erc-match-functions #'erc-desktop-notifications--match-type-query t))) @@ -155,8 +173,8 @@ erc-desktop-notifications--query-p (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))))) + (not (run-hook-with-args-until-success + 'erc-desktop-notifications-skip-predicates match)))) (defun erc-desktop-notifications--query-notify (match) ;; No need to pass argument PRIVP because current buffer is correct. diff --git a/test/lisp/erc/erc-desktop-notifications-tests.el b/test/lisp/erc/erc-desktop-notifications-tests.el index 5a9ad0ff5ba..00cf8ed45da 100644 --- a/test/lisp/erc/erc-desktop-notifications-tests.el +++ b/test/lisp/erc/erc-desktop-notifications-tests.el @@ -1,6 +1,6 @@ ;;; erc-desktop-notifications-tests.el --- Notifications tests -*- lexical-binding:t -*- -;; Copyright (C) 2024 Free Software Foundation, Inc. +;; Copyright (C) 2025 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. ;; @@ -112,4 +112,28 @@ erc-notifications-focused-contexts/unselected (should-not (funcall check)))))) +(ert-deftest erc-desktop-notifications-skip-predicates/fools () + (erc-desktop-notifications-tests--populate-chan + (lambda (check) + + ;; A private query triggers a notification. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester yo") + (should (eq (current-buffer) (get-buffer "bob"))) + + (should (equal (funcall check) + '(("bob" "yo") + ("bob" "hi tester\n")))) + + (let ((erc-fools '("bob"))) + + ;; A query from is suppressed if bob is a fool. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester ho") + (should-not (funcall check)) + + ;; A mention from bob is suppressed if bob is a fool. + (with-current-buffer "#chan" + (erc-tests-common-simulate-privmsg "bob" "hi tester") + (erc-tests-common-simulate-privmsg "alice" "hi tester") + (should (equal (funcall check) '(("alice" "hi tester\n"))))))))) + ;;; erc-desktop-notifications-tests.el ends here -- 2.48.1 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.7-Use-speaker-end-marker-in-ERC-insertion-hooks.patch From 51425461c8fe0e49ceb86890e16aa02a40407b3a Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Sun, 6 Oct 2024 23:17:40 -0700 Subject: [PATCH 1/3] [5.7] Use speaker-end marker in ERC insertion hooks * lisp/erc/erc-fill.el (erc-fill-wrap): Use `erc--offset-marker' instead of heuristics for finding the beginning of the message proper. * lisp/erc/erc.el (erc--send-action-display): Use `erc--ensure-offset-prop'. (erc--ensure-offset-prop): New function. Only works for `erc--message-speaker-catalog' entries, which all (currently) end in "%m". If any were to gain a "footer" component after their "%m", this would need to be modified, possibly to require an extra `catalog-key' parameter that could then be queried at runtime for a symbol property specifying the footer length as a negative offset. (erc--add-msg-prop): New function. (erc--offset-marker): New variable. (erc--with-offset-marker): New macro. (erc-insert-line): Run insertion hooks in `erc--with-offset-marker'. (erc--determine-speaker-message-format-args) (erc--format-speaker-input-message) (erc-ctcp-query-ACTION): Use `erc--ensure-offset-prop'. In the latter, don't set statusmsg "%s" to the target name. (erc-make-notice): Set `erc--offset' msg prop to the length of the `erc--notice-prefix', which includes a trailing space. Don't do the same for the fallback case of `erc-display-message-highlight' because some format specs contain leading characters that are basically analogs of `erc-notice-prefix'. Examining each prematurely to formulate a guess that may never be used is wasteful, and just going with 0 would sometimes be wrong or destructive, such as on subsequent passes for "compound" `erc-display-message' type parameters specified by `erc-display-error-notice', etc. (erc-display-msg): Run send hooks in `erc--with-offset-marker'. (Bug#73798) --- 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 145a4c174a8..9ccdae50f0d 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 d377839733b..cca9a395ed4 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3190,7 +3190,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." @@ -3214,6 +3215,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." @@ -3328,6 +3334,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)) @@ -3452,6 +3465,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. @@ -3509,8 +3536,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))) @@ -6437,7 +6465,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. @@ -6571,7 +6599,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) @@ -6881,12 +6909,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)) @@ -7869,6 +7897,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) @@ -8368,8 +8397,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.48.1 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-5.7-Introduce-lower-level-erc-match-API.patch From 7219aa686a0713e36d31f504cca28b7e2d270c0d Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Sat, 3 Jun 2023 02:01:29 -0700 Subject: [PATCH 2/3] [5.7] Introduce lower level erc-match API * doc/misc/erc.texi (Match API): New node under the Advanced chapter. Update menus. * lisp/erc/erc-match.el (erc-pal-highlight-type) (erc-fool-highlight-type) (erc-dangerous-host-highlight-type): Add `nick-or-mention' variant. (erc-text-matched-hook): Doc. (erc-match-functions): New option. (erc-add-entry-to-list) (erc-remove-entry-from-list): Clear options cache. (erc-match) (erc-match-traditional) (erc-match-opt-current-nick) (erc-match-opt-keyword) (erc-match-opt-user) (erc-match-opt-fool) (erc-match-opt-pal) (erc-match-opt-dangerous-host): New struct types. (erc-match--opt-pat-cache): New variable. (erc-match--opt-pat-ttl): New variable. (erc-match--opt-pat): New struct type. (erc-match--opt-pat-cache-clear) (erc-match--opt-pat-cache-clear-all) (erc-match--opt-pat-get) (erc-match--opt-pat-make) (erc-match--opt-pat-kw-make) (erc-match--opt-pat-addr-beg-make) (erc-match--opt-pat-addr-end-make) (erc-match--current-nick-p) (erc-match--keyword-p) (erc-match--user-nuh-or-mention-p): New functions. (erc-match-highlight-by-part): New generic function and methods. (erc-match-highlight-matched): New variable. (erc-match--instances): New variable. (erc-match-highlight): New function. (erc-match-get-message-body): New function. (erc-match-get-match): New function (erc-match--run-match): New function. (erc-match--message): New function. (erc-match-use-legacy-logic-p): New variable. (erc-match-message): Move body to `erc-match--message-legacy. Rework as thin wrapper. (erc-match--message-legacy): New function with body of former `erc-match-message'. (erc-log-matches): Rework to be slightly less wasteful. * test/lisp/erc/erc-match-tests.el (erc-match-tests--perform): Shadow `erc-match--opt-pat-cache'. (erc-match-message/pal/nick/legacy) (erc-match-message/fool/nick/legacy) (erc-match-message/dangerous-host/nick/legacy): New tests. (erc-match-tests--hl-type-nick-or-mention): New function. (erc-match-message/pal/nick-or-mention) (erc-match-message/fool/nick-or-mention) (erc-match-message/dangerous-host/nick-or-mention) (erc-match-message/pal/message/legacy) (erc-match-message/fool/message/legacy) (erc-match-message/dangerous-host/message/legacy) (erc-match-message/pal/all/legacy) (erc-match-message/fool/all/legacy) (erc-match-message/dangerous-host/all/legacy) (erc-match-message/current-nick/nick-or-keyword/legacy) (erc-match-message/keyword/keyword/legacy) (erc-log-matches/legacy) (erc-match-functions/api/non-parts-based) (erc-match-functions/api/parts-based): New tests. (Bug#73798) --- doc/misc/erc.texi | 376 +++++++++++++++++++++++++++ lisp/erc/erc-match.el | 428 +++++++++++++++++++++++++++++-- test/lisp/erc/erc-match-tests.el | 214 +++++++++++++++- 3 files changed, 990 insertions(+), 28 deletions(-) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index c47747a5b1f..03fa8337479 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -81,6 +81,7 @@ Top * 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 @@ -766,6 +767,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. @detailmenu @@ -2100,6 +2102,380 @@ display-buffer @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, options-oriented usage, please see +the doc strings for option @code{erc-pal-highlight-type} and friends in +the @code{erc-match} group. Unfortunately, those options often prove +insufficient for more granular filtering and highlighting needs, and +advanced users eventually outgrow them. However, under the hood, those +options all use the same foundational @code{erc-match} API, which +centers around a @code{cl-defstruct} @dfn{type} of the same name: + +@deftp {Struct} erc-match @ + predicate spkr-beg spkr-end body-beg sender nick command handler + + This is a @code{cl-struct} type that contains some handy facts about + the message being processed. That message's formatted body occupies + the narrowed buffer when ERC creates and provides access to each + @code{erc-match} instance. To use this interface, you add a + @dfn{constructor}-like function to the hook + @code{erc-match-functions}: + + @defopt erc-match-functions + + An abnormal hook for which each member accepts the parameters named + above as an @samp{&rest}-style plist and returns a new + @code{erc-match} instance. A function can also be a traditional + @code{cl-defstruct}-provided constructor belonging to a @dfn{subtype} + you've defined. + + @end defopt + + The only slot you definitely need to specify is @samp{predicate}. + Both it and @samp{handler} are functions that take a single argument: + the instance itself. As its name implies, @samp{predicate} must + return non-@code{nil} if @samp{handler}, whose return value ERC + ignores, should run. + + A few slots, like @samp{spkr-beg}, @samp{spkr-end}, and @samp{nick}, + may surprise you. The first two are @code{nil} for non-chat messages, + like those displayed for @samp{JOIN} events. The @samp{nick} slot can + likewise be @code{nil} if the sender of the message is a domain-style + host name, such as @samp{irc.example.org}, which it often is for + informational messages, like @samp{*** #chan was created on 2023-12-26 + 00:36:42}. + + To locate the start of the just-inserted message, use @samp{body-beg}, + a marker indicating the beginning of the message proper. Don't + forget: all inserted messages include a trailing newline. If you want + to extract just the message body's text, use the function + @code{erc-match-get-message-body}: + + @defun erc-match-get-message-body match + + Takes an @code{erc-match} instance and returns a string containing the + message body, sans trailing newline and any leading speaker or + decorative component, such as @code{erc-notice-prefix}. + + @end defun + +@end deftp + +@noindent +Although module authors may want to subclass this struct, everyday users +can just instantiate it directly (it's @dfn{concrete}). This is +especially handy for one-off tasks or simple customizations in your +@file{init.el}. To do this, define a function that invokes its +constructor: + +@lisp +(require 'erc-match) + +(defvar my-mentions 0) + +(defun my-match (&rest plist) + (apply #'erc-match + :predicate (lambda (_) (search-forward "my-project" nil t)) + :handler (lambda (_) (cl-incf my-mentions)) + plist)) + +(add-hook 'erc-match-functions #'my-match) +(setopt erc-prompt (lambda () (format "%d!" my-mentions))) +@end lisp + +@noindent +Here, the user could just as well shove the incrementer into the +@samp{predicate} body, since @samp{handler} is set to @code{ignore} by +default (however, some frown at the notion of a predicate exhibiting +side effects). The user could also choose to concentrate only on chat +content by filtering out non-@samp{PRIVMSG} messages via the slot +@samp{command}. + +In cases where you need a handler to only run when some other match type +appearing earlier in @code{erc-match-functions} has _not_ yielded a +match, use: + +@defun erc-match-get-match constructor + +When called from a @samp{handler} or a @samp{predicate} body, this +utility returns instances of prior @code{erc-match-functions} that have +already successfully matched the current message. Use this for +deduplication and to share data between match instances. + +@end defun + +@noindent +For a detailed example of matching for non-highlighting purposes, see +the @samp{jabbycat} demo module, available on ERC's dev-oriented package +archive: @uref{https://emacs-erc.gitlab.io/bugs/archive/jabbycat.html}. +If you're in a hurry, check out @file{erc-desktop-notifications.el}, +which ships with ERC, but please ignore the parts that involve adapting +the global setup (and teardown) business to a buffer-local context. +Since your module is declared @code{local}, as per the modern +convention, you won't be needing such code, so feel free to do things +like add local members to @code{erc-match-functions} in your module's +definition. + +@anchor{highlighting} +@subsection Highlighting +@cindex highlighting + +End users and third-party modules likely want to manage and apply faces +themselves. If that's you, feel free to skip to the more extensive +examples further below. However, for the sake of completeness, it's +worth mentioning that in a pinch, you can likely piggyback atop the +highlighting functionality already provided by @samp{match} to support +its many high-level options. + +@lisp +(require 'erc-match) + +(defvar my-keywords + `((foonet ("#chan" ,(rx bow (or "foo" "bar" "baz") eow))))) + +(defface my-face + '((t (:inherit font-lock-constant-face :weight bold))) + "My face.") + +(defun my-match (&rest plist) + (apply #'erc-match-opt-keyword + :data (and-let* ((chans (alist-get (erc-network) my-keywords)) + ((cdr (assoc (erc-target) chans))))) + :face 'my-face + plist)) + +(add-hook 'erc-match-functions #'my-match) +@end lisp + +@noindent +Here, the user leverages a handy subtype of @code{erc-match}, called +@code{erc-match-opt-keyword}, which actually descends directly from +another, intermediate @code{erc-match} type: + +@deftp {Struct} erc-match-traditional category face data part + +Use this type or one of its descendants (see below) if you want +@code{erc-text-matched-hook} to run alongside (after) the @samp{handler} +slot's default highlighter, @code{erc-match-highlight}, on every match +for which the @samp{category} slot's value is non-@code{nil} (it becomes +the argument provided for the hook's @var{match-type} parameter). + +Much more important, however, is @samp{part}. This slot determines what +portion of the message is being highlighted or otherwise operated on. +It can be any symbol, but the ones with predefined methods are +@code{nick}, @code{message}, @code{all}, @code{keyword}, +@code{nick-or-keyword}, and @code{nick-or-mention}. + +The complement to the @samp{part} slot is @samp{data}, which holds the +value of the module's option corresponding to the specific type. For +example, ERC initializes the @samp{data} slot for the +@code{erc-match-opt-pal} type with the value of @code{erc-pals}. + +The default handler, @code{erc-match-highlight}, does its work by +deferring to a purpose-built @dfn{method} meant to handle +@samp{part}-based highlighting: + +@defop {Method} erc-match-traditional erc-match-highlight-by-part @ + instance part + + You can override this method by @dfn{specializing} on any subclassed + @code{erc-match-traditional} type and/or non-reserved @var{part}, such + as one known only to your @file{init.el} or (informally) associated + with your package by its library @dfn{namespace}. + +@end defop + +@end deftp + +@noindent +You likely won't be needing these, but just for the record, other +options-based types similar to @code{erc-match-opt-keyword} include +@code{erc-match-opt-current-nick}, @code{erc-match-opt-fool}, +@code{erc-match-opt-pal}, and @code{erc-match-opt-dangerous-host}. (If +you're familiar with this module's user options, you'll notice some +parallels here.) + +@anchor{highlighting examples} +@subsubsection Complete Highlighting Examples +@cindex highlighting examples + +As mentioned, most users needn't bother with the piggybacking approach +detailed above, which can oftentimes be more complicated than starting +afresh. Here's a more elaborate, module-like example demoing some +highlighting with a bespoke @code{erc-match}-derived type: + +@lisp +;;; erc-org-markup.el --- Org Markup for ERC -*- lexical-binding: t; -*- + +(require 'erc-match) +(require 'org) + +(defgroup erc-org-markup nil + "Highlight messages written in Org markup." + :group 'erc) + +(defcustom erc-org-markup-targets '("#org") + "List of buffers in which to highlight messages." + :type '(repeat string)) + +(define-erc-module org-markup nil + "Local module that treats messages as having Org markup." + ((erc-org-markup-ensure-buffer) + (if (member (erc-target) erc-org-markup-targets) + (progn + (add-hook 'erc-match-functions #'erc-org-markup 0 t) + (add-to-invisibility-spec 'org-link)) + (erc-org-markup-mode -1))) + ((remove-hook 'erc-match-functions #'erc-org-markup t) + (remove-from-invisibility-spec 'org-link)) + localp) + +(cl-defstruct (erc-org-markup + (:include erc-match + (predicate #'erc-org-markup--should-p) + (handler #'erc-org-markup--fontify)) + (:constructor erc-org-markup)) + "Match type to highlight messages written in Org markup.") + +(defun erc-org-markup--should-p (match) + "Return non-nil if MATCH describes an Org-markup worthy message." + (and erc-org-markup-mode (erc-match-nick match))) + +(defun erc-org-markup-ensure-buffer () + "Return existing global work buffer or create it anew." + (or (get-buffer "*erc-org-markup*") + (with-current-buffer (get-buffer-create "*erc-org-markup*") + (org-mode) + (make-local-variable 'org-link-parameters) + (setf (plist-get (cdr (assoc "https" org-link-parameters)) + :activate-func) + #'erc-org-markup-activate-link) + (setq-local org-hide-emphasis-markers t) + (current-buffer)))) + +(defun erc-org-markup--fontify (match) + "Overwrite text properties in MATCH'd message with Org's." + (save-restriction + (narrow-to-region (erc-match-body-beg match) (1- (point-max))) + (let ((buffer (current-buffer))) + (with-current-buffer (erc-org-markup-ensure-buffer) + (save-window-excursion + (buffer-swap-text buffer) + (font-lock-ensure) + (buffer-swap-text buffer)))))) + +(defun erc-org-markup-activate-link (beg end path _) + "Ensure Org https link between BEG and END has `erc-button' props." + (erc-button-add-button beg end #'browse-url-button-open-url nil + (list (concat "https:" path)) "")) + +(provide 'erc-org-markup) + +;;; erc-org-markup.el ends here +@end lisp + +@noindent +Finally, here's a slightly more complete demo module: a superficial +rewrite of @file{erc-colorize.el} by Sylvain Rousseau +@uref{https://github.com/thisirs/erc-colorize.git}. + +@lisp +;;; erc-colorize.el --- Per-user message faces -*- lexical-binding: t; -*- + +(require 'ring) +(require 'erc-match) +(require 'erc-button) ; for `erc-button-add-face' + +(defgroup erc-colorize nil + "Highlight messages with per-user faces from a limited pool." + :group 'erc) + +(defface erc-colorize-1 '((t :inherit font-lock-keyword-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-2 '((t :inherit font-lock-type-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-3 '((t :inherit font-lock-string-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-4 '((t :inherit font-lock-constant-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-5 '((t :inherit font-lock-preprocessor-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-6 '((t :inherit font-lock-variable-name-face)) + "Auto-assigned face for distinguishing between messages.") + +(defface erc-colorize-7 '((t :inherit font-lock-warning-face)) + "Auto-assigned face for distinguishing between messages.") + +(defvar erc-colorize-faces '(erc-colorize-1 + erc-colorize-2 + erc-colorize-3 + erc-colorize-4 + erc-colorize-5 + erc-colorize-6 + erc-colorize-7) + "List of faces to apply to chat messages.") + +(defvar-local erc-colorize-ring nil + "Ring of cons cells of the form (NICK . FACE).") + +(define-erc-module colorize nil + "Highlight messages from a speaker with the same face in target buffers." + ((when (erc-target) + (add-hook 'erc-match-functions 'erc-colorize 0 t) + (setq erc-colorize-ring (make-ring (length erc-colorize-faces))))) + ((remove-hook 'erc-match-functions 'erc-colorize t)) + 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." + (cond + ((and-let* ((i (catch 'found + (dotimes (i (ring-length ring)) + (when (equal (car (ring-ref ring i)) nick) + (throw 'found i)))))) + (ring-insert ring (ring-remove ring i)) + (cdr (ring-ref ring 0)))) + ((let ((used (mapcar #'cdr (ring-elements ring)))) + (and-let* ((face (catch 'found + (dolist (face erc-colorize-faces) + (unless (member face used) + (throw 'found face)))))) + (prog1 face + (ring-insert ring (cons nick face)))))) + ((let ((older (ring-remove ring))) + (ring-insert ring (cons nick (cdr older))) + (cdr older))))) + +(cl-defstruct (erc-colorize ( :include erc-match + (predicate #'erc-colorize-nick) + (handler #'erc-colorize-message)) + (:constructor erc-colorize)) + "An `erc-match' type for the `erc-colorize' module.") + +(defun erc-colorize-message (match) + "Highlight MATCH's full message with a face from `erc-colorize-faces'." + (erc-button-add-face (point-min) (1- (point-max)) + (erc-colorize-color erc-colorize-ring + (erc-colorize-nick match)))) + +(provide 'erc-colorize) + +;;; erc-colorize.el ends here +@end lisp + + @node Options @section Options @cindex options diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index ffb5a2af91e..5c862b1b804 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -122,10 +122,15 @@ erc-pal-highlight-type `all' - highlight the entire message (including the nick) from pal + `nick-or-mention' - highlight a matching speaker or all matching + mentions as quasi keywords + A value of `nick' only highlights a matching sender's nick in the bracketed speaker portion of the message. A value of \\+`message' basically highlights its complement: the message-body alone, after the -speaker tag. All values for this option require a matching sender to be +speaker tag. A value of `nick-or-mention' works like `nick' but also +matches \"mentions,\" which `erc-fool-highlight-type' explains in its +doc string. All values for this option require a matching sender to be an actual user on the network \(or a bot/service) as opposed to a host name, such as that of the server itself \(e.g. \"irc.gnu.org\"). When patterns from other user-based categories \(namely, \\+`fool' and @@ -135,6 +140,7 @@ erc-pal-highlight-type \\+`fool'-related invisibility may not survive such collisions.)" :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -148,12 +154,12 @@ erc-fool-highlight-type <speaker> USER: hi. <speaker> USER, hi. -However, at present, this option doesn't offer a means of highlighting -matched mentions alone. See `erc-pal-highlight-type' for a summary of -possible values and additional details common to categories like -\\+`fool' that normally match against a message's sender." +See `erc-pal-highlight-type' for a summary of possible values and +additional details common to categories like \\+`fool' that normally +match against a message's sender." :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -182,6 +188,7 @@ erc-dangerous-host-highlight-type normally match against a message's sender." :type '(choice (const nil) (const nick) + (const nick-or-mention) (const message) (const all))) @@ -267,6 +274,22 @@ erc-match-quote-when-adding (const t) (const nil))) +(defcustom erc-match-functions '(erc-match-opt-pal + erc-match-opt-fool + erc-match-opt-dangerous-host + erc-match-opt-keyword + erc-match-opt-current-nick) + "Type constructors for \\+`match' processing. +See the struct `erc-match' as well as Info node `(erc) Match API' for +details." + :package-version '(ERC . "5.7") ; FIXME sync on release + :type '(hook :options (erc-match-opt-pal + erc-match-opt-fool + erc-match-opt-dangerous-host + erc-match-opt-keyword + erc-match-opt-current-nick))) + + ;; Internal variables: ;; This is exactly the same as erc-button-syntax-table. Should we @@ -322,6 +345,7 @@ erc-add-entry-to-list LIST must be passed as a symbol The query happens using PROMPT. Completion is performed on the optional alist COMPLETIONS." + (erc-match--opt-pat-cache-clear-all list) (let ((entry (completing-read prompt completions @@ -345,6 +369,7 @@ erc-remove-entry-from-list LIST must be passed as a symbol. The elements of LIST can be strings, or cons cells where the car is the string." + (erc-match--opt-pat-cache-clear-all list) (let* ((alist (mapcar (lambda (x) (if (listp x) x @@ -468,7 +493,360 @@ erc-match-directed-at-fool-p (or (erc-list-match fools-beg msg) (erc-list-match fools-end msg)))) +(cl-defstruct (erc-match (:constructor erc-match)) + "Base type for text and user matching performed by the \\+`match' module. +Users wishing to perform custom matching should add a constructor that +returns an instance of this type to the hook `erc-match-functions'. If +the `:predicate' slot's predicate returns non-nil after being called +with its own instance in the narrowed single-message buffer, ERC calls +the `:handler' slot's function with the same instance and with the match +data still intact. More details in Info node `(erc) Match API'." + ( predicate (error "Keyword `:predicate' missing") :type function + :documentation "Called in narrowed buffer with own instance.") + ( spkr-beg nil :type (or null natnum) + :documentation "Position of the beginning of speaker's nick, if known.") + ( spkr-end nil :type (or null natnum) + :documentation "Position of the end of speaker's nick, if known.") + ( body-beg (error "Keyword `:body-beg' missing") :type marker + :documentation "Marker residing at the beginning of the message body.") + ( sender (error "Keyword `:sender' missing") :type string + :documentation "The sender's n!u@h.") + ( nick nil :type (or null string) + :documentation "The sender's nick if they're a user and not the server.") + ( command (error "Keyword `:command' missing") :type (or symbol natnum) + :documentation "Protocol command or numeric, like `PRIVMSG' or 353.") + ( handler #'ignore :type function + :documentation "Called on `:predicate' match with own instance.")) + +(cl-defstruct (erc-match-traditional + (:constructor erc-match-traditional) + (:include erc-match (handler #'erc-match-highlight))) + "Match type for user-option based on \"categories\" and \"parts\". +The `:category' slot exists for the benefit of `erc-text-matched-hook', +which receives its value as a second parameter (the hook only runs when +the slot is non-nil)." + ( category (error "Keyword `:category' missing") :type symbol + :documentation "Traditional \\+`match' \"category\", like `pal'.") + ( face 'erc-default-face :type face + :documentation "Face to highlight the matched portion with.") + ( part nil :type symbol + :documentation "Symbol for the portion of the message to highlight.") + ( data nil :type list + :documentation "User-specified patterns or other type-specific data.")) + +(cl-defstruct (erc-match-opt-current-nick + (:include erc-match-traditional + (category 'current-nick) + (predicate #'erc-match--current-nick-p) + (part erc-current-nick-highlight-type) + (face 'erc-current-nick-face) + (data (list (concat "\\b" + (regexp-quote (erc-current-nick)) + "\\b")))) + (:constructor erc-match-opt-current-nick)) + "An options-based type for the `current-nick' category.") + +(cl-defstruct (erc-match-opt-keyword + (:include erc-match-traditional + (category 'keyword) + (predicate #'erc-match--keyword-p) + (part erc-keyword-highlight-type) + (face 'erc-keyword-face) + (data erc-keywords)) + (:constructor erc-match-opt-keyword)) + "An options-based type for the `keyword' category.") + +(cl-defstruct (erc-match-user (:include erc-match-traditional) + (:constructor erc-match-user)) + "An `erc-match' that's only processed when `:nick' is non-nil.") + +(cl-defstruct (erc-match-opt-fool + (:include erc-match-user + (category 'fool) + (predicate #'erc-match--user-nuh-or-mention-p) + (part erc-fool-highlight-type) + (face 'erc-fool-face) + (data erc-fools)) + (:constructor erc-match-opt-fool)) + "An options-based type for the `fool' category.") + +(cl-defstruct (erc-match-opt-pal + (:include erc-match-user + (category 'pal) + (predicate #'erc-match--user-nuh-or-mention-p) + (part erc-pal-highlight-type) + (face 'erc-pal-face) + (data erc-pals)) + (:constructor erc-match-opt-pal)) + "An options-based type for the `pal' category.") + +(cl-defstruct (erc-match-opt-dangerous-host + (:include erc-match-user + (category 'dangerous-host) + (predicate #'erc-match--user-nuh-or-mention-p) + (part erc-dangerous-host-highlight-type) + (face 'erc-dangerous-host-face) + (data erc-dangerous-hosts)) + (:constructor erc-match-opt-dangerous-host)) + "An options-based type for the `dangerous-host' category.") + +(defvar erc-match--opt-pat-cache nil + "Hash table of computed `regexp-opt' patterns from match-list options. +Keys are cons cells of (CATEGORY . COMPUTE-FN). Values are +`erc-match--opt-pat' objects. The table also contains an auxiliary item +whose key is CATEGORY and whose value is a list of (COMPUTE-FN-1 +COMPUTE-FN-2 ... COMPUTE-FN-N). ERC uses this when clearing the cache +for CATEGORY.") + +(defvar erc-match--opt-pat-ttl 300.0 + "Seconds to retain cached `regexp-opt' patterns between hits.") + +(cl-defstruct erc-match--opt-pat ts in out) + +(defun erc-match--opt-pat-cache-clear (base-key) + "Remove items for BASE-KEY from `erc-match--opt-pat-cache'." + (when-let* ((table erc-match--opt-pat-cache) + (keys (gethash base-key table))) + (remhash base-key table) + (dolist (key keys) + (remhash (cons base-key key) table)))) + +;; FIXME have :set functions of user options also break cache. +(defun erc-match--opt-pat-cache-clear-all (list-option) + "Remove items for LIST-OPTION from `erc-match--opt-pat-cache'." + (let ((base-key (pcase-exhaustive list-option + ('erc-fools 'fool) + ('erc-pals 'pal) + ('erc-keywords 'keyword) + ('erc-dangerous-hosts 'dangerous-host)))) + (erc-match--opt-pat-cache-clear base-key))) + +(defun erc-match--opt-pat-get (base-key compute-fn input) + "Retrieve cached results for computing INPUT with COMPUTE-FN. +Use BASE-KEY for `erc-match--opt-pat-cache' transactions." + (unless erc-match--opt-pat-cache + (setq erc-match--opt-pat-cache + (make-hash-table :test #'equal))) + (if-let* ((key (cons base-key compute-fn)) + (entry (gethash key erc-match--opt-pat-cache)) + (ct (erc-current-time)) + ((> ct (+ (erc-match--opt-pat-ts entry) + erc-match--opt-pat-ttl))) + ((equal (erc-match--opt-pat-in entry) input))) + (progn + (setf (erc-match--opt-pat-ts entry) ct) + (erc-match--opt-pat-out entry)) + (let ((output (funcall compute-fn input))) + (prog1 output + (cl-pushnew compute-fn (gethash base-key erc-match--opt-pat-cache)) + (puthash key + (make-erc-match--opt-pat :ts (or ct (erc-current-time)) + :in input + :out output) + erc-match--opt-pat-cache))))) + +(defun erc-match--opt-pat-make (patterns) + (string-join patterns "\\|")) + +(defun erc-match--opt-pat-kw-make (patterns) + (mapconcat (lambda (w) (or (car-safe w) w)) patterns "\\|")) + +(defun erc-match--opt-pat-addr-beg-make (patterns) + (concat "\\<\\(" (erc-match--opt-pat-make patterns) "\\)[:,] ")) + +(defun erc-match--opt-pat-addr-end-make (patterns) + (concat "\\s. \\(" (erc-match--opt-pat-make patterns) "\\)\\s.")) + +(defun erc-match--current-nick-p (instance) + (re-search-forward (car (erc-match-traditional-data instance)) nil t)) + +(defun erc-match--keyword-p (instance) + (and-let* ((patterns (erc-match-traditional-data instance)) + (regexp (erc-match--opt-pat-get + (erc-match-traditional-category instance) + #'erc-match--opt-pat-kw-make patterns))) + (goto-char (erc-match-body-beg instance)) + (re-search-forward regexp nil t))) + +(defun erc-match--user-nuh-or-mention-p (instance) + "Return non-nil on NUH match for `erc-match' INSTANCE. +Also do so on mentions if the category is `fool' or the corresponding +\"part\" option is `nick-or-mention'." + (and-let* ((patterns (erc-match-traditional-data instance)) + (category (erc-match-traditional-category instance))) + (or (string-match (erc-match--opt-pat-get + category #'erc-match--opt-pat-make patterns) + (erc-match-sender instance)) + (and (or (eq category 'fool) + (eq (erc-match-traditional-part instance) 'nick-or-mention)) + ;; Mimic `erc-match-directed-at-fool-p', but search + ;; the narrowed buffer instead of a string argument. + (goto-char (erc-match-body-beg instance)) + (or (looking-at (erc-match--opt-pat-get + category #'erc-match--opt-pat-addr-beg-make + patterns)) + (search-forward-regexp + (erc-match--opt-pat-get + category #'erc-match--opt-pat-addr-end-make patterns) + nil t)))))) + +(cl-defgeneric erc-match-highlight-by-part (instance part) + "Highlight PART of narrowed buffer for `erc-match' INSTANCE.") + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql nick))) + "Highlight nick in the bracketed speaker portion of the message." + (when (erc-match-spkr-beg instance) + (erc-put-text-property (erc-match-spkr-beg instance) + (erc-match-spkr-end instance) + 'font-lock-face + (erc-match-traditional-face instance)))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql message))) + "Highlight the message body, not including the leading speaker tag." + (erc-put-text-property (erc-match-body-beg instance) (point-max) + 'font-lock-face + (erc-match-traditional-face instance))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql all))) + "Highlight the whole message, including the speaker tag." + (erc-put-text-property (point-min) (point-max) + 'font-lock-face + (erc-match-traditional-face instance))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql keyword))) + "Highlight all occurrences of all keyword patterns." + (dolist (pat (erc-match-traditional-data instance)) + (let ((regex (if (consp pat) (car pat) pat)) + (face (if (consp pat) + (cdr pat) + (erc-match-traditional-face instance)))) + (goto-char (erc-match-body-beg instance)) + (while (re-search-forward regex nil t) + (erc-put-text-property (match-beginning 0) (match-end 0) + 'font-lock-face face))))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql nick-or-keyword))) + "Highlight speaker-tag nick of matching users, otherwise all mentions." + (if (erc-match-spkr-end instance) + (erc-put-text-property (erc-match-spkr-beg instance) + (erc-match-spkr-end instance) + 'font-lock-face + (erc-match-traditional-face instance)) + (erc-match-highlight-by-part instance 'keyword))) + +(cl-defmethod erc-match-highlight-by-part ((instance erc-match-traditional) + (_ (eql nick-or-mention))) + "Highlight speaker-tag nick of matching users or all mentions." + (let ((body-beg (erc-match-body-beg instance))) + (setf (erc-match-body-beg instance) + (or (erc-match-spkr-beg instance) (point-min))) + (erc-match-highlight-by-part instance 'keyword) + (setf (erc-match-body-beg instance) body-beg))) + +(defvar erc-match-highlight-matched nil + "Matched `erc-match' instance in `erc-text-matched-hook'.") + +(defvar erc-match--instances nil + "Alist mapping constructors to successful `erc-match' instances.") + +(defun erc-match-highlight (instance) + "Dispatch `erc-match-highlight-by-part' on INSTANCE's `:part' slot. +Run `erc-text-matched-hook' when INSTANCE's `category' slot is non-nil." + (unless (erc-match-traditional-p instance) + (signal 'wrong-type-argument (list 'erc-match-traditional instance))) + (erc-match-highlight-by-part instance (erc-match-traditional-part instance)) + (when (erc-match-traditional-category instance) + (let ((user-nuh (and (erc-match-nick instance) + (erc-match-sender instance))) + (erc-match-highlight-matched instance)) + (run-hook-with-args 'erc-text-matched-hook + (erc-match-traditional-category instance) + (or user-nuh (format "Server:%s" + (erc-match-command instance))) + ;; For compatibility, include a leading "*** ". + (buffer-substring (if user-nuh + (erc-match-body-beg instance) + (point-min)) + (point-max)))))) + +(defun erc-match-get-message-body (instance) + "Return the message body in the narrowed buffer for match INSTANCE." + (buffer-substring (erc-match-body-beg instance) (1- (point-max)))) + +(defun erc-match-get-match (constructor) + "Return successful `erc-match' instance for CONSTRUCTOR, if any. +Expect to be called only from `erc-match' :predicate and :handler +functions as well as `erc-text-matched-hook' members." + (alist-get constructor erc-match--instances)) + +(defun erc-match--run-match (constructor spkr-beg spkr-end body-beg + nick sender command) + "Run :handler for for `erc-match' instance if :predicate returns non-nil. +Call CONSTRUCTOR with SPKR-BEG, SPKR-END, BODY-BEG, NICK SENDER, and +COMMAND to create said instance." + (when-let* ((instance (funcall constructor + :spkr-beg spkr-beg + :spkr-end spkr-end + :body-beg body-beg + :nick nick + :sender sender + :command command)) + ((or nick (not (erc-match-user-p instance)))) + ((goto-char (point-min))) + ((funcall (erc-match-predicate instance) instance))) + (funcall (erc-match-handler instance) instance) + (push (cons constructor instance) erc-match--instances) + nil)) + +(defun erc-match--message () + "Highlight matches in narrowed buffer's current message." + (goto-char (point-min)) + (let* ((response erc--parsed-response) + (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)))) + (spkr-end (erc--get-speaker-bounds)) + (spkr-beg (and spkr-end (pop spkr-end))) + (body-beg (copy-marker + (cond (erc--offset-marker + (marker-position erc--offset-marker)) + (spkr-end + (save-excursion (goto-char spkr-end) + (skip-syntax-forward "^-") + (skip-syntax-forward "-") + (point))) + ((point-min))))) + (command (erc--check-msg-prop 'erc--cmd)) + (erc-match--instances ())) + (with-syntax-table erc-match-syntax-table + (run-hook-wrapped 'erc-match-functions #'erc-match--run-match + spkr-beg spkr-end body-beg nick + (erc-response.sender response) command)) + (when (and erc--offset-marker (/= body-beg erc--offset-marker)) + (setq erc--offset-marker body-beg)))) + +(defvar erc-match-use-legacy-logic-p nil + "When non-nil, use the non-`erc-match' variant of `erc-match-message'.") +(make-obsolete 'erc-match-use-legacy-logic-p + "non-nil behavior is missing features and integrations" "31.1") + (defun erc-match-message () + "Highlight matched portions of the narrowed buffer." + (if (or erc-match-use-legacy-logic-p (null erc--parsed-response)) + (erc-match--message-legacy) + (unless (or (and erc-match-exclude-server-buffer (erc--server-buffer-p)) + (null (erc--check-msg-prop 'erc--cmd)) + (erc--check-msg-prop 'erc--echo) + (erc--memq-msg-prop 'erc--skip 'match)) + (erc-match--message)))) + +(defun erc-match--message-legacy () "Mark certain keywords in a region. Use this defun with `erc-insert-modify-hook'." ;; This needs some refactoring. @@ -591,27 +969,25 @@ erc-log-matches Specify the match types which should be logged in the former, and deactivate/activate match logging in the latter. See `erc-log-match-format'." - (let ((match-buffer-name (cdr (assq match-type - erc-log-matches-types-alist))) - (nick (nth 0 (erc-parse-user nickuserhost)))) - (when (and - (or (eq erc-log-matches-flag t) - (and (eq erc-log-matches-flag 'away) - (erc-away-time))) - match-buffer-name) - (let ((line (format-spec - erc-log-match-format - `((?n . ,nick) - (?t . ,(format-time-string - (or (bound-and-true-p erc-timestamp-format) - "[%Y-%m-%d %H:%M] "))) - (?c . ,(or (erc-default-target) "")) - (?m . ,message) - (?u . ,nickuserhost))))) - (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) - (let ((inhibit-read-only t)) - (goto-char (point-max)) - (insert line))))))) + (when-let* + ((erc-log-matches-flag) + ((or (eq erc-log-matches-flag t) (erc-away-time))) + (match-buffer-name (cdr (assq match-type erc-log-matches-types-alist))) + (line (format-spec + erc-log-match-format + (erc-compat--defer-format-spec-in-buffer + (?n . (or (erc--check-msg-prop 'erc--spkr) + (erc-extract-nick nickuserhost))) + (?t . (format-time-string + (or (bound-and-true-p erc-timestamp-format) + "[%Y-%m-%d %H:%M] "))) + (?c erc-default-target) + (?m . message) + (?u . nickuserhost))))) + (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) + (with-silent-modifications + (goto-char (point-max)) + (insert line))))) (defun erc-log-matches-make-buffer (name) "Create or get a log-matches buffer named NAME and return it." diff --git a/test/lisp/erc/erc-match-tests.el b/test/lisp/erc/erc-match-tests.el index 7c960fc7f0a..7f811d24fa4 100644 --- a/test/lisp/erc/erc-match-tests.el +++ b/test/lisp/erc/erc-match-tests.el @@ -244,8 +244,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))) @@ -339,6 +340,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)) @@ -404,6 +476,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)) @@ -469,6 +565,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)) @@ -513,6 +633,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)) @@ -569,6 +694,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@@]") @@ -591,5 +721,85 @@ erc-match-tests--log-matches (ert-deftest erc-log-matches () (erc-match-tests--log-matches)) +(ert-deftest erc-log-matches/legacy () + (with-suppressed-warnings ((erc-match-use-legacy-logic-p obsolete)) + (let ((erc-match-use-legacy-logic-p t)) + (erc-match-tests--log-matches)))) + +;; This demos bare-bones usage of the `erc-match' API that implicitly +;; opts out of the traditional options and "parts"-based mechanism. The +;; user does not have to provide a `:part' keyword because they've +;; overridden the `:handler', meaning `erc-match-highlight-by-part' +;; never runs. This is somewhat analogous but ultimately orthogonal to +;; `erc-text-matched-hook' not running because that happens on account +;; of the user not specifying a `:category' field. +(ert-deftest erc-match-functions/api/non-parts-based () + (let* ((results ()) + (erc-text-matched-hook (lambda (&rest r) (push r results))) + (erc-match-functions + (list + (lambda (&rest plist) + ;; Doing everything in `:pred' would also work if + ;; specifying `ignore' for `:handler'. And you wouldn't + ;; even need to return non-nil on matches. + (apply #'erc-match + :predicate (lambda (_) (search-forward "alice" nil t)) + :handler (lambda (_) (push (match-string 0) results)) + plist))))) + + (erc-match-tests--perform + (lambda () + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "Alice") + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :bob tester Alice") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-privmsg "bob" "hi ALICE") + (goto-char (point-min)) + + (should (equal results '("ALICE" "Alice"))))))) + +;; This one piggybacks on infrastructure supporting the traditional +;; `match' interface. +(ert-deftest erc-match-functions/api/parts-based () + (let* ((results ()) + (erc-text-matched-hook (lambda (&rest r) (push r results))) + (erc-match-functions ())) + + (erc-match-tests--perform + (lambda () + + ;; Use local setter for no particular reason. + (add-hook 'erc-match-functions + (lambda (&rest plist) + (apply #'erc-match-traditional + :category 'keyword + :part 'keyword + :data '("alice") + :face 'error + :predicate (lambda (_) + (search-forward "alice" nil t)) + plist)) + 0 t) + + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "Alice") + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :Alice bob tester") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-privmsg "bob" "hi ALICE") + (goto-char (point-min)) + + (search-forward "*** Users on #chan:") + (erc-match-tests--assert-face-absent 'error "Alice") + (erc-match-tests--assert-face-present 'error " bob") + (erc-match-tests--assert-face-absent 'error (pos-eol)) + + (should (equal results + '(( keyword "[email protected]" "hi ALICE\n") + ( keyword "Server:353" + "*** Users on #chan: Alice bob tester\n")))))))) ;;; erc-match-tests.el ends here -- 2.48.1 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0003-5.7-Use-erc-match-type-API-for-erc-desktop-notificat.patch From 641b7a11d23821ad5ab20c252544fa7eff4dc84d Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Sat, 12 Oct 2024 17:44:30 -0700 Subject: [PATCH 3/3] [5.7] Use erc-match-type API for erc-desktop-notifications * etc/ERC-NEWS: New section for 5.7 and new entries for the `erc-match-type' API and options `erc-notifications-focused-context' and `erc-desktop-notifications-skip-predicates'. * lisp/erc/erc-desktop-notifications.el (erc-notifications-focused-contexts): New option. (erc-desktop-notifications-skip-predicates): 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-desktop-notifications-skip-untracked) (erc-desktop-notifications-skip-fools): New functions (erc-notifications-notify-on-match): Account for new options. (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. (Bug#73798) --- etc/ERC-NEWS | 27 ++++ lisp/erc/erc-desktop-notifications.el | 87 ++++++++++- .../erc/erc-desktop-notifications-tests.el | 139 ++++++++++++++++++ 3 files changed, 245 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 dd960994b4f..fd12cb8843b 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -11,6 +11,33 @@ This file is about changes in ERC, the powerful, modular, and extensible IRC (Internet Relay Chat) client distributed with GNU Emacs since Emacs version 22.1. + +* Changes in ERC 5.7 + +** An extensibility focused 'match' API. +Users have often expressed frustration over ERC's lack of a simple API +for matching, highlighting, and filtering based on a message's content +and metadata, like the sender or associated IRC command. While it's +true that discussions have been ongoing for a more powerful message +formatting and construction API that will hopefully one day offer access +to the various parts of a message before they're assembled, users will +be needing something practical and effective in the interim. Enter the +'erc-match-type' API, which is based on a simple hook-like handler +system. You subscribe by enrolling a function that takes a special +'erc-match-type' object with useful fields to help with matching, +filtering, and applying faces. See Info node 'Match API' to find out +more. + +** Exercise more control in skipping certain desktop notifications. +Elect to skip select notifications that ERC would otherwise emit with +new hook option 'erc-desktop-notifications-skip-predicates'. Its +default members skip messages by fools and those in untracked buffers. + +** Opt out of desktop notifications from the active buffer. +Option 'erc-notifications-focused-contexts' can help spare you from +seeing desktop alerts for messages you're reading or those inserted +while you're typing. + * Changes in ERC 5.6.1 diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index a8bde92686c..36e57a7dd15 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -47,6 +47,19 @@ 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-desktop-notifications-skip-predicates + '(erc-desktop-notifications-skip-untracked + erc-desktop-notifications-skip-fools) + "Abnormal hook whose members return non-nil to suppress notification. +Called in match buffer with a matching `erc-match-user' object." + :package-version '(ERC . "5.7") ; FIXME sync on release + :type 'hook) + (defcustom erc-notifications-bus :session "D-Bus bus to use for notification." :version "25.1" @@ -60,12 +73,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 +98,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))) @@ -93,24 +110,78 @@ erc-notifications-PRIVMSG ;; Return nil to continue processing by ERC nil) +(defun erc-desktop-notifications-skip-untracked (_) + "Return non-nil when current buffer's target appears in `erc-track-exclude'." + (and (boundp 'erc-track-exclude) (member (erc-target) erc-track-exclude))) + +(defun erc-desktop-notifications-skip-fools (_) + "Return non-nil if the current message has a \"match type\" of `fool'." + (erc-match-get-match 'erc-match-opt-fool)) + (defun erc-notifications-notify-on-match (match-type nickuserhost msg) (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))) + (run-hook-with-args-until-success + 'erc-desktop-notifications-skip-predicates + erc-match-highlight-matched)) (erc-notifications-notify nick msg))))) ;;;###autoload(autoload 'erc-notifications-mode "erc-desktop-notifications" "" t) (define-erc-module notifications nil "Send notifications on private message reception and mentions." ;; Enable - ((add-hook 'erc-server-PRIVMSG-functions #'erc-notifications-PRIVMSG) + ((unless erc--updating-modules-p + (erc-buffer-do #'erc-desktop-notifications--setup)) + (add-hook 'erc-mode-hook #'erc-desktop-notifications--setup) (add-hook 'erc-text-matched-hook #'erc-notifications-notify-on-match)) ;; Disable - ((remove-hook 'erc-server-PRIVMSG-functions #'erc-notifications-PRIVMSG) + ((erc-buffer-do #'erc-desktop-notifications--setup) (remove-hook 'erc-text-matched-hook #'erc-notifications-notify-on-match))) +(defun erc-desktop-notifications--setup () + (if erc-notifications-mode + (add-hook 'erc-match-functions + ;; Run after default value to detect fools. + #'erc-desktop-notifications--match-type-query 20 t) + (remove-hook 'erc-match-functions + #'erc-desktop-notifications--match-type-query t))) + +(defvar erc-desktop-notifications-match-query-commands '(PRIVMSG) + "IRC commands considered in query buffers for notification. +Omits \"NOTICE\"s by default because they're typically reserved for bots +and services that you interact with directly.") + +(cl-defstruct (erc-desktop-notifications--match-type-query + (:constructor erc-desktop-notifications--match-type-query) + (:include erc-match-user + (category nil) + (data erc-desktop-notifications-match-query-commands) + (predicate #'erc-desktop-notifications--query-p) + (handler #'erc-desktop-notifications--query-notify))) + "Notification match type for queries.") + +(defun erc-desktop-notifications--query-p (match) + "Return non-nil if MATCH object describes a \"PRIVMSG\" query." + (and (erc-query-buffer-p) + (or (memq 'query erc-notifications-focused-contexts) + (null (frame-focus-state)) + (not (eq (current-buffer) (window-buffer)))) + (memq (erc-match-command match) (erc-match-user-data match)) + (always (cl-assert (erc-match-nick match))) + (not (run-hook-with-args-until-success + 'erc-desktop-notifications-skip-predicates match)))) + +(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..00cf8ed45da --- /dev/null +++ b/test/lisp/erc/erc-desktop-notifications-tests.el @@ -0,0 +1,139 @@ +;;; erc-desktop-notifications-tests.el --- Notifications tests -*- lexical-binding:t -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;;; Code: +(require 'erc-desktop-notifications) + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) + +(defun erc-desktop-notifications-tests--perform (test) + (erc-tests-common-make-server-buf) + (erc-notifications-mode +1) + (setq erc-server-current-nick "tester") + + (cl-letf* ((calls nil) + ((frame-parameter nil 'last-focus-update) + t) + ((symbol-function 'erc-notifications-notify) + (lambda (&rest r) (push r calls)))) + (with-current-buffer (erc--open-target "#chan") + (funcall test (lambda () (prog1 calls (setq calls nil)))))) + + (when noninteractive + (erc-notifications-mode -1) + (erc-tests-common-kill-buffers))) + +(defun erc-desktop-notifications-tests--populate-chan (test) + (erc-desktop-notifications-tests--perform + (lambda (check) + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "alice") + + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :alice bob tester") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-privmsg "bob" "hi tester") + + (should (equal (current-buffer) (get-buffer "#chan"))) + (should (not (eq (current-buffer) (window-buffer)))) ; *ert* or *scratch* + (funcall test check)))) + +(ert-deftest erc-notifications-focused-contexts/default () + (should (equal erc-notifications-focused-contexts '(query mention))) + + (erc-desktop-notifications-tests--populate-chan + (lambda (check) + + ;; A private query triggers a notification. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester yo") + (should (eq (current-buffer) (get-buffer "bob"))) + + ;; A NOTICE command doesn't trigger a notification because it's + ;; absent from `erc-desktop-notifications-match-query-commands'. + (erc-tests-common-simulate-line ":irc.foonet.org NOTICE tester nope") + + (should (equal (funcall check) + '(("bob" "yo") + ("bob" "hi tester\n")))) + + ;; Setting the window to the buffer where insertions are happening + ;; makes no difference: notifications are still sent. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester ho") + + (set-window-buffer nil (set-buffer "#chan")) + (erc-tests-common-simulate-privmsg "alice" "hi tester") + + (should (equal (funcall check) + '(("alice" "hi tester\n") + ("bob" "ho"))))))) + +(ert-deftest erc-notifications-focused-contexts/unselected () + (should (equal erc-notifications-focused-contexts '(query mention))) + + (let ((erc-notifications-focused-contexts)) + + (erc-desktop-notifications-tests--populate-chan + (lambda (check) + (should (equal (funcall check) '(("bob" "hi tester\n")))) + + ;; Buffer #chan is current and displayed in the selected window, + ;; so no notification is sent. + (set-window-buffer nil "#chan") ; #chan + (erc-tests-common-simulate-privmsg "alice" "hi tester") + + ;; A new query comes in for a buffer that doesn't exist. The + ;; option `erc-receive-query-display' tells ERC to switch to that + ;; buffer and show it before insertion. Therefore, no + ;; notification is sent. + (let ((erc-receive-query-display 'buffer)) + (erc-tests-common-simulate-line + ":[email protected] PRIVMSG tester yo")) + + (should-not (funcall check)))))) + +(ert-deftest erc-desktop-notifications-skip-predicates/fools () + (erc-desktop-notifications-tests--populate-chan + (lambda (check) + + ;; A private query triggers a notification. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester yo") + (should (eq (current-buffer) (get-buffer "bob"))) + + (should (equal (funcall check) + '(("bob" "yo") + ("bob" "hi tester\n")))) + + (let ((erc-fools '("bob"))) + + ;; A query from is suppressed if bob is a fool. + (erc-tests-common-simulate-line ":[email protected] PRIVMSG tester ho") + (should-not (funcall check)) + + ;; A mention from bob is suppressed if bob is a fool. + (with-current-buffer "#chan" + (erc-tests-common-simulate-privmsg "bob" "hi tester") + (erc-tests-common-simulate-privmsg "alice" "hi tester") + (should (equal (funcall check) '(("alice" "hi tester\n"))))))))) + +;;; erc-desktop-notifications-tests.el ends here -- 2.48.1 --=-=-=--