From 5cf741aa1d2e606079cb7ecf1c7b6f65a451fe68 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 USER: hi. 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 " 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 " 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 " 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