From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: "J.P." Newsgroups: gmane.emacs.bugs Subject: bug#73798: 31.0.50; ERC 5.7: New extensibility focused match API Date: Fri, 01 Nov 2024 06:39:07 -0700 Message-ID: <87h68rrs3o.fsf__9524.09048784233$1730468446$gmane$org@neverwas.me> References: <87y12rifv2.fsf@neverwas.me> <87ldy3v87y.fsf@neverwas.me> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="38933"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: emacs-erc@gnu.org To: 73798@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Fri Nov 01 14:40:37 2024 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1t6rtE-0009rO-Eq for geb-bug-gnu-emacs@m.gmane-mx.org; Fri, 01 Nov 2024 14:40:36 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1t6rso-00039t-7s; Fri, 01 Nov 2024 09:40:10 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1t6rsh-00033q-CR for bug-gnu-emacs@gnu.org; Fri, 01 Nov 2024 09:40:03 -0400 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1t6rsh-0000xo-1u for bug-gnu-emacs@gnu.org; Fri, 01 Nov 2024 09:40:03 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:References:In-Reply-To:From:To:Subject; bh=S9vunvv3KUp6/O2ZE+UcpsY+/KM526RKiNfJ4o6jdWQ=; b=kfWbcqTzuIsP/mTLh3tanRsjTHLDu4AddsZYMAHrvaWd4wFisFRmXJaBiecuKdHi6ZnkrvUbMi7yA3oOKbzl1L9ic/Lm6y31n8a8hddCNhh/uwSdqSRNA/XG55q7OHAMR6FwuZEeYpEWpgOqnv84qSxkyHuw/V14k3dQBEZnbEGuU+ermLQJI9IgkZC5IalCbrYllHc3t42RrLQwPZDz91k0T2RgEHrddSAGDxJj030+XxF7U6xD8JRQwVvSrMbt5W4XaBL9/AX2Zcg5SYiaX60BgcGfyCR0zGg5o/YN3dhCA/UCVth+F5YBvOZQSN6Mp97iGk0CAz/ZrDz13J3xNA==; Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1t6rsg-0001NV-Mi for bug-gnu-emacs@gnu.org; Fri, 01 Nov 2024 09:40:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: "J.P." Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Fri, 01 Nov 2024 13:40:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 73798 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 73798-submit@debbugs.gnu.org id=B73798.17304683635272 (code B ref 73798); Fri, 01 Nov 2024 13:40:02 +0000 Original-Received: (at 73798) by debbugs.gnu.org; 1 Nov 2024 13:39:23 +0000 Original-Received: from localhost ([127.0.0.1]:49577 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t6rrz-0001My-7f for submit@debbugs.gnu.org; Fri, 01 Nov 2024 09:39:23 -0400 Original-Received: from mail-108-mta82.mxroute.com ([136.175.108.82]:40335) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t6rrs-0001Mq-5c for 73798@debbugs.gnu.org; Fri, 01 Nov 2024 09:39:17 -0400 Original-Received: from filter006.mxroute.com ([136.175.111.3] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta82.mxroute.com (ZoneMTA) with ESMTPSA id 192e7f38c5d0003e01.001 for <73798@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Fri, 01 Nov 2024 13:39:11 +0000 X-Zone-Loop: b4d467c4e2703e544e0bfb5aef25a23a172399e1555c X-Originating-IP: [136.175.111.3] DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=neverwas.me ; s=x; h=Content-Type:MIME-Version:Message-ID:Date:References:In-Reply-To: Subject:Cc:To:From:Sender:Reply-To:Content-Transfer-Encoding:Content-ID: Content-Description:Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc :Resent-Message-ID:List-Id:List-Help:List-Unsubscribe:List-Subscribe: List-Post:List-Owner:List-Archive; bh=S9vunvv3KUp6/O2ZE+UcpsY+/KM526RKiNfJ4o6jdWQ=; b=mFFxOqBhEYgV8NEe4t0EY169hd Kasil4jwR8ZTjJHSkc+hZG1MLTcvix3GlEHXUAb6bYFYsCpP/KzX5FFLoXDoaijm3GzT1ImSTX/hK 1w+3k551dQD+Migj0c6VGd9iyCsmslvbadQjexF9lqDaT6JBLnPCczCrkO7oF5C2RgwQoxLui9wiP VHvwvrkGkWrESlg8mYmjYmoiS7z2bcPC7iykInYQLJkuVVO4USj+mzbQavO6yLaziuM0f7rz7HXQv GOwcMF0NUm0h8FBlE7ZW06dyYzFKZZCaLmw+UftX1mjj9CgomrbsI5V7CC+5K8vJprJ6CB87PksTY /81w3sYw==; In-Reply-To: <87ldy3v87y.fsf@neverwas.me> (J. P.'s message of "Thu, 31 Oct 2024 22:22:41 -0700") X-Authenticated-Id: masked@neverwas.me X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:294681 Archived-At: --=-=-= Content-Type: text/plain v3. Replace `erc-match-types' with `erc-match-functions', an actual (abnormal) hook. Update docs as mentioned in previous post. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0000-v2-v3.diff >From af5dd1ceb407c445bfa6f27ec737f989329bbdc4 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.7-Use-speaker-end-marker-in-ERC-insertion-hooks.patch >From 59393bd9be6cb30ee78dbead7f39ba5042bf917c Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-5.7-Introduce-lower-level-erc-match-API.patch >From 1c4d1feb3b48c04b145a03f40f8754da13030d4e 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-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 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,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 " 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,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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0003-5.7-Use-erc-match-type-API-for-erc-desktop-notificat.patch >From af5dd1ceb407c445bfa6f27ec737f989329bbdc4 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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. + +* 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. + * 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 . + +;;; 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 --=-=-=--