From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Michael Mauger Newsgroups: gmane.emacs.devel Subject: cua-mode: cursor types Date: Mon, 23 Feb 2004 19:20:32 -0800 (PST) Sender: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Message-ID: <20040224032032.10511.qmail@web60306.mail.yahoo.com> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: sea.gmane.org 1077593094 3460 80.91.224.253 (24 Feb 2004 03:24:54 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Tue, 24 Feb 2004 03:24:54 +0000 (UTC) Original-X-From: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Tue Feb 24 04:24:46 2004 Return-path: Original-Received: from quimby.gnus.org ([80.91.224.244]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1AvTBe-0006dK-00 for ; Tue, 24 Feb 2004 04:24:46 +0100 Original-Received: from monty-python.gnu.org ([199.232.76.173]) by quimby.gnus.org with esmtp (Exim 3.35 #1 (Debian)) id 1AvTBc-000631-00 for ; Tue, 24 Feb 2004 04:24:44 +0100 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.30) id 1AvT8U-0005jB-QL for emacs-devel@quimby.gnus.org; Mon, 23 Feb 2004 22:21:30 -0500 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.30) id 1AvT88-0005i9-Ph for emacs-devel@gnu.org; Mon, 23 Feb 2004 22:21:08 -0500 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.30) id 1AvT7b-0005T4-UQ for emacs-devel@gnu.org; Mon, 23 Feb 2004 22:21:07 -0500 Original-Received: from [216.109.118.117] (helo=web60306.mail.yahoo.com) by monty-python.gnu.org with smtp (Exim 4.30) id 1AvT7b-0005SR-Hl for emacs-devel@gnu.org; Mon, 23 Feb 2004 22:20:35 -0500 Original-Received: from [12.76.164.24] by web60306.mail.yahoo.com via HTTP; Mon, 23 Feb 2004 19:20:32 PST Original-To: emacs-devel@gnu.org X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.2 Precedence: list List-Id: Emacs development discussions. List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+emacs-devel=quimby.gnus.org@gnu.org Xref: main.gmane.org gmane.emacs.devel:20146 X-Report-Spam: http://spam.gmane.org/gmane.emacs.devel:20146 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