Commit 2ed2415d authored by Kim F. Storm's avatar Kim F. Storm
Browse files

* 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.
parent 4bf6af92
...@@ -413,29 +413,101 @@ Can be toggled by [M-p] while the rectangle is active," ...@@ -413,29 +413,101 @@ Can be toggled by [M-p] while the rectangle is active,"
"red") "red")
"Normal (non-overwrite) cursor color. "Normal (non-overwrite) cursor color.
Also used to indicate that rectangle padding is not in effect. 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 :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) :group 'cua)
(defcustom cua-read-only-cursor-color "darkgreen" (defcustom cua-read-only-cursor-color "darkgreen"
"*Cursor color used in read-only buffers, if non-nil. "*Cursor color used in read-only buffers, if non-nil.
Only used when `cua-enable-cursor-indications' is non-nil." Only used when `cua-enable-cursor-indications' is non-nil.
:type 'color
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) :group 'cua)
(defcustom cua-overwrite-cursor-color "yellow" (defcustom cua-overwrite-cursor-color "yellow"
"*Cursor color used when overwrite mode is set, if non-nil. "*Cursor color used when overwrite mode is set, if non-nil.
Also used to indicate that rectangle padding is in effect. Also used to indicate that rectangle padding is in effect.
Only used when `cua-enable-cursor-indications' is non-nil." Only used when `cua-enable-cursor-indications' is non-nil.
:type 'color
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) :group 'cua)
(defcustom cua-global-mark-cursor-color "cyan" (defcustom cua-global-mark-cursor-color "cyan"
"*Indication for active global mark. "*Indication for active global mark.
Will change cursor color to specified color if string. Will change cursor color to specified color if string.
Only used when `cua-enable-cursor-indications' is non-nil." Only used when `cua-enable-cursor-indications' is non-nil.
:type 'color
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) :group 'cua)
...@@ -946,23 +1018,29 @@ If ARG is the atom `-', scroll upward by nearly full screen." ...@@ -946,23 +1018,29 @@ If ARG is the atom `-', scroll upward by nearly full screen."
;;; Cursor indications ;;; Cursor indications
(defun cua--update-indications () (defun cua--update-indications ()
(let ((cursor (let* ((cursor
(cond (cond
((and cua--global-mark-active ((and cua--global-mark-active
(stringp cua-global-mark-cursor-color)) cua-global-mark-cursor-color)
cua-global-mark-cursor-color) cua-global-mark-cursor-color)
((and buffer-read-only ((and buffer-read-only
(stringp cua-read-only-cursor-color)) 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 (or overwrite-mode
(and cua--rectangle (cua--rectangle-padding)))) (and cua--rectangle (cua--rectangle-padding))))
cua-overwrite-cursor-color) cua-overwrite-cursor-color)
(t cua-normal-cursor-color)))) (t cua-normal-cursor-color)))
(if (and cursor (color (if (consp cursor) (cdr cursor) cursor))
(not (equal cursor (frame-parameter nil 'cursor-color)))) (type (if (consp cursor) (car cursor) cursor)))
(set-cursor-color cursor)) (if (and color
cursor)) (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 ;;; Pre-command hook
...@@ -1233,7 +1311,9 @@ paste (in addition to the normal emacs bindings)." ...@@ -1233,7 +1311,9 @@ paste (in addition to the normal emacs bindings)."
(add-hook 'post-command-hook 'cua--post-command-handler) (add-hook 'post-command-hook 'cua--post-command-handler)
(if (and cua-enable-modeline-indications (not (assoc 'cua-mode minor-mode-alist))) (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))) (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 'pre-command-hook 'cua--pre-command-handler)
(remove-hook 'post-command-hook 'cua--post-command-handler)) (remove-hook 'post-command-hook 'cua--post-command-handler))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment