Update cursor display using Xterm escape sequences

* lisp/term/xterm.el (xterm-update-cursor): New user option.
(xterm--init): Use it.
(xterm--post-command-hook): New function for all xterm
functionality installed in 'post-command-hook'.
(xterm--init-frame-title): Install it.
(xterm--init-update-cursor, xterm--set-cursor-type)
(xterm--update-cursor-type, xterm--update-cursor-color): New
functions.
(xterm--cursor-type-to-int): New constant.
* doc/emacs/display.texi (Cursor Display):
* etc/NEWS: Document the new feature.

3 files changed, 152 insertions, 21 deletions

diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 05a25323543..d475fc3cfde 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -2048,20 +2048,41 @@ variable @code{visible-cursor} is @code{nil} when Emacs starts or
 resumes, it uses the normal cursor.
 
 @vindex cursor-type
-  On a graphical display, many more properties of the text cursor can
-be altered.  To customize its color, change the @code{:background}
-attribute of the face named @code{cursor} (@pxref{Face
-Customization}).  (The other attributes of this face have no effect;
-the text shown under the cursor is drawn using the frame's background
-color.)  To change its shape, customize the buffer-local variable
-@code{cursor-type}; possible values are @code{box} (the default),
-@code{(box . @var{size})} (box cursor becoming a hollow box under
-masked images larger than @var{size} pixels in either dimension),
-@code{hollow} (a hollow box), @code{bar} (a vertical bar), @code{(bar
-. @var{n})} (a vertical bar @var{n} pixels wide), @code{hbar} (a
-horizontal bar), @code{(hbar . @var{n})} (a horizontal bar @var{n}
+  On a graphical display and many Xterm-compatible text terminals, the
+color and shape of the text cursor can be altered.  To customize its
+color, change the @code{:background} attribute of the face named
+@code{cursor} (@pxref{Face Customization}).  (The other attributes of
+this face have no effect; the text shown under the cursor is drawn using
+the frame's background color.)  To change its shape, customize the
+buffer-local variable @code{cursor-type}; possible values are @code{box}
+(the default), @code{(box . @var{size})} (box cursor becoming a hollow
+box under masked images larger than @var{size} pixels in either
+dimension), @code{hollow} (a hollow box), @code{bar} (a vertical bar),
+@code{(bar . @var{n})} (a vertical bar @var{n} pixels wide), @code{hbar}
+(a horizontal bar), @code{(hbar . @var{n})} (a horizontal bar @var{n}
 pixels tall), or @code{nil} (no cursor at all).
 
+@vindex xterm-update-cursor
+  On Xterm-compatible text terminals cursor customiztaion is controlled
+by the user option @code{xterm-update-cursor}.  Valid values are:
+@code{t} to update the cursor's color and shape, @code{type} to update
+the cursor's shape only, @code{color} to update the cursor's color only,
+and @code{nil} to not update the cursor's appearance.  Xterm-compatible
+text terminals can not display a hollow box and instead use a filled
+box.  Similarly, Xterm-compatible text terminals ignore the pixel sizes
+for @code{bar} and @code{hbar}.
+
+@findex hl-line-mode
+@findex global-hl-line-mode
+@cindex highlight current line
+  To make the cursor even more visible, you can use HL Line mode, a
+minor mode that highlights the line containing point.  Use @kbd{M-x
+hl-line-mode} to enable or disable it in the current buffer.  @kbd{M-x
+global-hl-line-mode} enables or disables the same mode globally.
+
+  The remaining controls only work on graphical displays where Emacs can
+fully control the way the cursor appears.
+
 @findex blink-cursor-mode
 @cindex cursor, blinking
 @cindex blinking cursor
@@ -2105,14 +2126,6 @@ non-blinking hollow box.  (For a bar cursor, it instead appears as a
 thinner bar.)  To turn off cursors in non-selected windows, change the
 variable @code{cursor-in-non-selected-windows} to @code{nil}.
 
-@findex hl-line-mode
-@findex global-hl-line-mode
-@cindex highlight current line
-  To make the cursor even more visible, you can use HL Line mode, a
-minor mode that highlights the line containing point.  Use @kbd{M-x
-hl-line-mode} to enable or disable it in the current buffer.  @kbd{M-x
-global-hl-line-mode} enables or disables the same mode globally.
-
 @node Line Truncation
 @section Line Truncation
 
diff --git a/etc/NEWS b/etc/NEWS
index 68cb6c642fb..27aff3b7a1e 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -772,6 +772,15 @@ Emacs previously discarded arguments to emacsclient of zero length, such
 as in 'emacsclient --eval "(length (pop server-eval-args-left))" ""'.
 These are no longer discarded.
 
++++
+** New user option 'xterm-update-cursor' to update cursor display on TTYs.
+When enabled, Emacs sends Xterm escape sequences on Xterm-compatible
+terminals to update the cursor's appearacse.  Emacs can update the
+cursor's shape and color.  For example, if you use a purple bar cursor
+on graphical displays then when this option is enabled Emacs will use a
+purple bar cursor on compatible terminals as well.  See the Info node
+"(emacs) Cursor Display" for more information.
+
 
 * Editing Changes in Emacs 31.1
 
diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el
index dd179c4e3eb..47e82decb03 100644
--- a/lisp/term/xterm.el
+++ b/lisp/term/xterm.el
@@ -80,6 +80,20 @@ capabilities, and only when that terminal understands bracketed paste."
   :version "28.1"
   :type 'boolean)
 
+(defcustom xterm-update-cursor nil
+  "If non-nil, try to update the cursor's appearance on XTerm terminals.
+
+If set to t all supported attributes of the cursor are updated.
+If set to `type' only the cursor type is updated.  This uses the CSI
+DECSCUSR escape sequence.
+If set to `color' only the cursor color is updated.  This uses the OSC
+12 escape sequence."
+  :version "31.1"
+  :type '(radio (const :tag "Do not update" nil)
+                (const :tag "Update" t)
+                (const :tag "Update type only" type)
+                (const :tag "Update color only" color)))
+
 (defconst xterm-paste-ending-sequence "\e[201~"
   "Characters sent by the terminal to end a bracketed paste.")
 
@@ -988,6 +1002,8 @@ We run the first FUNCTION whose STRING matches the input events."
 
   (when xterm-set-window-title
     (xterm--init-frame-title))
+  (when xterm-update-cursor
+    (xterm--init-update-cursor))
 
   (let ((bg-color (terminal-parameter nil 'xterm--background-color))
         (fg-color (terminal-parameter nil 'xterm--foreground-color)))
@@ -1025,6 +1041,17 @@ We run the first FUNCTION whose STRING matches the input events."
   ;; We likewise unconditionally enable support for focus tracking.
   (xterm--init-focus-tracking))
 
+(defun xterm--post-command-hook ()
+  "Hook for xterm features that need to be frequently updated."
+
+  (unless (display-graphic-p)
+    (when xterm-set-window-title
+      (xterm-set-window-title))
+    (when (memq xterm-update-cursor '(t type))
+      (xterm--update-cursor-type))
+    (when (memq xterm-update-cursor '(t color))
+      (xterm--update-cursor-color))))
+
 (defun terminal-init-xterm ()
   "Terminal initialization function for xterm."
   (unwind-protect
@@ -1067,7 +1094,7 @@ We run the first FUNCTION whose STRING matches the input events."
   (xterm-set-window-title)
   (add-hook 'after-make-frame-functions 'xterm-set-window-title-flag)
   (add-hook 'window-configuration-change-hook 'xterm-unset-window-title-flag)
-  (add-hook 'post-command-hook 'xterm-set-window-title)
+  (add-hook 'post-command-hook 'xterm--post-command-hook)
   (add-hook 'minibuffer-exit-hook 'xterm-set-window-title))
 
 (defvar xterm-window-title-flag nil
@@ -1300,6 +1327,88 @@ versions of xterm."
             (b (caddr fg-color)))
         (set-face-foreground 'default (format "#%04x%04x%04x" r g b) frame)))))
 
+(defun xterm--init-update-cursor ()
+  "Register hooks to run `xterm--update-cursor-type' appropriately."
+
+  (when (memq xterm-update-cursor '(color t))
+    (xterm--query
+     "\e]12;?\e\\"
+     '(("\e]12;" . (lambda ()
+                     (let ((str (xterm--read-string ?\e ?\\)))
+                       ;; The response is specifically formated to set the
+                       ;; color
+                       (push
+                        (concat "\e]12;" str "\e\\")
+                        (terminal-parameter nil 'tty-mode-reset-strings)))))))
+    ;; No need to set tty-mode-set-strings because
+    ;; xterm--post-command-hook handles restoring the cursor color.
+
+    (xterm--update-cursor-color))
+
+  (when (memq xterm-update-cursor '(type t))
+    (xterm--update-cursor-type))
+
+  (add-hook 'post-command-hook 'xterm--post-command-hook))
+
+(defconst xterm--cursor-type-to-int
+  '(nil 0
+    box 1
+    hollow 1
+    bar 5
+    hbar 3)
+  "Mapping of cursor type symbols to control sequence integers.
+
+Cursor type symbols are the same as for `cursor-type'.")
+
+(defun xterm--set-cursor-type (terminal type)
+  (let ((type-int (or (plist-get xterm--cursor-type-to-int type) 1))
+        (old (terminal-parameter terminal 'xterm--cursor-style)))
+
+    (when old
+      (set-terminal-parameter
+       terminal
+       'tty-mode-set-strings
+       (delete (format "\e[%d q" old)
+               (terminal-parameter terminal 'tty-mode-set-strings))))
+    (let ((set-string (format "\e[%d q" type-int)))
+      (push set-string (terminal-parameter terminal 'tty-mode-set-strings))
+      (send-string-to-terminal set-string terminal))
+    (unless old
+      ;; Assume that the default cursor is appropriate when exiting Emacs.
+      (push "\e[0 q" (terminal-parameter terminal 'tty-mode-reset-strings)))
+
+    (set-terminal-parameter terminal 'xterm--cursor-type type-int)))
+
+(defun xterm--update-cursor-type ()
+  "Update the cursor type for Xterm-compatible terminals.
+This updates the selected frame's terminal based on `cursor-type'."
+  (let ((buffer-cursor cursor-type)
+        (window-cursor (window-cursor-type))
+        (frame-cursor (frame-parameter nil 'cursor-type))
+        type)
+    ;; All of them can be conses, in which case the type symbol is the car.
+    (when (consp buffer-cursor) (setf buffer-cursor (car buffer-cursor)))
+    (when (consp window-cursor) (setf window-cursor (car window-cursor)))
+    (when (consp frame-cursor) (setf frame-cursor (car frame-cursor)))
+
+    (cond
+     ((not (eq window-cursor t))
+      (setf type window-cursor))
+     ((not (eq buffer-cursor t))
+      (setf type buffer-cursor))
+     (t
+      (setf type frame-cursor)))
+    (xterm--set-cursor-type nil type)))
+
+(defun xterm--update-cursor-color ()
+  "Update the cursor color for Xterm-compatible terminals.
+This updates the selected frame's terminal based on the face `cursor'."
+  (let* ((color (color-values (face-background 'cursor)))
+         (r (nth 0 color))
+         (g (nth 1 color))
+         (b (nth 2 color)))
+    (send-string-to-terminal (format "\e]12;rgb:%04x/%04x/%04x\e\\" r g b))))
+
 (provide 'xterm)                        ;Backward compatibility.
 (provide 'term/xterm)
 ;;; xterm.el ends here