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