cua-mode: cursor types

[Michael Mauger]

Below is a patch for cua-base.el that changes the cursor shape based on
insert/overstrike or read-only state.  The mode already supports changing
the color of the cursor, this patch only adds changing its shape.

It also fixes a bug where the cursor was not being set when the mode
starts up.

My .emacs now sets these as follows:

    (setq cua-normal-cursor-color '(bar . "black")
          cua-overwrite-cursor-color '(box . "red")
          cua-read-only-cursor-color '(block . "blue"))

NB. I tried to change the name of the `cua-*-cursor-color' variables to
`cua-*cursor-style' and then use `defvaralias' to link the old name to
the new, but custom-set-variable wouldn't work.  SHould this have worked?


Index: emacs/lisp/emulation/cua-base.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/emulation/cua-base.el,v
retrieving revision 1.27
diff -u -r1.27 cua-base.el
--- emacs/lisp/emulation/cua-base.el    25 Nov 2003 22:10:52 -0000      1.27
+++ emacs/lisp/emulation/cua-base.el    21 Feb 2004 18:55:44 -0000
@@ -411,30 +411,101 @@
                                            (cdr (assoc 'cursor-color 
default-frame-alist)))
                                       (frame-parameter nil 'cursor-color)
                                       "red")
-  "Normal (non-overwrite) cursor color.
+  "Normal (non-overwrite) cursor color and type.
 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' or `bar'),
+then only the `cursor-type' property will be affected.
+If the value is a cons of (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 "Narrow bar" bar)
+                 (const :tag "Hollow block" block))
+         (cons :tag "Color and Type"
+               (choice :tag "Type"
+                       (const :tag "Filled box" box)
+                       (const :tag "Narrow bar" bar)
+                       (const :tag "Hollow block" block))
+               (color :tag "Color")))
   :group 'cua)
 
 (defcustom cua-read-only-cursor-color "darkgreen"
-  "*Cursor color used in read-only buffers, if non-nil."
-  :type 'color
+  "*Cursor color used in read-only buffers, if 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' or `bar'),
+then only the `cursor-type' property will be affected.
+If the value is a cons of (TYPE . COLOR), then both properties
+are affected."
+  :type '(choice
+         (color :tag "Color")
+         (choice :tag "Type"
+                 (const :tag "Filled box" box)
+                 (const :tag "Narrow bar" bar)
+                 (const :tag "Hollow block" block))
+         (cons :tag "Color and Type"
+               (choice :tag "Type"
+                       (const :tag "Filled box" box)
+                       (const :tag "Narrow bar" bar)
+                       (const :tag "Hollow block" 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."
-  :type 'color
+Also used to indicate that rectangle padding is in effect.
+
+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' or `bar'),
+then only the `cursor-type' property will be affected.
+If the value is a cons of (TYPE . COLOR), then both properties
+are affected."
+  :type '(choice
+         (color :tag "Color")
+         (choice :tag "Type"
+                 (const :tag "Filled box" box)
+                 (const :tag "Narrow bar" bar)
+                 (const :tag "Hollow block" block))
+         (cons :tag "Color and Type"
+               (choice :tag "Type"
+                       (const :tag "Filled box" box)
+                       (const :tag "Narrow bar" bar)
+                       (const :tag "Hollow block" 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."
-  :type 'color
-  :group 'cua)
+Will change cursor color to specified color if string.
 
+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' or `bar'),
+then only the `cursor-type' property will be affected.
+If the value is a cons of (TYPE . COLOR), then both properties
+are affected."
+  :type '(choice
+         (color :tag "Color")
+         (choice :tag "Type"
+                 (const :tag "Filled box" box)
+                 (const :tag "Narrow bar" bar)
+                 (const :tag "Hollow block" block))
+         (cons :tag "Color and Type"
+               (choice :tag "Type"
+                       (const :tag "Filled box" box)
+                       (const :tag "Narrow bar" bar)
+                       (const :tag "Hollow block" block))
+               (color :tag "Color")))
+  :group 'cua)
 
 ;;; Rectangle support is in cua-rect.el
 
@@ -850,7 +921,7 @@
 
 With no prefix argument, clear mark if already set.  Otherwise, set
 mark, and push old mark position on local mark ring; also push mark on
-global mark ring if last mark was set in another buffer.  
+global mark ring if last mark was set in another buffer.
 
 With argument, jump to mark, and pop a new position for mark off
 the local mark ring \(this does not affect the global mark ring\).
@@ -906,19 +977,35 @@
   (let ((cursor
         (cond
          ((and cua--global-mark-active
-               (stringp cua-global-mark-cursor-color))
+               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)
           cua-read-only-cursor-color)
-         ((and (stringp cua-overwrite-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))))
-    (if (and cursor
-            (not (equal cursor (frame-parameter nil 'cursor-color))))
-       (set-cursor-color cursor))
+         (t cua-normal-cursor-color)))
+       color
+       type)
+    (setq color (if (and cursor (consp cursor))
+                   (cdr cursor)
+                 (if (stringp cursor)
+                     cursor)))
+    (setq type (if (and cursor (consp cursor))
+                  (car cursor)
+                (if (symbolp 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))))
+       (modify-frame-parameters nil
+                                (list (cons 'cursor-type type))))
     cursor))
 
 
@@ -1186,7 +1273,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))
 


__________________________________
Do you Yahoo!?
Yahoo! Mail SpamGuard - Read only the mail you want.
http://antispam.yahoo.com/tools