diff lisp/emulation/cua-base.el @ 55267:4a6854d33d2b

* emulation/cua-base.el: Add support for changing cursor types; based on patch from Michael Mauger. (cua-normal-cursor-color, cua-read-only-cursor-color) (cua-overwrite-cursor-color, cua-global-mark-cursor-color): Customization cursor type and/or cursor color. (cua--update-indications): Handle cursor type changes. (cua-mode): Update cursor indications if enabled.

--- a/lisp/emulation/cua-base.el	Fri Apr 30 21:44:12 2004 +0000
+++ b/lisp/emulation/cua-base.el	Fri Apr 30 22:47:38 2004 +0000
@@ -413,29 +413,101 @@
 				       "red")
   "Normal (non-overwrite) cursor color.
 Also used to indicate that rectangle padding is not in effect.
-Default is to load cursor color from initial or default frame parameters."
+Default is to load cursor color from initial or default frame parameters.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected.  If the value is a cursor TYPE (one of: box, block, bar, or hbar),
+then only the `cursor-type' property will be affected.  If the value is
+a cons (TYPE . COLOR), then both properties are affected."
   :initialize 'custom-initialize-default
-  :type 'color
+  :type '(choice
+	  (color :tag "Color")
+	  (choice :tag "Type"
+		  (const :tag "Filled box" box)
+		  (const :tag "Vertical bar" bar)
+		  (const :tag "Horisontal bar" hbar)
+		  (const :tag "Hollow box" block))
+	  (cons :tag "Color and Type"
+		(choice :tag "Type"
+			(const :tag "Filled box" box)
+			(const :tag "Vertical bar" bar)
+			(const :tag "Horisontal bar" hbar)
+			(const :tag "Hollow box" block))
+		(color :tag "Color")))
   :group 'cua)
 
 (defcustom cua-read-only-cursor-color "darkgreen"
   "*Cursor color used in read-only buffers, if non-nil.
-Only used when `cua-enable-cursor-indications' is non-nil."
-  :type 'color
+Only used when `cua-enable-cursor-indications' is non-nil.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected.  If the value is a cursor TYPE (one of: box, block, bar, or hbar),
+then only the `cursor-type' property will be affected.  If the value is
+a cons (TYPE . COLOR), then both properties are affected."
+  :type '(choice
+	  (color :tag "Color")
+	  (choice :tag "Type"
+		  (const :tag "Filled box" box)
+		  (const :tag "Vertical bar" bar)
+		  (const :tag "Horisontal bar" hbar)
+		  (const :tag "Hollow box" block))
+	  (cons :tag "Color and Type"
+		(choice :tag "Type"
+			(const :tag "Filled box" box)
+			(const :tag "Vertical bar" bar)
+			(const :tag "Horisontal bar" hbar)
+			(const :tag "Hollow box" block))
+		(color :tag "Color")))
   :group 'cua)
 
 (defcustom cua-overwrite-cursor-color "yellow"
   "*Cursor color used when overwrite mode is set, if non-nil.
 Also used to indicate that rectangle padding is in effect.
-Only used when `cua-enable-cursor-indications' is non-nil."
-  :type 'color
+Only used when `cua-enable-cursor-indications' is non-nil.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected.  If the value is a cursor TYPE (one of: box, block, bar, or hbar),
+then only the `cursor-type' property will be affected.  If the value is
+a cons (TYPE . COLOR), then both properties are affected."
+  :type '(choice
+	  (color :tag "Color")
+	  (choice :tag "Type"
+		  (const :tag "Filled box" box)
+		  (const :tag "Vertical bar" bar)
+		  (const :tag "Horisontal bar" hbar)
+		  (const :tag "Hollow box" block))
+	  (cons :tag "Color and Type"
+		(choice :tag "Type"
+			(const :tag "Filled box" box)
+			(const :tag "Vertical bar" bar)
+			(const :tag "Horisontal bar" hbar)
+			(const :tag "Hollow box" block))
+		(color :tag "Color")))
   :group 'cua)
 
 (defcustom cua-global-mark-cursor-color "cyan"
   "*Indication for active global mark.
 Will change cursor color to specified color if string.
-Only used when `cua-enable-cursor-indications' is non-nil."
-  :type 'color
+Only used when `cua-enable-cursor-indications' is non-nil.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected.  If the value is a cursor TYPE (one of: box, block, bar, or hbar),
+then only the `cursor-type' property will be affected.  If the value is
+a cons (TYPE . COLOR), then both properties are affected."
+  :type '(choice
+	  (color :tag "Color")
+	  (choice :tag "Type"
+		  (const :tag "Filled box" box)
+		  (const :tag "Vertical bar" bar)
+		  (const :tag "Horisontal bar" hbar)
+		  (const :tag "Hollow box" block))
+	  (cons :tag "Color and Type"
+		(choice :tag "Type"
+			(const :tag "Filled box" box)
+			(const :tag "Vertical bar" bar)
+			(const :tag "Horisontal bar" hbar)
+			(const :tag "Hollow box" block))
+		(color :tag "Color")))
   :group 'cua)
 
 
@@ -946,23 +1018,29 @@
 ;;; Cursor indications
 
 (defun cua--update-indications ()
-  (let ((cursor
-	 (cond
-	  ((and cua--global-mark-active
-		(stringp cua-global-mark-cursor-color))
-	   cua-global-mark-cursor-color)
-	  ((and buffer-read-only
-		(stringp cua-read-only-cursor-color))
-	   cua-read-only-cursor-color)
-	  ((and (stringp cua-overwrite-cursor-color)
-		(or overwrite-mode
-		    (and cua--rectangle (cua--rectangle-padding))))
-	   cua-overwrite-cursor-color)
-	  (t cua-normal-cursor-color))))
-    (if (and cursor
-	     (not (equal cursor (frame-parameter nil 'cursor-color))))
-	(set-cursor-color cursor))
-    cursor))
+  (let* ((cursor
+	  (cond
+	   ((and cua--global-mark-active
+		 cua-global-mark-cursor-color)
+	    cua-global-mark-cursor-color)
+	   ((and buffer-read-only
+		 cua-read-only-cursor-color)
+	    cua-read-only-cursor-color)
+	   ((and cua-overwrite-cursor-color
+		 (or overwrite-mode
+		     (and cua--rectangle (cua--rectangle-padding))))
+	    cua-overwrite-cursor-color)
+	   (t cua-normal-cursor-color)))
+	 (color (if (consp cursor) (cdr cursor) cursor))
+	 (type (if (consp cursor) (car cursor) cursor)))
+    (if (and color
+	     (stringp color)
+	     (not (equal color (frame-parameter nil 'cursor-color))))
+	(set-cursor-color color))
+    (if (and type
+	     (symbolp type)
+	     (not (eq type (frame-parameter nil 'cursor-type))))
+	(setq default-cursor-type type))))
 
 
 ;;; Pre-command hook
@@ -1233,7 +1311,9 @@
 	(add-hook 'post-command-hook 'cua--post-command-handler)
 	(if (and cua-enable-modeline-indications (not (assoc 'cua-mode minor-mode-alist)))
 	    (setq minor-mode-alist (cons '(cua-mode cua--status-string) minor-mode-alist)))
-	)
+	(if cua-enable-cursor-indications
+	    (cua--update-indications)))
+
     (remove-hook 'pre-command-hook 'cua--pre-command-handler)
     (remove-hook 'post-command-hook 'cua--post-command-handler))