Skip to content

Commit 398b370

Browse files
ikappakiikappaki
authored
Workaround for `ansi-color-apply' Emacs bug#53808 (#3154)
Enabled only in Emacs versions < 29. https://debbugs.gnu.org/cgi/bugreport.cgi?bug=53808. Also fixed a couple of old linter docstring warnings.
1 parent 223bd60 commit 398b370

File tree

4 files changed

+118
-24
lines changed

4 files changed

+118
-24
lines changed

‎cider-mode.el

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -765,7 +765,7 @@ with the given LIMIT."
765765
value))
766766

767767
(defun cider--compile-font-lock-keywords (symbols-plist core-plist)
768-
"Return a list of font-lock rules for symbols."
768+
"Return a list of font-lock rules for symbols in SYMBOLS-PLIST, CORE-PLIST."
769769
(let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t)
770770
'(function var macro core deprecated)
771771
cider-font-lock-dynamically))

‎cider-repl-history.el

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -344,7 +344,7 @@ case return nil."
344344
(error "No CIDER history item here")))))
345345

346346
(defun cider-repl-history-current-string (pt &optional no-error)
347-
"Find the string to insert into the REPL by looking for the overlay at PT
347+
"Find the string to insert into the REPL by looking for the overlay at PT.
348348
Might error unless NO-ERROR set."
349349
(let ((o (cider-repl-history-target-overlay-at pt t)))
350350
(if o

‎cider-repl.el

Lines changed: 49 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -593,13 +593,51 @@ Return the position of the prompt beginning."
593593
(set-marker cider-repl-prompt-start-mark prompt-start)
594594
prompt-start))))
595595

596-
(defun cider-repl--flush-ansi-color-context ()
597-
"Flush ansi color context after printing.
598-
When there is a possible unfinished ansi control sequence,
599-
`ansi-color-context` maintains this list."
600-
(when (and ansi-color-context (stringp (cadr ansi-color-context)))
601-
(insert-before-markers (cadr ansi-color-context))
602-
(setq ansi-color-context nil)))
596+
(defun cider-repl--ansi-color-apply (string)
597+
"Like `ansi-color-apply', but does not withhold non-SGR seqs found in STRING.
598+
599+
Workaround for Emacs bug#53808 whereby partial ANSI control seqs present in
600+
the input stream may block the whole colorization process."
601+
(let* ((result (ansi-color-apply string))
602+
603+
;; The STRING may end with a possible incomplete ANSI control seq which
604+
;; the call to `ansi-color-apply' stores in the `ansi-color-context'
605+
;; fragment. If the fragment is not an incomplete ANSI color control
606+
;; sequence (aka SGR seq) though then flush it out and appended it to
607+
;; the result.
608+
(fragment-flush?
609+
(when-let (fragment (and ansi-color-context (cadr ansi-color-context)))
610+
(save-match-data
611+
;; Check if fragment is indeed an SGR seq in the making. The SGR
612+
;; seq is defined as starting with ESC followed by [ followed by
613+
;; zero or more [:digit:]+; followed by one or more digits and
614+
;; ending with m.
615+
(when (string-match
616+
(rx (sequence ?\e
617+
(? (and (or ?\[ eol)
618+
(or (+ (any (?0 . ?9))) eol)
619+
(* (sequence ?\; (+ (any (?0 . ?9)))))
620+
(or ?\; eol)))))
621+
fragment)
622+
(let* ((sgr-end-pos (match-end 0))
623+
(fragment-matches-whole? (or (= sgr-end-pos 0)
624+
(= sgr-end-pos (length fragment)))))
625+
(when (not fragment-matches-whole?)
626+
;; Definitely not an partial SGR seq, flush it out of
627+
;; `ansi-color-context'.
628+
t)))))))
629+
630+
(if (not fragment-flush?)
631+
result
632+
633+
(progn
634+
;; Temporarily replace the ESC char in the fragment so that is flushed
635+
;; out of `ansi-color-context' by `ansi-color-apply' and append it to
636+
;; the result.
637+
(aset (cadr ansi-color-context) 0 ?\0)
638+
(let ((result-fragment (ansi-color-apply "")))
639+
(aset result-fragment 0 ?\e)
640+
(concat result result-fragment))))))
603641

604642
(defvar-local cider-repl--ns-forms-plist nil
605643
"Plist holding ns->ns-form mappings within each connection.")
@@ -672,7 +710,9 @@ namespaces. STRING is REPL's output."
672710
(put-text-property 0 (length string) 'help-echo 'cider-locref-help-echo string)
673711
string)
674712

675-
(defvar cider-repl-preoutput-hook '(ansi-color-apply
713+
(defvar cider-repl-preoutput-hook `(,(if (< emacs-major-version 29)
714+
'cider-repl--ansi-color-apply
715+
'ansi-color-apply)
676716
cider-repl-highlight-current-project
677717
cider-repl-highlight-spec-keywords
678718
cider-repl-add-locref-help-echo)
@@ -729,8 +769,7 @@ Before inserting, run `cider-repl-preoutput-hook' on STRING."
729769
'font-lock-face face
730770
'rear-nonsticky '(font-lock-face)))
731771
(setq string (cider-run-chained-hook 'cider-repl-preoutput-hook string))
732-
(insert-before-markers string)
733-
(cider-repl--flush-ansi-color-context))
772+
(insert-before-markers string))
734773
(when (and (= (point) cider-repl-prompt-start-mark)
735774
(not (bolp)))
736775
(insert-before-markers "\n")

‎test/cider-repl-tests.el

Lines changed: 67 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -106,30 +106,71 @@
106106
(cider-repl--emit-output (current-buffer) "a\n" 'cider-repl-stdout-face)
107107
(cider-repl--emit-output (current-buffer) "b\n" 'cider-repl-stdout-face)
108108
(cider-repl--emit-output (current-buffer) "c\n" 'cider-repl-stdout-face)
109-
(cider-repl--emit-output (current-buffer) "d\n" 'cider-repl-stdout-face)
109+
;; split at ESC
110+
(cider-repl--emit-output (current-buffer) "" 'cider-repl-stdout-face)
111+
(cider-repl--emit-output (current-buffer) "[32md\n" 'cider-repl-stdout-face)
112+
;; split at ESC [
113+
(cider-repl--emit-output (current-buffer) "[" 'cider-repl-stdout-face)
114+
(cider-repl--emit-output (current-buffer) "33me\n" 'cider-repl-stdout-face)
110115

111-
(expect (buffer-string) :to-equal "a\nb\nc\nd\n")
116+
;; split at ESC [n
117+
(cider-repl--emit-output (current-buffer) "[3" 'cider-repl-stdout-face)
118+
(cider-repl--emit-output (current-buffer) "1mf\n" 'cider-repl-stdout-face)
119+
120+
;; split at ESC [nm
121+
(cider-repl--emit-output (current-buffer) "" 'cider-repl-stdout-face)
122+
(cider-repl--emit-output (current-buffer) "g\n" 'cider-repl-stdout-face)
123+
124+
;; split at ESC [n;
125+
(cider-repl--emit-output (current-buffer) "[1;" 'cider-repl-stdout-face)
126+
(cider-repl--emit-output (current-buffer) "33mh\n" 'cider-repl-stdout-face)
127+
128+
;; split at ESC [n;n
129+
(cider-repl--emit-output (current-buffer) "[0;31" 'cider-repl-stdout-face)
130+
(cider-repl--emit-output (current-buffer) "mi\n" 'cider-repl-stdout-face)
131+
132+
;; split at ESC [n;nm
133+
(cider-repl--emit-output (current-buffer) "" 'cider-repl-stdout-face)
134+
(cider-repl--emit-output (current-buffer) "j\n" 'cider-repl-stdout-face)
135+
136+
(expect (buffer-substring-no-properties (point-min) (point-max))
137+
:to-equal "a\nb\nc\nd\ne\nf\ng\nh\ni\nj\n")
112138
(expect (get-text-property 1 'font-lock-face)
113139
:to-equal '(foreground-color . "black"))
114140
(expect (get-text-property 3 'font-lock-face)
115141
:to-equal 'cider-repl-stdout-face)
116142
(expect (get-text-property 5 'font-lock-face)
117143
:to-equal '(foreground-color . "red3"))
118144
(expect (get-text-property 7 'font-lock-face)
119-
:to-equal '(foreground-color . "red3"))))))
145+
:to-equal '(foreground-color . "green3"))
146+
(expect (get-text-property 9 'font-lock-face)
147+
:to-equal '(foreground-color . "yellow3"))
148+
(expect (get-text-property 11 'font-lock-face)
149+
:to-equal '(foreground-color . "red3"))
150+
(expect (get-text-property 13 'font-lock-face)
151+
:to-equal '(foreground-color . "green3"))
152+
(expect (get-text-property 15 'font-lock-face)
153+
:to-equal '((foreground-color . "yellow3") bold))
154+
(expect (get-text-property 17 'font-lock-face)
155+
:to-equal '(foreground-color . "red3"))
156+
(expect (get-text-property 19 'font-lock-face)
157+
:to-equal '((foreground-color . "green3") italic))
158+
))))
120159

121160
(defun simulate-cider-output (s property)
122161
"Return properties from `cider-repl--emit-output'.
123162
PROPERTY should be a symbol of either 'text, 'ansi-context or
124163
'properties."
125-
(with-temp-buffer
126-
(with-testing-ansi-table cider-testing-ansi-colors-vector
127-
(cider-repl-reset-markers)
128-
(cider-repl--emit-output (current-buffer) s nil))
129-
(pcase property
130-
(`text (substring-no-properties (buffer-string)))
131-
(`ansi-context ansi-color-context)
132-
(`properties (substring (buffer-string))))))
164+
(let ((strings (if (listp s) s (list s))))
165+
(with-temp-buffer
166+
(with-testing-ansi-table cider-testing-ansi-colors-vector
167+
(cider-repl-reset-markers)
168+
(dolist (s strings)
169+
(cider-repl--emit-output (current-buffer) s nil)))
170+
(pcase property
171+
(`text (substring-no-properties (buffer-string)))
172+
(`ansi-context ansi-color-context)
173+
(`properties (substring (buffer-string)))))))
133174

134175
(describe "cider-repl--emit-output"
135176
(it "prints simple strings"
@@ -142,7 +183,21 @@ PROPERTY should be a symbol of either 'text, 'ansi-context or
142183
(expect (simulate-cider-output "\033hi" 'text)
143184
:to-equal "\033hi\n")
144185
(expect (simulate-cider-output "\033hi" 'ansi-context)
145-
:to-equal nil)))
186+
:to-equal nil)
187+
188+
;; Informational: Ideally, we would have liked any non-SGR
189+
;; sequence to appear on the output verbatim, but as per the
190+
;; `ansi-color-apply' doc string, they are removed
191+
;;
192+
;; """Translates SGR control sequences into text properties.
193+
;; Delete all other control sequences without processing them."""
194+
;;
195+
;; e.g.:
196+
(expect (simulate-cider-output
197+
"\033[hi" 'text) :to-equal "i\n")
198+
(expect (simulate-cider-output
199+
'("\033[" "hi") 'text) :to-equal "i\n")
200+
))
146201

147202
(describe "when the escape code is valid"
148203
(it "preserves the context"

0 commit comments

Comments
 (0)