Add text props for CTCP messages and speakers in ERC

* etc/ERC-NEWS: Mention reduction in boldness of `erc-notice-face' and
`erc-action-face'.
* lisp/erc/erc-fill.el (erc-fill-spaced-commands,
erc-fill--spaced-commands): Rename former to latter and demote from
user option to internal variable.
(erc-fill): Change `erc-fill-spaced-commands' to
`erc-fill--spaced-commands'.
(erc-fill--wrap-continued-message-p): Use more precise `erc-ctcp' text
prop instead of face-based heuristic to detect CTCP ACTION message.
(erc-fill--wrap-action-dedent-p): New variable to toggle whether
`line-prefix' is applied to CTCP ACTION messages.  This exists less
to accommodate user preferences and more for third-party code that
assumes the first non-whitespace span in every message is a nick.
(erc-fill-wrap): Look for `erc-speaker' property before falling back
on word at point.  Use `erc-ctcp' to detect CTCP ACTION messages.
* lisp/erc/erc.el (erc-notice-face, erc-action-face): Prefer weight of
`semi-bold' when available so that buttonization is at least somewhat
perceptible in notices and action messages.
(erc-send-action): Ensure nickname passed to `erc-display-message' has
`erc-speaker' property and `erc-ctcp' ACTION property.
(erc--own-property-names): Add `erc-speaker' to lineup.
(erc-format-privmessage): Don't clobber `erc-nick-prefix-face'.  That
is, retain face applied to a leading stretch of characters in the
`nick' parameter, but continue to discard trailing faces.
(erc-format-my-nick, erc-ctcp-query-ACTION): Add new text property
`erc-speaker' to the nick portion of the formatted speaker label.  Do
this to assist modules, like `button' and `match', that currently
re-parse speakers in inserted messages.
(erc-process-ctcp-query): Add `erc-ctcp' property to entire message
before insertion hooks see it.
* test/lisp/erc/erc-fill-tests.el (erc-fill-tests--compare): Warn
about certain unreliable comparisons if generalizing helper for use by
other modules.
* test/lisp/erc/erc-tests.el (erc-tests--equal-including-properties):
New helper compat macro.
(erc-format-privmessage): New test.  (Bug#64301)

diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 80885c3c874232105dd9ea0dc35ad98162dc0469..3d062e2e9abd7bdca8216fde03d89a89bdd87e95 100644 (file)
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -145,6 +145,13 @@ been restored with a slightly revised role contingent on a few
 assumptions explained in its doc string.  For clarity, it has been
 renamed 'erc-ensure-target-buffer-on-privmsg'.
 
+** Subtle changes in two fundamental faces.
+Users of the default theme may notice that 'erc-action-face' and
+'erc-notice-face' now appear slightly less bold on systems supporting
+a weight of 'semi-bold'.  This was done to make buttons detectable and
+to spare users from resorting to tweaking these faces, or options like
+'erc-notice-highlight-type', just to achieve this effect.
+
 ** Improved interplay between buffer truncation and message logging.
 While most of these improvements are subtle, some affect everyday use.
 For example, users of the 'truncate' module may notice that truncation

diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index 5115e45210d17e35ba455ab082caae39025a0fe1..a65c95f1d850f6e8efc71141f0925dad89ab096f 100644 (file)
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -124,11 +124,9 @@ configured.  Its value should be larger than that of the variable
   :package-version '(ERC . "5.6") ; FIXME sync on release
   :type '(choice (const nil) number))
 
-(defcustom erc-fill-spaced-commands '(PRIVMSG NOTICE)
+(defvar erc-fill--spaced-commands '(PRIVMSG NOTICE)
   "Types of messages to add space between on graphical displays.
-Only considered when `erc-fill-line-spacing' is non-nil."
-  :package-version '(ERC . "5.6") ; FIXME sync on release
-  :type '(repeat (choice integer symbol)))
+Only considered when `erc-fill-line-spacing' is non-nil.")
 
 (defvar-local erc-fill--function nil
   "Internal copy of `erc-fill-function'.
@@ -153,12 +151,12 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'."
                       (p (point-min)))
             (widen)
             (when (or (and-let* ((cmd (get-text-property p 'erc-command)))
-                        (memq cmd erc-fill-spaced-commands))
+                        (memq cmd erc-fill--spaced-commands))
                       (and-let* ((cmd (save-excursion
                                         (forward-line -1)
                                         (get-text-property (point)
                                                            'erc-command))))
-                        (memq cmd erc-fill-spaced-commands)))
+                        (memq cmd erc-fill--spaced-commands)))
               (put-text-property (1- p) p
                                  'line-spacing erc-fill-line-spacing))))))))
 
@@ -384,8 +382,7 @@ parties.")
                        (when (eq 'erc-timestamp (field-at-pos m))
                          (set-marker m (field-end m)))
                        (and (eq 'PRIVMSG (get-text-property m 'erc-command))
-                            (not (eq (get-text-property m 'font-lock-face)
-                                     'erc-action-face))
+                            (not (eq (get-text-property m 'erc-ctcp) 'ACTION))
                             (cons (get-text-property m 'erc-timestamp)
                                   (get-text-property (1+ m) 'erc-data)))))
               (ts (pop props))
@@ -418,6 +415,12 @@ parties.")
                        `(space :width (- erc-fill--wrap-value ,width))))
   args)
 
+;; An escape hatch for third-party code expecting speakers of ACTION
+;; messages to be exempt from `line-prefix'.  This could be converted
+;; into a user option if users feel similarly.
+(defvar erc-fill--wrap-action-dedent-p t
+  "Whether to dedent speakers in CTCP \"ACTION\" lines.")
+
 (defun erc-fill-wrap ()
   "Use text props to mimic the effect of `erc-fill-static'.
 See `erc-fill-wrap-mode' for details."
@@ -428,6 +431,12 @@ See `erc-fill-wrap-mode' for details."
     (let ((len (or (and erc-fill--wrap-length-function
                         (funcall erc-fill--wrap-length-function))
                    (progn
+                     (when-let ((e (erc--get-speaker-bounds))
+                                (b (pop e))
+                                ((or erc-fill--wrap-action-dedent-p
+                                     (not (eq (get-text-property b 'erc-ctcp)
+                                              'ACTION)))))
+                       (goto-char e))
                      (skip-syntax-forward "^-")
                      (forward-char)
                      ;; Using the `invisible' property might make more

diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 6c3dc82b13352c589f7fe3f0424516fce8e59276..c10b39e9a1b8dfc8ac85c27de7933b4bb03ebb93 100644 (file)
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -1302,13 +1302,18 @@ See the variable `erc-command-indicator'."
 
 (defface erc-notice-face
   '((default :weight bold)
+    (((class color) (min-colors 88) (supports :weight semi-bold))
+     :weight semi-bold :foreground "SlateBlue")
     (((class color) (min-colors 88)) :foreground "SlateBlue")
     (t :foreground "blue"))
   "ERC face for notices."
+  :package-version '(ERC . "5.6") ; FIXME sync on release
   :group 'erc-faces)
 
-(defface erc-action-face '((t :weight bold))
+(defface erc-action-face '((((supports :weight semi-bold)) :weight semi-bold)
+                           (t :weight bold))
   "ERC face for actions generated by /ME."
+  :package-version '(ERC . "5.6") ; FIXME sync on release
   :group 'erc-faces)
 
 (defface erc-error-face '((t :foreground "red"))
@@ -2735,10 +2740,13 @@ If ARG is non-nil, show the *erc-protocol* buffer."
   (erc-send-ctcp-message tgt (format "ACTION %s" str) force)
   (let ((erc-insert-pre-hook
          (cons (lambda (s) ; Leave newline be.
-                 (put-text-property 0 (1- (length s)) 'erc-command 'PRIVMSG s))
-               erc-insert-pre-hook)))
+                 (put-text-property 0 (1- (length s)) 'erc-command 'PRIVMSG s)
+                 (put-text-property 0 (1- (length s)) 'erc-ctcp 'ACTION s))
+               erc-insert-pre-hook))
+        (nick (erc-current-nick)))
+    (setq nick (propertize nick 'erc-speaker nick))
     (erc-display-message nil 'input (current-buffer)
-                         'ACTION ?n (erc-current-nick) ?a str ?u "" ?h "")))
+                         'ACTION ?n nick ?a str ?u "" ?h "")))
 
 ;; Display interface
 
@@ -4580,7 +4588,7 @@ Eventually add a # in front of it, if that turns it into a valid channel name."
     (concat "#" channel)))
 
 (defvar erc--own-property-names
-  '( tags erc-parsed display ; core
+  '( tags erc-speaker erc-parsed display ; core
      ;; `erc-display-prompt'
      rear-nonsticky erc-prompt field front-sticky read-only
      ;; stamp
@@ -5099,11 +5107,19 @@ the parsed NUH, and the original `erc-response' object.")
          (mark-e (if msgp (if privp "*" ">") "-"))
          (str    (format "%s%s%s %s" mark-s nick mark-e msg))
          (nick-face (if privp 'erc-nick-msg-face 'erc-nick-default-face))
+         (nick-prefix-face (get-text-property 0 'font-lock-face nick))
+         (prefix-len (or (and nick-prefix-face (text-property-not-all
+                                                0 (length nick) 'font-lock-face
+                                                nick-prefix-face nick))
+                         0))
          (msg-face (if privp 'erc-direct-msg-face 'erc-default-face)))
     ;; add text properties to text before the nick, the nick and after the nick
     (erc-put-text-property 0 (length mark-s) 'font-lock-face msg-face str)
-    (erc-put-text-property (length mark-s) (+ (length mark-s) (length nick))
-                           'font-lock-face nick-face str)
+    (erc-put-text-properties (+ (length mark-s) prefix-len)
+                             (+ (length mark-s) (length nick))
+                             '(font-lock-face erc-speaker) str
+                             (list nick-face
+                                   (substring-no-properties nick prefix-len)))
     (erc-put-text-property (+ (length mark-s) (length nick)) (length str)
                            'font-lock-face msg-face str)
     str))
@@ -5155,7 +5171,7 @@ also `erc-format-nick-function'."
         (concat
          (propertize open 'font-lock-face 'erc-default-face)
          (propertize mode 'font-lock-face 'erc-my-nick-prefix-face)
-         (propertize nick 'font-lock-face 'erc-my-nick-face)
+         (propertize nick 'font-lock-face 'erc-my-nick-face 'erc-speaker nick)
          (propertize close 'font-lock-face 'erc-default-face)))
     (let ((prefix "> "))
       (propertize prefix 'font-lock-face 'erc-default-face))))
@@ -5393,7 +5409,12 @@ See also `erc-display-message'."
            'ctcp-empty ?n nick)
         (while queries
           (let* ((type (upcase (car (split-string (car queries)))))
-                 (hook (intern-soft (concat "erc-ctcp-query-" type "-hook"))))
+                 (hook (intern-soft (concat "erc-ctcp-query-" type "-hook")))
+                 (erc-insert-pre-hook
+                  (cons (lambda (s)
+                          (put-text-property 0 (1- (length s)) 'erc-ctcp
+                                             (intern type) s))
+                        erc-insert-pre-hook)))
             (if (and hook (boundp hook))
                 (if (string-equal type "ACTION")
                     (run-hook-with-args-until-success
@@ -5428,6 +5449,7 @@ See also `erc-display-message'."
           (buf (or (erc-get-buffer to proc)
                    (erc-get-buffer nick proc)
                    (process-buffer proc))))
+      (setq nick (propertize nick 'erc-speaker nick))
       (erc-display-message
        parsed 'action buf
        'ACTION ?n nick ?u login ?h host ?a s))))

diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el
index 15a8087f84834937875f83f48ec216b2e7bb9b85..99ec4a9635e04eb8703c1d9eafaaa7bfad62f2fa 100644 (file)
--- a/test/lisp/erc/erc-fill-tests.el
+++ b/test/lisp/erc/erc-fill-tests.el
@@ -153,7 +153,10 @@
         (with-temp-file expect-file
           (insert repr))
       (if (file-exists-p expect-file)
-          ;; Compare set-equal over intervals
+          ;; Compare set-equal over intervals.  This comparison is
+          ;; less useful for messages treated by other modules because
+          ;; it doesn't compare "nested" props belonging to
+          ;; string-valued properties, like timestamps.
           (should (equal-including-properties
                    (read repr)
                    (read (with-temp-buffer

diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 8d63936b7c2e3b5c3c848262203d4b7d766eb73c..fed25056b4200f6a1cb0b836848a6d5f41fe17da 100644 (file)
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1443,6 +1443,49 @@
     (kill-buffer "ExampleNet")
     (kill-buffer "#chan")))
 
+(defmacro erc-tests--equal-including-properties (a b)
+  (list (if (< emacs-major-version 29)
+            'ert-equal-including-properties
+          'equal-including-properties)
+        a b))
+
+(ert-deftest erc-format-privmessage ()
+  ;; Basic PRIVMSG
+  (should (erc-tests--equal-including-properties
+           (erc-format-privmessage (copy-sequence "bob")
+                                   (copy-sequence "oh my")
+                                   nil 'msgp)
+           #("<bob> oh my"
+             0 1 (font-lock-face erc-default-face)
+             1 4 (erc-speaker "bob" font-lock-face erc-nick-default-face)
+             4 11 (font-lock-face erc-default-face))))
+
+  ;; Basic NOTICE
+  (should (erc-tests--equal-including-properties
+           (erc-format-privmessage (copy-sequence "bob")
+                                   (copy-sequence "oh my")
+                                   nil nil)
+           #("-bob- oh my"
+             0 1 (font-lock-face erc-default-face)
+             1 4 (erc-speaker "bob" font-lock-face erc-nick-default-face)
+             4 11 (font-lock-face erc-default-face))))
+
+  ;; Prefixed PRIVMSG
+  (let* ((user (make-erc-server-user :nickname (copy-sequence "Bob")))
+         (cuser (make-erc-channel-user :op t))
+         (erc-channel-users (make-hash-table :test #'equal)))
+    (puthash "bob" (cons user cuser) erc-channel-users)
+
+    (should (erc-tests--equal-including-properties
+             (erc-format-privmessage (erc-format-@nick user cuser)
+                                     (copy-sequence "oh my")
+                                     nil 'msgp)
+             #("<@Bob> oh my"
+               0 1 (font-lock-face erc-default-face)
+               1 2 (font-lock-face erc-nick-prefix-face help-echo "operator")
+               2 5 (erc-speaker "Bob" font-lock-face erc-nick-default-face)
+               5 12 (font-lock-face erc-default-face))))))
+
 (defvar erc-tests--ipv6-examples
   '("1:2:3:4:5:6:7:8"
     "::ffff:10.0.0.1" "::ffff:1.2.3.4" "::ffff:0.0.0.0"