mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-25 07:28:20 +00:00
Skip indentation when gathering faces in erc-track
* lisp/erc/erc-nicks.el (erc-nicks-mode, erc-nicks-enable) (erc-nicks-disable): Use correct name for `track' module hook. (erc-nicks--check-normals): Remove falsity from doc string. * lisp/erc/erc-track.el (erc-make-mode-line-buffer-name): Don't error when optional COUNT is nil. (erc-track-modified-channels): Use new name for preferred face-finding function. (erc-track--get-faces-in-current-message, erc-track--collect-faces-in): Rename former to latter to better reflect expanded utility, which now includes spanning gaps, including newlines and indentation that may be lacking in face-related properties. * test/lisp/erc/erc-track-tests.el (erc-track--collect-faces-in): New test. (Bug#73443)
This commit is contained in:
F. Jason Park
parent
4d7f41716e
commit
df593b5a61
@ -580,7 +580,7 @@ Abandon search after examining LIMIT faces."
|
||||
(setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal)
|
||||
#'erc-nicks-customize-face)
|
||||
(erc-nicks--setup-track-integration)
|
||||
(add-hook 'erc-track-mode #'erc-nicks--setup-track-integration 50 t)
|
||||
(add-hook 'erc-track-mode-hook #'erc-nicks--setup-track-integration 50 t)
|
||||
(advice-add 'widget-create-child-and-convert :filter-args
|
||||
#'erc-nicks--redirect-face-widget-link))
|
||||
((kill-local-variable 'erc-nicks--face-table)
|
||||
@ -598,6 +598,7 @@ Abandon search after examining LIMIT faces."
|
||||
#'erc-nicks--highlight-button)
|
||||
(remove-function (local 'erc-track--alt-normals-function)
|
||||
#'erc-nicks--check-normals)
|
||||
(remove-hook 'erc-track-mode-hook #'erc-nicks--setup-track-integration t)
|
||||
(setf (alist-get "Edit face"
|
||||
erc-button--nick-popup-alist nil 'remove #'equal)
|
||||
nil)
|
||||
@ -736,7 +737,7 @@ Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"."
|
||||
"Return a viable `nicks'-owned face from NORMALS in CONTENDERS.
|
||||
But only do so if the CURRENT face is also one of ours and in
|
||||
NORMALS and if the highest ranked CONTENDER among new faces is
|
||||
`erc-default-face', the lowest ranking default priority face."
|
||||
`erc-default-face'."
|
||||
(and-let* (((eq contender 'erc-default-face))
|
||||
((or (null current) (gethash current normals)))
|
||||
(spkr (or (null current) (erc-nicks--oursp current))))
|
||||
|
||||
@ -768,7 +768,7 @@ is displayed according to `erc-track-mouse-face'."
|
||||
;; (really?), 3. the defun needs to switch to BUFFER, so we would
|
||||
;; need to save that value somewhere.
|
||||
(let ((map (make-sparse-keymap))
|
||||
(name (if erc-track-showcount
|
||||
(name (if (and count erc-track-showcount)
|
||||
(concat string
|
||||
erc-track-showcount-string
|
||||
(int-to-string count))
|
||||
@ -992,7 +992,7 @@ the current buffer is in `erc-mode'."
|
||||
(when-let
|
||||
((faces (if erc-track-ignore-normal-contenders-p
|
||||
(erc-faces-in (buffer-string))
|
||||
(erc-track--get-faces-in-current-message)))
|
||||
(erc-track--collect-faces-in)))
|
||||
(normals erc-track--normal-faces)
|
||||
(erc-track-faces-priority-list
|
||||
`(,@erc-track--attn-faces ,@erc-track-faces-priority-list))
|
||||
@ -1057,25 +1057,25 @@ the current buffer is in `erc-mode'."
|
||||
(defvar erc-track--face-reject-function nil
|
||||
"Function called with face in current buffer to massage or reject.")
|
||||
|
||||
(defun erc-track--get-faces-in-current-message ()
|
||||
"Collect all faces in the narrowed buffer.
|
||||
Return a cons of a hash table and a list ordered from most
|
||||
recently seen to earliest seen."
|
||||
(let ((i (text-property-not-all (point-min) (point-max) 'font-lock-face nil))
|
||||
(seen (make-hash-table :test #'equal))
|
||||
;;
|
||||
(rfaces ())
|
||||
(faces (make-hash-table :test #'equal)))
|
||||
(while-let ((i)
|
||||
(cur (get-text-property i 'face)))
|
||||
(unless (gethash cur seen)
|
||||
(puthash cur t seen)
|
||||
(when erc-track--face-reject-function
|
||||
(setq cur (funcall erc-track--face-reject-function cur)))
|
||||
(when cur
|
||||
(push cur rfaces)
|
||||
(puthash cur t faces)))
|
||||
(setq i (next-single-property-change i 'font-lock-face)))
|
||||
(defun erc-track--collect-faces-in ()
|
||||
"Collect all faces in the (presumably narrowed) current buffer.
|
||||
Return a cons cell of a hash table and a list ordered from most recently
|
||||
seen to least."
|
||||
(let* ((prop (if noninteractive 'font-lock-face 'face))
|
||||
(p (text-property-not-all (point-min) (point-max) prop nil))
|
||||
(seen (and p (make-hash-table :test #'equal)))
|
||||
(faces (make-hash-table :test #'equal))
|
||||
(rfaces ()))
|
||||
(while p
|
||||
(when-let ((cur (get-text-property p prop)))
|
||||
(unless (gethash cur seen)
|
||||
(puthash cur t seen)
|
||||
(when erc-track--face-reject-function
|
||||
(setq cur (funcall erc-track--face-reject-function cur)))
|
||||
(when cur
|
||||
(push cur rfaces)
|
||||
(puthash cur t faces))))
|
||||
(setq p (next-single-property-change p prop)))
|
||||
(cons faces rfaces)))
|
||||
|
||||
;;; Buffer switching
|
||||
|
||||
@ -22,8 +22,12 @@
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'erc-track)
|
||||
(require 'ert-x)
|
||||
(eval-and-compile
|
||||
(let ((load-path (cons (ert-resource-directory) load-path)))
|
||||
(require 'erc-tests-common)))
|
||||
|
||||
|
||||
(ert-deftest erc-track--shorten-aggressive-nil ()
|
||||
"Test non-aggressive erc track buffer name shortening."
|
||||
@ -286,4 +290,124 @@
|
||||
(a b (b a))
|
||||
(a b (a b)))))
|
||||
|
||||
(ert-deftest erc-track--collect-faces-in ()
|
||||
(with-current-buffer (get-buffer-create "*erc-track--get-faces-in*")
|
||||
(erc-tests-common-prep-for-insertion)
|
||||
(goto-char (point-min))
|
||||
(skip-chars-forward "\n")
|
||||
|
||||
(let ((ts #("[04:37]"
|
||||
0 1 ( erc--msg 0 field erc-timestamp
|
||||
font-lock-face erc-timestamp-face)
|
||||
1 7 ( field erc-timestamp
|
||||
font-lock-face erc-timestamp-face)))
|
||||
bounds)
|
||||
|
||||
(with-silent-modifications
|
||||
|
||||
(push (list (point)) bounds)
|
||||
(insert ; JOIN
|
||||
ts " " ; iniital `fill' indentation lacks properties
|
||||
#("*** You have joined channel #chan" 0 33
|
||||
(font-lock-face erc-notice-face))
|
||||
"\n")
|
||||
(setcdr (car bounds) (point))
|
||||
|
||||
(push (list (point)) bounds)
|
||||
(insert ; 353
|
||||
ts " "
|
||||
#("*** Users on #chan: bob alice dummy tester"
|
||||
0 30 (font-lock-face erc-notice-face)
|
||||
30 35 (font-lock-face erc-current-nick-face)
|
||||
35 42 (font-lock-face erc-notice-face))
|
||||
"\n" #(" @fsbot" ; but intervening HAS properties
|
||||
0 23 (font-lock-face erc-notice-face)))
|
||||
(setcdr (car bounds) (point))
|
||||
|
||||
(push (list (point)) bounds)
|
||||
(insert ; PRIVMSG
|
||||
"\n" ts " "
|
||||
#("<alice> bob: Thou canst not come to me: I come to"
|
||||
0 1 (font-lock-face erc-default-face)
|
||||
;; erc-dangerous-host-face -> erc-nicks-alice-face (undefined)
|
||||
1 6 (font-lock-face (erc-dangerous-host-face erc-nick-default-face))
|
||||
6 8 (font-lock-face erc-default-face)
|
||||
;; erc-pal-face -> erc-nicks-bob-face (undefined)
|
||||
8 11 (font-lock-face (erc-pal-face erc-default-face))
|
||||
11 49 (font-lock-face erc-default-face))
|
||||
"\n" #(" thee."
|
||||
0 22 (font-lock-face erc-default-face))
|
||||
"\n")
|
||||
(setcdr (car bounds) (point)))
|
||||
|
||||
(goto-char (point-max))
|
||||
(should (equal (setq bounds (nreverse bounds))
|
||||
'((3 . 50) (50 . 129) (129 . 212))))
|
||||
|
||||
;; For these result assertions, the insertion order of the table
|
||||
;; elements should mirror that of the consed lists.
|
||||
|
||||
;; Baseline
|
||||
(narrow-to-region 1 3)
|
||||
(let ((result (erc-track--collect-faces-in)))
|
||||
(should-not (map-pairs (car result)))
|
||||
(should-not (cdr result)))
|
||||
|
||||
;; JOIN
|
||||
(narrow-to-region (car (nth 0 bounds)) (cdr (nth 0 bounds)))
|
||||
(let ((result (erc-track--collect-faces-in)))
|
||||
(should (seq-set-equal-p
|
||||
(map-pairs (car result)) '((erc-timestamp-face . t)
|
||||
(erc-notice-face . t))))
|
||||
(should (equal (cdr result) '(erc-notice-face erc-timestamp-face))))
|
||||
|
||||
;; 353
|
||||
(narrow-to-region (car (nth 1 bounds)) (cdr (nth 1 bounds)))
|
||||
(let ((result (erc-track--collect-faces-in)))
|
||||
(should (seq-set-equal-p (map-pairs (car result))
|
||||
'((erc-timestamp-face . t)
|
||||
(erc-notice-face . t)
|
||||
(erc-current-nick-face . t))))
|
||||
(should (equal (cdr result) '(erc-current-nick-face
|
||||
erc-notice-face
|
||||
erc-timestamp-face))))
|
||||
|
||||
;; PRIVMSG
|
||||
(narrow-to-region (car (nth 2 bounds)) (cdr (nth 2 bounds)))
|
||||
(let ((result (erc-track--collect-faces-in)))
|
||||
(should (seq-set-equal-p
|
||||
(map-pairs (car result))
|
||||
'((erc-timestamp-face . t)
|
||||
(erc-default-face . t)
|
||||
((erc-dangerous-host-face erc-nick-default-face) . t)
|
||||
((erc-pal-face erc-default-face) . t))))
|
||||
(should (equal (cdr result)
|
||||
'((erc-pal-face erc-default-face)
|
||||
(erc-dangerous-host-face erc-nick-default-face)
|
||||
erc-default-face
|
||||
erc-timestamp-face))))
|
||||
|
||||
;; Entire buffer.
|
||||
(narrow-to-region (car (nth 0 bounds)) erc-insert-marker)
|
||||
(let ((result (erc-track--collect-faces-in)))
|
||||
(should (seq-set-equal-p
|
||||
(map-pairs (car result))
|
||||
'((erc-timestamp-face . t)
|
||||
(erc-notice-face . t)
|
||||
(erc-current-nick-face . t)
|
||||
(erc-default-face . t)
|
||||
((erc-dangerous-host-face erc-nick-default-face) . t)
|
||||
((erc-pal-face erc-default-face) . t))))
|
||||
(should (equal (cdr result)
|
||||
'((erc-pal-face erc-default-face)
|
||||
(erc-dangerous-host-face erc-nick-default-face)
|
||||
erc-default-face
|
||||
erc-current-nick-face
|
||||
erc-notice-face
|
||||
erc-timestamp-face)))))
|
||||
|
||||
(widen)
|
||||
(when noninteractive
|
||||
(kill-buffer))))
|
||||
|
||||
;;; erc-track-tests.el ends here
|
||||
|
||||
Loading…
Reference in New Issue
Block a user