From: F. Jason Park Date: Sun, 25 Jun 2023 01:33:20 +0000 (-0700) Subject: Add text props for CTCP messages and speakers in ERC X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=6a96b862680d4ab168259572545bc9d6a29352c7;p=emacs.git 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 80885c3c874..3d062e2e9ab 100644 --- 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 5115e45210d..a65c95f1d85 100644 --- 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 6c3dc82b133..c10b39e9a1b 100644 --- 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 15a8087f848..99ec4a9635e 100644 --- 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 8d63936b7c2..fed25056b42 100644 --- 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) + #(" 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"