From 2ed2415d6d393f8212dcf105d933d67ebd350c1e Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Fri, 30 Apr 2004 22:47:38 +0000 Subject: [PATCH] * 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. --- lisp/emulation/cua-base.el | 132 +++++++++++++++++++++++++++++-------- 1 file changed, 106 insertions(+), 26 deletions(-) diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 0dbfce78870..c32624fe7b7 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -413,29 +413,101 @@ Can be toggled by [M-p] while the rectangle is active," "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 @@ If ARG is the atom `-', scroll upward by nearly full screen." ;;; 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 @@ paste (in addition to the normal emacs bindings)." (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)) -- 2.39.5