From 0f324a9946804fe01476ed62be9c23e99b47aaed Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sat, 24 Jun 2023 18:33:20 -0700 Subject: [PATCH 3/4] [5.6] Add text props for CTCPs and speakers in ERC * 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--wrap-continued-message-p): Use `erc-ctcp' text prop instead of face to detect ACTION. (erc-fill--wrap-action-dedent-p): New variable to toggle whether `line-prefix' is applied to CTCP ACTION messages. (erc-fill-wrap): Look for `erc-speaker' property before falling back on word at point. Use `erc-ctcp' to detect 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 visible. (erc-send-action): Ensure nickname passed to `erc-display-message' has `erc-speaker' property and `erc-ctcp' ACTION property. Apply both `erc-input-face' and `erc-action-face' to messages. (erc--own-property-names): Add `erc-speaker'. (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 a new text property, `erc-speaker', to the nick portion of the formatted speaker label. Do this to assist modules, like `button' and `match', that re-parse speakers in inserted messages. (erc-process-ctcp-query): Add `erc-ctcp' property to entire message before insertion hooks. (Bug#64301) * test/lisp/erc/erc-fill-tests.el (erc-fill-tests--compare): Warn about certain unreliable comparisons if generalizing helper for use by other modules. --- lisp/erc/erc-fill.el | 25 ++++++++++++++------- lisp/erc/erc.el | 40 ++++++++++++++++++++++++--------- test/lisp/erc/erc-fill-tests.el | 5 ++++- 3 files changed, 51 insertions(+), 19 deletions(-) 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 @@ erc-fill-line-spacing :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 @@ erc-fill (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 @@ erc-fill--wrap-continued-message-p (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 @@ erc-fill--wrap-stamp-insert-prefixed-date `(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 @@ erc-fill-wrap (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 06b88ade2a0..d43281825fb 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1302,12 +1302,15 @@ erc-command-indicator-face (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." :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." :group 'erc-faces) @@ -2723,10 +2726,13 @@ erc-send-action (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))) - (erc-display-message nil 'input (current-buffer) - 'ACTION ?n (erc-current-nick) ?a str ?u "" ?h ""))) + (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 '(action input) (current-buffer) + 'ACTION ?n nick ?a str ?u "" ?h ""))) ;; Display interface @@ -4532,7 +4538,7 @@ erc-ensure-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 @@ -5051,11 +5057,19 @@ erc-format-privmessage (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)) @@ -5107,7 +5121,7 @@ erc-format-my-nick (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)))) @@ -5345,7 +5359,12 @@ erc-process-ctcp-query '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 @@ -5380,6 +5399,7 @@ erc-ctcp-query-ACTION (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 @@ erc-fill-tests--compare (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 -- 2.41.0