Mercurial > emacs
changeset 44938:358d42530d42
Added cua-mode based files [split from original cua.el]:
cua-base.el, cua-rect.el, cua-gmrk.el, and keypad.el
| author | Kim F. Storm <storm@cua.dk> |
|---|---|
| date | Sun, 28 Apr 2002 21:48:39 +0000 |
| parents | 75c89848438b |
| children | d4ace8c553e4 |
| files | lisp/emulation/cua-base.el lisp/emulation/cua-gmrk.el lisp/emulation/cua-rect.el lisp/emulation/keypad.el |
| diffstat | 4 files changed, 3078 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulation/cua-base.el Sun Apr 28 21:48:39 2002 +0000 @@ -0,0 +1,1133 @@ +;;; cua-base.el --- emulate CUA key bindings + +;; Copyright (C) 1997-2002 Free Software Foundation, Inc. + +;; Author: Kim F. Storm <storm@cua.dk> +;; Keywords: keyboard emulation convenience cua + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +;;; Commentary: + +;; This is the CUA package which provides a complete emulation of the +;; standard CUA key bindings (Motif/Windows/Mac GUI) for selecting and +;; manipulating the region where S-<movement> is used to highlight & +;; extend the region. + +;; This package allow the C-z, C-x, C-c, and C-v keys to be +;; bound appropriately according to the Motif/Windows GUI, i.e. +;; C-z -> undo +;; C-x -> cut +;; C-c -> copy +;; C-v -> paste +;; +;; The tricky part is the handling of the C-x and C-c keys which +;; are normally used as prefix keys for most of emacs' built-in +;; commands. With CUA they still do!!! +;; +;; Only when the region is currently active (and highlighted since +;; transient-mark-mode is used), the C-x and C-c keys will work as CUA +;; keys +;; C-x -> cut +;; C-c -> copy +;; When the region is not active, C-x and C-c works as prefix keys! +;; +;; This probably sounds strange and difficult to get used to - but +;; based on my own experience and the feedback from many users of +;; this package, it actually works very well and users adapt to it +;; instantly - or at least very quickly. So give it a try! +;; ... and in the few cases where you make a mistake and accidentally +;; delete the region - you just undo the mistake (with C-z). +;; +;; If you really need to perform a command which starts with one of +;; the prefix keys even when the region is active, you have three options: +;; - press the prefix key twice very quickly (within 0.2 seconds), +;; - press the prefix key and the following key within 0.2 seconds), or +;; - use the SHIFT key with the prefix key, i.e. C-X or C-C +;; +;; This behaviour can be customized via the +;; cua-prefix-override-inhibit-delay variable. + +;; In addition to using the shifted movement keys, you can also use +;; [C-space] to start the region and use unshifted movement keys to extend +;; it. To cancel the region, use [C-space] or [C-g]. + +;; If you prefer to use the standard emacs cut, copy, paste, and undo +;; bindings, customize cua-enable-cua-keys to nil. + +;; CUA mode indications +;; -------------------- +;; You can choose to let CUA use different cursor colors to indicate +;; overwrite mode and read-only buffers. For example, the following +;; setting will use a RED cursor in normal (insertion) mode in +;; read-write buffers, a YELLOW cursor in overwrite mode in read-write +;; buffers, and a GREEN cursor read-only buffers: +;; +;; (setq cua-normal-cursor-color "red") +;; (setq cua-overwrite-cursor-color "yellow") +;; (setq cua-read-only-cursor-color "green") +;; + +;; CUA register support +;; -------------------- +;; Emacs' standard register support is also based on a separate set of +;; "register commands". +;; +;; CUA's register support is activated by providing a numeric +;; prefix argument to the C-x, C-c, and C-v commands. For example, +;; to copy the selected region to register 2, enter [M-2 C-c]. +;; Or if you have activated the keypad prefix mode, enter [kp-2 C-c]. +;; +;; And CUA will copy and paste normal region as well as rectangles +;; into the registers, i.e. you use exactly the same command for both. +;; +;; In addition, the last highlighted text that is deleted (not +;; copied), e.g. by [delete] or by typing text over a highlighted +;; region, is automatically saved in register 0, so you can insert it +;; using [M-0 C-v]. + +;; CUA rectangle support +;; --------------------- +;; Emacs' normal rectangle support is based on interpreting the region +;; between the mark and point as a "virtual rectangle", and using a +;; completely separate set of "rectangle commands" [C-x r ...] on the +;; region to copy, kill, fill a.s.o. the virtual rectangle. +;; +;; cua-mode's superior rectangle support is based on using a true visual +;; representation of the selected rectangle. To start a rectangle, use +;; [S-return] and extend it using the normal movement keys (up, down, +;; left, right, home, end, C-home, C-end). Once the rectangle has the +;; desired size, you can cut or copy it using C-x and C-c (or C-w and M-w), +;; and you can subsequently insert it - as a rectangle - using C-v (or +;; C-y). So the only new command you need to know to work with +;; cua-mode rectangles is S-return! +;; +;; Normally, when you paste a rectangle using C-v (C-y), each line of +;; the rectangle is inserted into the existing lines in the buffer. +;; If overwrite-mode is active when you paste a rectangle, it is +;; inserted as normal (multi-line) text. +;; +;; Furthermore, cua-mode's rectangles are not limited to the actual +;; contents of the buffer, so if the cursor is currently at the end of a +;; short line, you can still extend the rectangle to include more columns +;; of longer lines in the same rectangle. Sounds strange? Try it! +;; +;; You can enable padding for just this rectangle by pressing [M-p]; +;; this works like entering `picture-mode' where the tabs and spaces +;; are automatically converted/inserted to make the rectangle truly +;; rectangular. Or you can do it for all rectangles by setting the +;; `cua-auto-expand-rectangles' variable. + +;; And there's more: If you want to extend or reduce the size of the +;; rectangle in one of the other corners of the rectangle, just use +;; [return] to move the cursor to the "next" corner. Or you can use +;; the [M-up], [M-down], [M-left], and [M-right] keys to move the +;; entire rectangle overlay (but not the contents) in the given +;; direction. +;; +;; [S-return] cancels the rectangle +;; [C-space] activates the region bounded by the rectangle + +;; If you type a normal (self-inserting) character when the rectangle is +;; active, the character is inserted on the "current side" of every line +;; of the rectangle. The "current side" is the side on which the cursor +;; is currently located. If the rectangle is only 1 column wide, +;; insertion will be performed to the left when the cursor is at the +;; bottom of the rectangle. So, for example, to comment out an entire +;; paragraph like this one, just place the cursor on the first character +;; of the first line, and enter the following: +;; S-return M-} ; ; <space> S-return + +;; cua-mode's rectangle support also includes all the normal rectangle +;; functions with easy access: +;; +;; [M-a] aligns all words at the left edge of the rectangle +;; [M-b] fills the rectangle with blanks (tabs and spaces) +;; [M-c] closes the rectangle by removing all blanks at the left edge +;; of the rectangle +;; [M-f] fills the rectangle with a single character (prompt) +;; [M-i] increases the first number found on each line of the rectangle +;; by the amount given by the numeric prefix argument (default 1) +;; It recognizes 0x... as hexadecimal numbers +;; [M-k] kills the rectangle as normal multi-line text (for paste) +;; [M-l] downcases the rectangle +;; [M-m] copies the rectangle as normal multi-line text (for paste) +;; [M-n] fills each line of the rectangle with increasing numbers using +;; a supplied format string (prompt) +;; [M-o] opens the rectangle by moving the highlighted text to the +;; right of the rectangle and filling the rectangle with blanks. +;; [M-p] toggles rectangle padding, i.e. insert tabs and spaces to +;; make rectangles truly rectangular +;; [M-q] performs text filling on the rectangle +;; [M-r] replaces REGEXP (prompt) by STRING (prompt) in rectangle +;; [M-R] reverse the lines in the rectangle +;; [M-s] fills each line of the rectangle with the same STRING (prompt) +;; [M-t] performs text fill of the rectangle with TEXT (prompt) +;; [M-u] upcases the rectangle +;; [M-|] runs shell command on rectangle +;; [M-'] restricts rectangle to lines with CHAR (prompt) at left column +;; [M-/] restricts rectangle to lines matching REGEXP (prompt) +;; [C-?] Shows a brief list of the above commands. + +;; [M-C-up] and [M-C-down] scrolls the lines INSIDE the rectangle up +;; and down; lines scrolled outside the top or bottom of the rectangle +;; are lost, but can be recovered using [C-z]. + +;; CUA Global Mark +;; --------------- +;; The final feature provided by CUA is the "global mark", which +;; makes it very easy to copy bits and pieces from the same and other +;; files into the current text. To enable and cancel the global mark, +;; use [S-C-space]. The cursor will blink when the global mark +;; is active. The following commands behave differently when the global +;; mark is set: +;; <ch> All characters (including newlines) you type are inserted +;; at the global mark! +;; [C-x] If you cut a region or rectangle, it is automatically inserted +;; at the global mark, and the global mark is advanced. +;; [C-c] If you copy a region or rectangle, it is immediately inserted +;; at the global mark, and the global mark is advanced. +;; [C-v] Copies a single character to the global mark. +;; [C-d] Moves (i.e. deletes and inserts) a single character to the +;; global mark. +;; [backspace] deletes the character before the global mark, while +;; [delete] deltes the character after the global mark. + +;; [S-C-space] Jumps to and cancels the global mark. +;; [C-u S-C-space] Cancels the global mark (stays in current buffer). + +;; [TAB] Indents the current line or rectangle to the column of the +;; global mark. + +;;; Code: + +;;; Customization + +(defgroup cua nil + "Emulate CUA key bindings including C-x and C-c." + :prefix "cua" + :group 'editing-basics + :group 'convenience + :group 'emulations + :link '(emacs-commentary-link :tag "Commentary" "cua-base.el") + :link '(emacs-library-link :tag "Lisp File" "cua-base.el")) + +;;;###autoload +(defcustom cua-mode nil + "Non-nil means that CUA emulation mode is enabled. +In CUA mode, shifted movement keys highlight and extend the region. +When a region is highlighted, the binding of the C-x and C-c keys are +temporarily changed to work as Motif, MAC or MS-Windows cut and paste. +Also, insertion commands first delete the region and then insert. +This mode enables Transient Mark mode and it provides a superset of the +PC Selection Mode and Delete Selection Modes. + +Setting this variable directly does not take effect; +use either \\[customize] or the function `cua-mode'." + :set (lambda (symbol value) + (cua-mode (or value 0))) + :initialize 'custom-initialize-default + :set-after '(cua-enable-modeline-indications cua-use-hyper-key) + :require 'cua + :link '(emacs-commentary-link "cua-base.el") + :version "21.4" + :type 'boolean + :group 'cua) + + +(defcustom cua-enable-cua-keys t + "*Enable using C-z, C-x, C-c, and C-v for undo, cut, copy, and paste. +If the value is t, these mappings are always enabled. If the value is +'shift, these keys are only enabled if the last region was marked with +a shifted movement key. If the value is nil, these keys are never +enabled." + :type '(choice (const :tag "Disabled" nil) + (const :tag "Shift region only" shift) + (other :tag "Enabled")) + :group 'cua) + +(defcustom cua-highlight-region-shift-only nil + "*If non-nil, only highlight region if marked with S-<move>. +When this is non-nil, CUA toggles `transient-mark-mode' on when the region +is marked using shifted movement keys, and off when the mark is cleared. +But when the mark was set using \\[cua-set-mark], transient-mark-mode +is not turned on." + :type 'boolean + :group 'cua) + +(defcustom cua-prefix-override-inhibit-delay + (if (featurep 'lisp-float-type) (/ (float 1) (float 5)) nil) + "*If non-nil, time in seconds to delay before overriding prefix key. +If there is additional input within this time, the prefix key is +used as a normal prefix key. So typing a key sequence quickly will +inhibit overriding the prefix key. +As a special case, if the prefix keys repeated within this time, the +first prefix key is discarded, so typing a prefix key twice in quick +succession will also inhibit overriding the prefix key. +If the value is nil, use a shifted prefix key to inhibit the override." + :type '(choice (number :tag "Inhibit delay") + (const :tag "No delay" nil)) + :group 'cua) + +(defcustom cua-keep-region-after-copy nil + "If non-nil, don't deselect the region after copying." + :type 'boolean + :group 'cua) + +(defcustom cua-enable-register-prefix 'not-ctrl-u + "*If non-nil, registers are supported via numeric prefix arg. +If the value is t, any numeric prefix arg in the range 0 to 9 will be +interpreted as a register number. +If the value is not-ctrl-u, using C-u to enter a numeric prefix is not +interpreted as a register number. +If the value is ctrl-u-only, only numeric prefix entered with C-u is +interpreted as a register number." + :type '(choice (const :tag "Disabled" nil) + (const :tag "Enabled, but C-u arg is not a register" not-ctrl-u) + (const :tag "Enabled, but only for C-u arg" ctrl-u-only) + (other :tag "Enabled")) + :group 'cua) + +(defcustom cua-delete-copy-to-register-0 t + "*If non-nil, save last deleted region or rectangle to register 0." + :type 'boolean + :group 'cua) + +(defcustom cua-use-hyper-key nil + "*If non-nil, bind rectangle commands to H-? instead of M-?. +If set to 'also, toggle region command is also on S-return. +Must be set prior to enabling CUA." + :type '(choice (const :tag "Meta key and S-return" nil) + (const :tag "Hyper key only" only) + (const :tag "Hyper key and S-return" also)) + :group 'cua) + +(defcustom cua-enable-region-auto-help nil + "*If non-nil, automatically show help for active region." + :type 'boolean + :group 'cua) + +(defcustom cua-enable-modeline-indications nil + "*If non-nil, use minor-mode hook to show status in mode line." + :type 'boolean + :group 'cua) + +(defcustom cua-check-pending-input t + "*If non-nil, don't override prefix key if input pending. +It is rumoured that input-pending-p is unreliable under some window +managers, so try setting this to nil, if prefix override doesn't work." + :type 'boolean + :group 'cua) + + +;;; Rectangle Customization + +(defcustom cua-auto-expand-rectangles nil + "*If non-nil, rectangles are padded with spaces to make straight edges. +This implies modifying buffer contents by expanding tabs and inserting spaces. +Consequently, this is inhibited in read-only buffers. +Can be toggled by [M-p] while the rectangle is active," + :type 'boolean + :group 'cua) + +(defcustom cua-enable-rectangle-auto-help t + "*If non-nil, automatically show help for region, rectangle and global mark." + :type 'boolean + :group 'cua) + +(defface cua-rectangle-face 'nil + "*Font used by CUA for highlighting the rectangle." + :group 'cua) + +(defface cua-rectangle-noselect-face 'nil + "*Font used by CUA for highlighting the non-selected rectangle lines." + :group 'cua) + +(defcustom cua-undo-max 64 + "*Max no of undoable CUA rectangle changes (including undo)." + :type 'integer + :group 'cua) + + +;;; Global Mark Customization + +(defcustom cua-global-mark-keep-visible t + "*If non-nil, always keep global mark visible in other window." + :type 'boolean + :group 'cua) + +(defface cua-global-mark-face '((((class color)) + (:foreground "black") + (:background "yellow")) + (t (:bold t))) + "*Font used by CUA for highlighting the global mark." + :group 'cua) + +(defcustom cua-global-mark-blink-cursor-interval 0.20 + "*Blink cursor at this interval when global mark is active." + :type '(choice (number :tag "Blink interval") + (const :tag "No blink" nil)) + :group 'cua) + + +;;; Cursor Indication Customization + +(defcustom cua-enable-cursor-indications t + "*If non-nil, use different cursor colors for indications." + :type 'boolean + :group 'cua) + +(defcustom cua-normal-cursor-color nil + "Normal (non-overwrite) cursor color. +Also used to indicate that rectangle padding is not in effect. +Automatically loaded from frame parameters, if nil." + :initialize (lambda (symbol value) + (set symbol (or value + (and (boundp 'initial-cursor-color) initial-cursor-color) + (and (boundp 'initial-frame-alist) + (assoc 'cursor-color initial-frame-alist) + (cdr (assoc 'cursor-color initial-frame-alist))) + (and (boundp 'default-frame-alist) + (assoc 'cursor-color default-frame-alist) + (cdr (assoc 'cursor-color default-frame-alist))) + (frame-parameter nil 'cursor-color)))) + :type 'color + :group 'cua) + +(defcustom cua-read-only-cursor-color "darkgreen" + "*Cursor color used in read-only buffers, if non-nil." + :type '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 + :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) + + +;;; Rectangle support is in cua-rect.el + +(autoload 'cua-set-rectangle-mark "cua-rect" nil t nil) + +;; Stub definitions until it is loaded + +(when (not (featurep 'cua-rect)) + (defvar cua--rectangle) + (setq cua--rectangle nil) + (defvar cua--last-killed-rectangle) + (setq cua--last-killed-rectangle nil)) + + + +;;; Global Mark support is in cua-gmrk.el + +(autoload 'cua-toggle-global-mark "cua-gmrk.el" nil t nil) + +;; Stub definitions until cua-gmrk.el is loaded + +(when (not (featurep 'cua-gmrk)) + (defvar cua--global-mark-active) + (setq cua--global-mark-active nil)) + + +(provide 'cua-base) + +(eval-when-compile + (require 'cua-rect) + (require 'cua-gmrk) + ) + +;;; Aux. variables + +;; Current region was started using cua-set-mark. +(defvar cua--explicit-region-start nil) + +;; Latest region was started using shifted movement command. +(defvar cua--last-region-shifted nil) + +;; buffer + point prior to current command when rectangle is active +;; checked in post-command hook to see if point was moved +(defvar cua--buffer-and-point-before-command nil) + +;; status string for mode line indications +(defvar cua--status-string nil) + +(defvar cua--debug nil) + + +;;; Prefix key override mechanism + +;; The prefix override (when mark-active) operates in three substates: +;; [1] Before using a prefix key +;; [2] Immediately after using a prefix key +;; [3] A fraction of a second later + +;; In state [1], the cua--prefix-override-keymap is active. +;; This keymap binds the C-x and C-c prefix keys to the +;; cua--prefix-override-handler function. + +;; When a prefix key is typed in state [1], cua--prefix-override-handler +;; will push back the keys already read to the event queue. If input is +;; pending, it changes directly to state [3]. Otherwise, a short timer [T] +;; is started, and it changes to state [2]. + +;; In state [2], the cua--prefix-override-keymap is inactive. Instead the +;; cua--prefix-repeat-keymap is active. This keymap binds C-c C-c and C-x +;; C-x to the cua--prefix-repeat-handler function. + +;; If the prefix key is repeated in state [2], cua--prefix-repeat-handler +;; will cancel [T], back the keys already read (except for the second prefix +;; keys) to the event queue, and changes to state [3]. + +;; The basic cua--cua-keys-keymap binds [C-x timeout] to kill-region and +;; [C-c timeout] to copy-region-as-kill, so if [T] times out in state [2], +;; the cua--prefix-override-timeout function will push a `timeout' event on +;; the event queue, and changes to state [3]. + +;; In state [3] both cua--prefix-override-keymap and cua--prefix-repeat-keymap +;; are inactive, so the timeout in cua-global-keymap binding is used, or the +;; normal prefix key binding from the global or local map will be used. + +;; The pre-command hook (executed as a consequence of the timeout or normal +;; prefix key binding) will cancel [T] and change from state [3] back to +;; state [1]. So cua--prefix-override-handler and cua--prefix-repeat-handler +;; are always called with state reset to [1]! + +;; State [1] is recognized by cua--prefix-override-timer is nil, +;; state [2] is recognized by cua--prefix-override-timer is a timer, and +;; state [3] is recognized by cua--prefix-override-timer is t. + +(defvar cua--prefix-override-timer nil) +(defvar cua--prefix-override-length nil) + +(defun cua--prefix-override-replay (arg repeat) + (let* ((keys (this-command-keys)) + (i (length keys)) + (key (aref keys (1- i)))) + (setq cua--prefix-override-length (- i repeat)) + (setq cua--prefix-override-timer + (or + ;; In state [2], change to state [3] + (> repeat 0) + ;; In state [1], change directly to state [3] + (and cua-check-pending-input (input-pending-p)) + ;; In state [1], [T] disabled, so change to state [3] + (not (numberp cua-prefix-override-inhibit-delay)) + (<= cua-prefix-override-inhibit-delay 0) + ;; In state [1], start [T] and change to state [2] + (run-with-timer cua-prefix-override-inhibit-delay nil + 'cua--prefix-override-timeout))) + ;; Don't record this command + (setq this-command last-command) + ;; Restore the prefix arg + (setq prefix-arg arg) + (reset-this-command-lengths) + ;; Push the key back on the event queue + (setq unread-command-events (cons key unread-command-events)))) + +(defun cua--prefix-override-handler (arg) + "Start timer waiting for prefix key to be followed by another key. +Repeating prefix key when region is active works as a single prefix key." + (interactive "P") + (cua--prefix-override-replay arg 0)) + +(defun cua--prefix-repeat-handler (arg) + "Repeating prefix key when region is active works as a single prefix key." + (interactive "P") + (cua--prefix-override-replay arg 1)) + +(defun cua--prefix-copy-handler (arg) + "Copy region/rectangle, then replay last key." + (interactive "P") + (if cua--rectangle + (cua-copy-rectangle arg) + (cua-copy-region arg)) + (let ((keys (this-single-command-keys))) + (setq unread-command-events + (cons (aref keys (1- (length keys))) unread-command-events)))) + +(defun cua--prefix-cut-handler (arg) + "Cut region/rectangle, then replay last key." + (interactive "P") + (if cua--rectangle + (cua-cut-rectangle arg) + (cua-cut-region arg)) + (let ((keys (this-single-command-keys))) + (setq unread-command-events + (cons (aref keys (1- (length keys))) unread-command-events)))) + +(defun cua--prefix-override-timeout () + (setq cua--prefix-override-timer t) + (when (= (length (this-command-keys)) cua--prefix-override-length) + (setq unread-command-events (cons 'timeout unread-command-events)) + (if prefix-arg + (reset-this-command-lengths) + (setq overriding-terminal-local-map nil)) + (cua--fix-keymaps nil))) + + +;;; Aux. functions + +(defun cua--fallback () + ;; Execute original command + (setq this-command this-original-command) + (call-interactively this-command)) + +(defun cua--keep-active () + (setq mark-active t + deactivate-mark nil)) + +(defun cua--deactivate (&optional now) + (setq cua--explicit-region-start nil) + (if (not now) + (setq deactivate-mark t) + (setq mark-active nil) + (run-hooks 'deactivate-mark-hook))) + + +;; The current register prefix +(defvar cua--register nil) + +(defun cua--prefix-arg (arg) + (setq cua--register + (and cua-enable-register-prefix + (integerp (this-command-keys)) + (cond ((eq cua-enable-register-prefix 'not-ctrl-u) + (not (= (aref (this-command-keys) 0) ?\C-u))) + ((eq cua-enable-register-prefix 'ctrl-u-only) + (= (aref (this-command-keys) 0) ?\C-u)) + (t t)) + (integerp arg) (>= arg 0) (< arg 10) + (+ arg ?0))) + (if cua--register nil arg)) + + +;;; Enhanced undo - restore rectangle selections + +(defun cua-undo (&optional arg) + "Undo some previous changes. +Knows about CUA rectangle highlighting in addition to standard undo." + (interactive "*P") + (if (fboundp 'cua--rectangle-undo) + (cua--rectangle-undo arg) + (undo arg))) + +;;; Region specific commands + +(defun cua-delete-region () + "Delete the active region. +Save a copy in register 0 if `cua-delete-copy-to-register-0' is non-nil." + (interactive) + (let ((start (mark)) (end (point))) + (or (<= start end) + (setq start (prog1 end (setq end start)))) + (if cua-delete-copy-to-register-0 + (copy-to-register ?0 start end nil)) + (delete-region start end) + (cua--deactivate))) + +(defun cua-replace-region () + "Replace the active region with the character you type." + (interactive) + (cua-delete-region) + (if (not (eq this-original-command this-command)) + (cua--fallback))) + +(defun cua-copy-region (arg) + "Copy the region to the kill ring. +With numeric prefix arg, copy to register 0-9 instead." + (interactive "P") + (setq arg (cua--prefix-arg arg)) + (setq cua--last-killed-rectangle nil) + (let ((start (mark)) (end (point))) + (or (<= start end) + (setq start (prog1 end (setq end start)))) + (if cua--register + (copy-to-register cua--register start end nil) + (copy-region-as-kill start end)) + (if cua-keep-region-after-copy + (cua--keep-active) + (cua--deactivate)))) + +(defun cua-cut-region (arg) + "Cut the region and copy to the kill ring. +With numeric prefix arg, copy to register 0-9 instead." + (interactive "P") + (setq cua--last-killed-rectangle nil) + (if buffer-read-only + (cua-copy-region arg) + (setq arg (cua--prefix-arg arg)) + (let ((start (mark)) (end (point))) + (or (<= start end) + (setq start (prog1 end (setq end start)))) + (if cua--register + (copy-to-register cua--register start end t) + (kill-region start end))) + (cua--deactivate))) + +;;; Generic commands for regions, rectangles, and global marks + +(defun cua-cancel () + "Cancel the active region, rectangle, or global mark." + (interactive) + (setq mark-active nil) + (setq cua--explicit-region-start nil) + (if (fboundp 'cua--cancel-rectangle) + (cua--cancel-rectangle))) + +(defun cua-paste (arg) + "Paste last cut or copied region or rectangle. +An active region is deleted before executing the command. +With numeric prefix arg, paste from register 0-9 instead. +If global mark is active, copy from register or one character." + (interactive "P") + (setq arg (cua--prefix-arg arg)) + (let ((regtxt (and cua--register (get-register cua--register))) + (count (prefix-numeric-value arg))) + (cond + ((and cua--register (not regtxt)) + (message "Nothing in register %c" cua--register)) + (cua--global-mark-active + (if regtxt + (cua--insert-at-global-mark regtxt) + (when (not (eobp)) + (cua--insert-at-global-mark (buffer-substring (point) (+ (point) count))) + (forward-char count)))) + (buffer-read-only + (message "Cannot paste into a read-only buffer")) + (t + ;; Must save register here, since delete may override reg 0. + (if mark-active + ;; Before a yank command, make sure we don't yank + ;; the same region that we are going to delete. + ;; That would make yank a no-op. + (if cua--rectangle + (cua--delete-rectangle) + (if (string= (buffer-substring (point) (mark)) + (car kill-ring)) + (current-kill 1)) + (cua-delete-region))) + (cond + (regtxt + (cond + ((consp regtxt) (cua--insert-rectangle regtxt)) + ((stringp regtxt) (insert-for-yank regtxt)) + (t (message "Unknown data in register %c" cua--register)))) + ((and cua--last-killed-rectangle + (eq (and kill-ring (car kill-ring)) (car cua--last-killed-rectangle))) + (let ((pt (point))) + (when (not (eq buffer-undo-list t)) + (setq this-command 'cua--paste-rectangle) + (undo-boundary) + (setq buffer-undo-list (cons pt buffer-undo-list))) + (cua--insert-rectangle (cdr cua--last-killed-rectangle)) + (if arg (goto-char pt)))) + (t (yank arg))))))) + +(defun cua-paste-pop (arg) + "Replace a just-pasted text or rectangle with a different text. +See `yank-pop' for details." + (interactive "P") + (if (eq last-command 'cua--paste-rectangle) + (progn + (undo) + (yank arg)) + (yank-pop (prefix-numeric-value arg)))) + +(defun cua-exchange-point-and-mark (arg) + "Exchanges point and mark, but don't activate the mark. +Activates the mark if a prefix argument is given." + (interactive "P") + (if arg + (setq mark-active t) + (let (mark-active) + (exchange-point-and-mark) + (if cua--rectangle + (cua--rectangle-corner 0))))) + +(defun cua-help-for-region (&optional help) + "Show region specific help in echo area." + (interactive) + (message + (concat (if help "C-?:help " "") + "C-z:undo C-x:cut C-c:copy C-v:paste S-ret:rect"))) + + +;;; Shift activated / extended region + +(defun cua-set-mark (&optional arg) + "Set mark at where point is, clear mark, or jump to mark. +With no prefix argument, set mark, push old mark position on local mark +ring, and push mark on global mark ring, or if mark is already set, clear mark. +With argument, jump to mark, and pop a new position for mark off the ring; +then it jumps to the next mark off the ring if repeated with no argument, or +sets the mark at the new position if repeated with argument." + (interactive "P") + (if (and (eq this-command last-command) + last-prefix-arg) + (setq arg (if arg nil last-prefix-arg) + current-prefix-arg arg)) + (cond + (arg + (if (null (mark t)) + (error "No mark set in this buffer") + (goto-char (mark t)) + (pop-mark))) + (mark-active + (cua--deactivate) + (message "Mark Cleared")) + (t + (push-mark nil nil t) + (setq cua--explicit-region-start t) + (setq cua--last-region-shifted nil) + (if cua-enable-region-auto-help + (cua-help-for-region t))))) + +(defvar cua--standard-movement-commands + '(forward-char backward-char + next-line previous-line + forward-word backward-word + end-of-line beginning-of-line + end-of-buffer beginning-of-buffer + scroll-up scroll-down forward-paragraph backward-paragraph) + "List of standard movement commands. +Extra commands should be added to `cua-user-movement-commands'") + +(defvar cua-movement-commands nil + "User may add additional movement commands to this list.") + + +;;; 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)) + + +;;; Pre-command hook + +(defun cua--pre-command-handler () + (condition-case nil + (let ((movement (or (memq this-command cua--standard-movement-commands) + (memq this-command cua-movement-commands)))) + + ;; Cancel prefix key timeout if user enters another key. + (when cua--prefix-override-timer + (if (timerp cua--prefix-override-timer) + (cancel-timer cua--prefix-override-timer)) + (setq cua--prefix-override-timer nil)) + + ;; Handle shifted cursor keys and other movement commands. + ;; If region is not active, region is activated if key is shifted. + ;; If region is active, region is cancelled if key is unshifted (and region not started with C-SPC). + ;; If rectangle is active, expand rectangle in specified direction and ignore the movement. + (if movement + (cond + ((memq 'shift (event-modifiers (aref (this-single-command-raw-keys) 0))) + (unless mark-active + (push-mark nil t t)) + (setq cua--last-region-shifted t) + (setq cua--explicit-region-start nil)) + ((or cua--explicit-region-start cua--rectangle) + (unless mark-active + (push-mark nil nil t))) + (t + ;; If we set mark-active to nil here, the region highlight will not be + ;; removed by the direct_output_ commands. + (setq deactivate-mark t))) + + ;; Handle delete-selection property on other commands + (let* ((ds (or (get this-command 'delete-selection) + (get this-command 'pending-delete))) + (nc (cond + ((eq ds 'yank) + 'cua-paste) + ((eq ds 'kill) + (if cua--rectangle + 'cua-copy-rectangle + 'cua-copy-region)) + ((eq ds 'supersede) + (if cua--rectangle + 'cua-delete-rectangle ;; replace? + 'cua-replace-region)) + (ds + (if cua--rectangle + 'cua-delete-rectangle + 'cua-delete-region)) + (t nil)))) + (if nc + (setq this-original-command this-command + this-command nc)))) + + ;; Detect extension of rectangles by mouse or other movement + (setq cua--buffer-and-point-before-command + (if cua--rectangle (cons (current-buffer) (point)))) + ) + (error nil))) + +;;; Post-command hook + +(defun cua--post-command-handler () + (condition-case nil + (progn + (when cua--global-mark-active + (cua--global-mark-post-command)) + (when (fboundp 'cua--rectangle-post-command) + (cua--rectangle-post-command)) + (setq cua--buffer-and-point-before-command nil) + (if (or (not mark-active) deactivate-mark) + (setq cua--explicit-region-start nil)) + + ;; Debugging + (if cua--debug + (cond + (cua--rectangle (cua--rectangle-assert)) + (mark-active (message "Mark=%d Point=%d Expl=%s" + (mark t) (point) cua--explicit-region-start)))) + + ;; Disable transient-mark-mode if rectangle active in current buffer. + (if (not (window-minibuffer-p (selected-window))) + (setq transient-mark-mode (and (not cua--rectangle) + (if cua-highlight-region-shift-only + (not cua--explicit-region-start) + t)))) + (if cua-enable-cursor-indications + (cua--update-indications)) + + (cua--fix-keymaps nil) + ) + + (error nil))) + + +;;; Keymaps + +(defun cua--M/H-key (map key fct) + ;; bind H-KEY or M-KEY to FCT in MAP + (if (eq key 'space) (setq key ? )) + (unless (listp key) (setq key (list key))) + (define-key map (vector (cons (if cua-use-hyper-key 'hyper 'meta) key)) fct)) + +(defvar cua-global-keymap (make-sparse-keymap)) +(defvar cua--cua-keys-keymap (make-sparse-keymap)) +(defvar cua--prefix-override-keymap (make-sparse-keymap)) +(defvar cua--prefix-repeat-keymap (make-sparse-keymap)) +(defvar cua--global-mark-keymap (make-sparse-keymap)) ; Initalized when cua-gmrk.el is loaded +(defvar cua--rectangle-keymap (make-sparse-keymap)) ; Initalized when cua-rect.el is loaded +(defvar cua--region-keymap (make-sparse-keymap)) + +(defvar cua--ena-cua-keys-keymap nil) +(defvar cua--ena-prefix-override-keymap nil) +(defvar cua--ena-prefix-repeat-keymap nil) +(defvar cua--ena-region-keymap nil) +(defvar cua--ena-global-mark-keymap nil) + +(defvar cua--mmap-prefix-override-keymap (cons 'cua--ena-prefix-override-keymap cua--prefix-override-keymap)) +(defvar cua--mmap-prefix-repeat-keymap (cons 'cua--ena-prefix-repeat-keymap cua--prefix-repeat-keymap)) +(defvar cua--mmap-cua-keys-keymap (cons 'cua--ena-cua-keys-keymap cua--cua-keys-keymap)) +(defvar cua--mmap-global-mark-keymap (cons 'cua--ena-global-mark-keymap cua--global-mark-keymap)) +(defvar cua--mmap-rectangle-keymap (cons 'cua--rectangle cua--rectangle-keymap)) +(defvar cua--mmap-region-keymap (cons 'cua--ena-region-keymap cua--region-keymap)) +(defvar cua--mmap-global-keymap (cons 'cua-mode cua-global-keymap)) + +(defvar cua--mmap-list + (list cua--mmap-prefix-override-keymap + cua--mmap-prefix-repeat-keymap + cua--mmap-cua-keys-keymap + cua--mmap-global-mark-keymap + cua--mmap-rectangle-keymap + cua--mmap-region-keymap + cua--mmap-global-keymap)) + +(defun cua--fix-keymaps (disable) + ;; Ensure that cua's keymaps are in minor-mode-map-alist and + ;; in the correct order. + (let (fix + (mmap minor-mode-map-alist) + (ml cua--mmap-list)) + (while (and (not fix) mmap ml) + (if (not (eq (car mmap) (car ml))) + (setq fix t) + (setq mmap (cdr mmap) + ml (cdr ml)))) + (if ml + (setq fix t)) + (when (or fix disable) + (setq ml cua--mmap-list) + (while ml + (setq minor-mode-map-alist (delq (car ml) minor-mode-map-alist)) + (setq ml (cdr ml)))) + (when (and fix (not disable)) + (setq minor-mode-map-alist + (append (copy-sequence cua--mmap-list) minor-mode-map-alist)))) + (setq cua--ena-region-keymap + (and mark-active (not deactivate-mark))) + (setq cua--ena-prefix-override-keymap + (and cua--ena-region-keymap + cua-enable-cua-keys + (or (eq cua-enable-cua-keys t) + (not cua--explicit-region-start)) + (not executing-kbd-macro) + (not cua--prefix-override-timer))) + (setq cua--ena-prefix-repeat-keymap + (and cua--ena-region-keymap + (timerp cua--prefix-override-timer))) + (setq cua--ena-cua-keys-keymap + (and cua-enable-cua-keys + (or (eq cua-enable-cua-keys t) + cua--last-region-shifted))) + (setq cua--ena-global-mark-keymap + (and cua--global-mark-active + (not (window-minibuffer-p))))) + +(defvar cua--keymaps-initalized nil) + +(defun cua--init-keymaps () + (unless (eq cua-use-hyper-key 'only) + (define-key cua-global-keymap [(shift return)] 'cua-set-rectangle-mark)) + (when cua-use-hyper-key + (cua--M/H-key cua-global-keymap 'space 'cua-set-rectangle-mark) + (define-key cua-global-keymap [(hyper mouse-1)] 'cua-mouse-set-rectangle-mark)) + + (define-key cua-global-keymap [(shift control ? )] 'cua-toggle-global-mark) + + ;; replace region with rectangle or element on kill ring + (define-key cua-global-keymap [remap yank] 'cua-paste) + (define-key cua-global-keymap [remap clipboard-yank] 'cua-paste) + ;; replace current yank with previous kill ring element + (define-key cua-global-keymap [remap yank-pop] 'cua-paste-pop) + ;; set mark + (define-key cua-global-keymap [remap set-mark-command] 'cua-set-mark) + ;; undo + (define-key cua-global-keymap [remap undo] 'cua-undo) + (define-key cua-global-keymap [remap advertised-undo] 'cua-undo) + + (define-key cua--cua-keys-keymap [(control x) timeout] 'kill-region) + (define-key cua--cua-keys-keymap [(shift control x)] 'Control-X-prefix) + (define-key cua--cua-keys-keymap [(control c) timeout] 'copy-region-as-kill) + (define-key cua--cua-keys-keymap [(shift control c)] 'mode-specific-command-prefix) + (define-key cua--cua-keys-keymap [(control z)] 'undo) + (define-key cua--cua-keys-keymap [(control v)] 'yank) + (define-key cua--cua-keys-keymap [remap exchange-point-and-mark] 'cua-exchange-point-and-mark) + + (define-key cua--prefix-override-keymap [(control x)] 'cua--prefix-override-handler) + (define-key cua--prefix-override-keymap [(control c)] 'cua--prefix-override-handler) + + (define-key cua--prefix-repeat-keymap [(control x) (control x)] 'cua--prefix-repeat-handler) + (define-key cua--prefix-repeat-keymap [(control x) up] 'cua--prefix-cut-handler) + (define-key cua--prefix-repeat-keymap [(control x) down] 'cua--prefix-cut-handler) + (define-key cua--prefix-repeat-keymap [(control x) left] 'cua--prefix-cut-handler) + (define-key cua--prefix-repeat-keymap [(control x) right] 'cua--prefix-cut-handler) + (define-key cua--prefix-repeat-keymap [(control c) (control c)] 'cua--prefix-repeat-handler) + (define-key cua--prefix-repeat-keymap [(control c) up] 'cua--prefix-copy-handler) + (define-key cua--prefix-repeat-keymap [(control c) down] 'cua--prefix-copy-handler) + (define-key cua--prefix-repeat-keymap [(control c) left] 'cua--prefix-copy-handler) + (define-key cua--prefix-repeat-keymap [(control c) right] 'cua--prefix-copy-handler) + + ;; replace current region + (define-key cua--region-keymap [remap self-insert-command] 'cua-replace-region) + (define-key cua--region-keymap [remap self-insert-iso] 'cua-replace-region) + (define-key cua--region-keymap [remap insert-register] 'cua-replace-region) + (define-key cua--region-keymap [remap newline-and-indent] 'cua-replace-region) + (define-key cua--region-keymap [remap newline] 'cua-replace-region) + (define-key cua--region-keymap [remap open-line] 'cua-replace-region) + ;; delete current region + (define-key cua--region-keymap [remap delete-backward-char] 'cua-delete-region) + (define-key cua--region-keymap [remap backward-delete-char] 'cua-delete-region) + (define-key cua--region-keymap [remap backward-delete-char-untabify] 'cua-delete-region) + (define-key cua--region-keymap [remap delete-char] 'cua-delete-region) + ;; kill region + (define-key cua--region-keymap [remap kill-region] 'cua-cut-region) + ;; copy region + (define-key cua--region-keymap [remap copy-region-as-kill] 'cua-copy-region) + (define-key cua--region-keymap [remap kill-ring-save] 'cua-copy-region) + ;; cancel current region/rectangle + (define-key cua--region-keymap [remap keyboard-escape-quit] 'cua-cancel) + (define-key cua--region-keymap [remap keyboard-quit] 'cua-cancel) + ) + + +;;;###autoload +(defun cua-mode (&optional arg) + "Toggle CUA key-binding mode. +When enabled, using shifted movement keys will activate the region (and +highlight the region using `transient-mark-mode'), and typed text replaces +the active selection. C-z, C-x, C-c, and C-v will undo, cut, copy, and +paste (in addition to the normal emacs bindings)." + (interactive "P") + (setq cua-mode + (cond + ((null arg) (not cua-mode)) + ((symbolp arg) t) + (t (> (prefix-numeric-value arg) 0)))) + + (setq mark-even-if-inactive t) + (setq highlight-nonselected-windows nil) + (make-variable-buffer-local 'cua--explicit-region-start) + (make-variable-buffer-local 'cua--status-string) + + (unless cua--keymaps-initalized + (cua--init-keymaps) + (setq cua--keymaps-initalized t)) + + (if cua-mode + (progn + (add-hook 'pre-command-hook 'cua--pre-command-handler) + (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))) + ) + (remove-hook 'pre-command-hook 'cua--pre-command-handler) + (remove-hook 'post-command-hook 'cua--post-command-handler)) + (cua--fix-keymaps (not cua-mode)) + (if (fboundp 'cua--rectangle-on-off) + (cua--rectangle-on-off cua-mode)) + (setq transient-mark-mode (and cua-mode + (if cua-highlight-region-shift-only + (not cua--explicit-region-start) + t)))) + +(defun cua-debug () + "Toggle cua debugging." + (interactive) + (setq cua--debug (not cua--debug))) + +;;; cua-base.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulation/cua-gmrk.el Sun Apr 28 21:48:39 2002 +0000 @@ -0,0 +1,385 @@ +;;; cua-gmrk.el --- CUA unified global mark support + +;; Copyright (C) 1997-2002 Free Software Foundation, Inc. + +;; Author: Kim F. Storm <storm@cua.dk> +;; Keywords: keyboard emulations convenience cua mark + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + + +(provide 'cua-gmrk) + +(eval-when-compile + (require 'cua-base) + (require 'cua-rect) + ) + +;;; Global Marker + +;; Non-nil when global marker is active. +(defvar cua--global-mark-active nil) + +;; Global mark position marker. +(defvar cua--global-mark-marker nil) + +;; Overlay for global mark position. +(defvar cua--global-mark-overlay nil) + +;; Initialize global mark things once... +(defvar cua--global-mark-initialized nil) + +;; Saved configured blink-cursor-interval +(defvar cua--orig-blink-cursor-interval nil) + +(defun cua--deactivate-global-mark (&optional msg) + (when cua--global-mark-overlay + (delete-overlay cua--global-mark-overlay) + (setq cua--global-mark-overlay nil)) + (if (markerp cua--global-mark-marker) + (move-marker cua--global-mark-marker nil)) + (if cua--orig-blink-cursor-interval + (setq blink-cursor-interval cua--orig-blink-cursor-interval + cua--orig-blink-cursor-interval nil)) + (setq cua--global-mark-active nil) + (if msg + (message "Global Mark Cleared"))) + +(defun cua--activate-global-mark (&optional msg) + (if (not (markerp cua--global-mark-marker)) + (setq cua--global-mark-marker (make-marker))) + (when (eobp) + (insert " ") + (backward-char 1)) + (move-marker cua--global-mark-marker (point)) + (if (overlayp cua--global-mark-overlay) + (move-overlay cua--global-mark-overlay (point) (1+ (point))) + (setq cua--global-mark-overlay + (make-overlay (point) (1+ (point)))) + (overlay-put cua--global-mark-overlay 'face 'cua-global-mark-face)) + (if (and cua-global-mark-blink-cursor-interval + (not cua--orig-blink-cursor-interval)) + (setq cua--orig-blink-cursor-interval blink-cursor-interval + blink-cursor-interval cua-global-mark-blink-cursor-interval)) + (setq cua--global-mark-active t) + (if msg + (message "Global Mark Set"))) + +(defun cua--global-mark-active () + (if cua--global-mark-active + (or (and (markerp cua--global-mark-marker) + (marker-buffer cua--global-mark-marker)) + (and (cua--deactivate-global-mark nil) + nil)))) + +(defun cua-toggle-global-mark (stay) + "Set or cancel the global marker. +When the global marker is set, CUA cut and copy commands will automatically +insert the deleted or copied text before the global marker, even when the +global marker is in another buffer. +If the global marker isn't set, set the global marker at point in the current +buffer. Otherwise jump to the global marker position and cancel it. +With prefix argument, don't jump to global mark when cancelling it." + (interactive "P") + (unless cua--global-mark-initialized + (cua--init-global-mark)) + (if (not (cua--global-mark-active)) + (if (not buffer-read-only) + (cua--activate-global-mark t) + (ding) + (message "Cannot set global mark in read-only buffer.")) + (when (not stay) + (pop-to-buffer (marker-buffer cua--global-mark-marker)) + (goto-char cua--global-mark-marker)) + (cua--deactivate-global-mark t))) + +(defun cua--insert-at-global-mark (str &optional msg) + ;; Insert string at global marker and move marker + (save-excursion + (set-buffer (marker-buffer cua--global-mark-marker)) + (goto-char (marker-position cua--global-mark-marker)) + (insert-for-yank str) + (cua--activate-global-mark)) + (if msg + (message "%s %d to global mark in %s:%d" msg + (length str) + (buffer-name (marker-buffer cua--global-mark-marker)) + (marker-position cua--global-mark-marker)))) + +(defun cua--delete-at-global-mark (arg &optional msg) + ;; Delete chars at global marker + (save-excursion + (set-buffer (marker-buffer cua--global-mark-marker)) + (goto-char (marker-position cua--global-mark-marker)) + (delete-char arg)) + (if msg + (message "%s %d chars at global mark in %s:%d" msg arg + (buffer-name (marker-buffer cua--global-mark-marker)) + (marker-position cua--global-mark-marker)))) + +(defun cua-copy-region-to-global-mark (start end) + "Copy region to global mark buffer/position." + (interactive "r") + (if (cua--global-mark-active) + (let ((src-buf (current-buffer))) + (save-excursion + (if (equal (marker-buffer cua--global-mark-marker) src-buf) + (let ((text (buffer-substring-no-properties start end))) + (goto-char (marker-position cua--global-mark-marker)) + (insert text)) + (set-buffer (marker-buffer cua--global-mark-marker)) + (goto-char (marker-position cua--global-mark-marker)) + (insert-buffer-substring-as-yank src-buf start end)) + (cua--activate-global-mark) + (message "Copied %d to global mark in %s:%d" + (abs (- end start)) + (buffer-name (marker-buffer cua--global-mark-marker)) + (marker-position cua--global-mark-marker)))) + (cua--deactivate-global-mark) + (message "No Global Mark"))) + +(defun cua-cut-region-to-global-mark (start end) + "Move region to global buffer/position." + (interactive "r") + (if (cua--global-mark-active) + (let ((src-buf (current-buffer))) + (save-excursion + (if (equal (marker-buffer cua--global-mark-marker) src-buf) + (if (and (< start (marker-position cua--global-mark-marker)) + (< (marker-position cua--global-mark-marker) end)) + (message "Can't move region into itself.") + (let ((text (buffer-substring-no-properties start end)) + (p1 (copy-marker start)) + (p2 (copy-marker end))) + (goto-char (marker-position cua--global-mark-marker)) + (insert text) + (cua--activate-global-mark) + (delete-region (marker-position p1) (marker-position p2)) + (move-marker p1 nil) + (move-marker p2 nil))) + (set-buffer (marker-buffer cua--global-mark-marker)) + (goto-char (marker-position cua--global-mark-marker)) + (insert-buffer-substring src-buf start end) + (message "Moved %d to global mark in %s:%d" + (abs (- end start)) + (buffer-name (marker-buffer cua--global-mark-marker)) + (marker-position cua--global-mark-marker)) + (cua--activate-global-mark) + (set-buffer src-buf) + (delete-region start end)))) + (cua--deactivate-global-mark) + (message "No Global Mark"))) + +(defun cua--copy-rectangle-to-global-mark (as-text) + ;; Copy rectangle to global mark buffer/position. + (if (cua--global-mark-active) + (let ((src-buf (current-buffer)) + (text (cua--extract-rectangle))) + (save-excursion + (set-buffer (marker-buffer cua--global-mark-marker)) + (goto-char (marker-position cua--global-mark-marker)) + (if as-text + (while text + (insert-for-yank (car text)) + (if (setq text (cdr text)) + (insert "\n"))) + (cua--insert-rectangle text 'auto)) + (cua--activate-global-mark) + (message "Copied rectangle to global mark in %s:%d" + (buffer-name (marker-buffer cua--global-mark-marker)) + (marker-position cua--global-mark-marker)))) + (cua--deactivate-global-mark) + (message "No Global Mark"))) + +(defun cua--cut-rectangle-to-global-mark (as-text) + ;; Move rectangle to global buffer/position. + (if (cua--global-mark-active) + (let ((src-buf (current-buffer))) + (save-excursion + (if (equal (marker-buffer cua--global-mark-marker) src-buf) + (let ((olist (overlays-at (marker-position cua--global-mark-marker))) + in-rect) + (while olist + (if (eq (overlay-get (car olist) 'face) 'cua-rectangle-face) + (setq in-rect t olist nil) + (setq olist (cdr olist)))) + (if in-rect + (message "Can't move rectangle into itself.") + (let ((text (cua--extract-rectangle))) + (cua--delete-rectangle) + (goto-char (marker-position cua--global-mark-marker)) + (if as-text + (while text + (insert-for-yank (car text)) + (if (setq text (cdr text)) + (insert "\n"))) + (cua--insert-rectangle text 'auto)) + (cua--activate-global-mark)))) + (let ((text (cua--extract-rectangle))) + (cua--delete-rectangle) + (set-buffer (marker-buffer cua--global-mark-marker)) + (goto-char (marker-position cua--global-mark-marker)) + (cua--insert-rectangle text 'auto)) + (message "Moved rectangle to global mark in %s:%d" + (buffer-name (marker-buffer cua--global-mark-marker)) + (marker-position cua--global-mark-marker)) + (cua--activate-global-mark)))) + (cua--deactivate-global-mark) + (message "No Global Mark"))) + +(defun cua-copy-to-global-mark () + "Copy active region/rectangle to global mark buffer/position." + (interactive) + (setq cua--last-killed-rectangle nil) + (if cua--rectangle + (cua--copy-rectangle-to-global-mark nil) + (let ((start (mark)) (end (point))) + (or (<= start end) + (setq start (prog1 end (setq end start)))) + (cua-copy-region-to-global-mark start end)))) + +(defun cua-copy-next-to-global-mark (n) + "Copy the following N characters in buffer to global mark buffer/position." + (interactive "p") + (setq cua--last-killed-rectangle nil) + (or (eobp) + (let ((p (point))) + (goto-char (+ p n)) + (cua-copy-region-to-global-mark p (point))))) + +(defun cua-cut-to-global-mark () + "Move active region/rectangle to global mark buffer/position." + (interactive) + (if buffer-read-only + (cua-copy-to-global-mark) + (setq cua--last-killed-rectangle nil) + (if cua--rectangle + (cua--cut-rectangle-to-global-mark nil) + (let ((start (mark)) (end (point))) + (or (<= start end) + (setq start (prog1 end (setq end start)))) + (cua-cut-region-to-global-mark start end))))) + +(defun cua-cut-next-to-global-mark (n) + "Move the following N characters in buffer to global mark buffer/position." + (interactive "p") + (setq cua--last-killed-rectangle nil) + (or (eobp) + (let ((p (point))) + (goto-char (+ p n)) + (cua-cut-region-to-global-mark p (point))))) + +(defun cua-delete-char-at-global-mark (arg) + "Delete character following the global mark position." + (interactive "p") + (cua--delete-at-global-mark arg "Deleted")) + +(defun cua-delete-backward-char-at-global-mark (arg) + "Delete character before the global mark position." + (interactive "p") + (cua--delete-at-global-mark (- arg) "Deleted backward")) + +(defun cua-insert-char-at-global-mark () + "Insert the character you type at the global mark position." + (interactive) + (cua--insert-at-global-mark (char-to-string (aref (this-single-command-keys) 0)) "Inserted")) + +(defun cua-insert-newline-at-global-mark () + "Insert a newline at the global mark position." + (interactive) + (cua--insert-at-global-mark "\n")) + +(defun cua-indent-to-global-mark-column () + "Indent current line or rectangle to global mark column." + (interactive "*") + (if (cua--global-mark-active) + (let (col) + (save-excursion + (set-buffer (marker-buffer cua--global-mark-marker)) + (goto-char (marker-position cua--global-mark-marker)) + (setq col (current-column))) + (if cua--rectangle + (cua--indent-rectangle nil col t) + (indent-to col)) + (if (eq (current-buffer) (marker-buffer cua--global-mark-marker)) + (save-excursion + (goto-char (marker-position cua--global-mark-marker)) + (move-to-column col) + (move-marker cua--global-mark-marker (point)) + (move-overlay cua--global-mark-overlay (point) (1+ (point)))))))) + + +(defun cua-cancel-global-mark () + "Cancel the global mark." + (interactive) + (if mark-active + (cua-cancel) + (if (cua--global-mark-active) + (cua--deactivate-global-mark t))) + (cua--fallback)) + +;;; Post-command hook for global mark. + +(defun cua--global-mark-post-command () + (when (and (cua--global-mark-active) ;; Updates cua--global-mark-active variable + cua-global-mark-keep-visible) + ;; keep global mark position visible + (sit-for 0) + (if (or (not (eq (current-buffer) (marker-buffer cua--global-mark-marker))) + (not (pos-visible-in-window-p (marker-position cua--global-mark-marker)))) + (let ((w (selected-window)) (p (point)) h) + ;; The following code is an attempt to keep the global mark visible in + ;; other window -- but it doesn't work. + (switch-to-buffer-other-window (marker-buffer cua--global-mark-marker) t) + (goto-char (marker-position cua--global-mark-marker)) + (if (not (pos-visible-in-window-p (marker-position cua--global-mark-marker))) + (recenter (if (> (setq h (- (window-height) 4)) 1) h '(4)))) + (select-window w) + (goto-char p))))) + +;;; Initialization + +(defun cua--init-global-mark () + (unless (face-background 'cua-global-mark-face) + (copy-face 'region 'cua-global-mark-face) + (set-face-foreground 'cua-global-mark-face "black") + (set-face-background 'cua-global-mark-face "cyan")) + + (define-key cua--global-mark-keymap [remap copy-region-as-kill] 'cua-copy-to-global-mark) + (define-key cua--global-mark-keymap [remap kill-ring-save] 'cua-copy-to-global-mark) + (define-key cua--global-mark-keymap [remap kill-region] 'cua-cut-to-global-mark) + (define-key cua--global-mark-keymap [remap yank] 'cua-copy-next-to-global-mark) + + (define-key cua--global-mark-keymap [remap keyboard-escape-quit] 'cua-cancel-global-mark) + (define-key cua--global-mark-keymap [remap keyboard-quit] 'cua-cancel-global-mark) + + (define-key cua--global-mark-keymap [(control ?d)] 'cua-cut-next-to-global-mark) + (define-key cua--global-mark-keymap [remap delete-backward-char] 'cua-delete-backward-char-at-global-mark) + (define-key cua--global-mark-keymap [remap backward-delete-char] 'cua-delete-backward-char-at-global-mark) + (define-key cua--global-mark-keymap [remap backward-delete-char-untabify] 'cua-delete-backward-char-at-global-mark) + (define-key cua--global-mark-keymap [remap self-insert-command] 'cua-insert-char-at-global-mark) + (define-key cua--global-mark-keymap [remap self-insert-iso] 'cua-insert-char-at-global-mark) + (define-key cua--global-mark-keymap [remap newline] 'cua-insert-newline-at-global-mark) + (define-key cua--global-mark-keymap [remap newline-and-indent] 'cua-insert-newline-at-global-mark) + (define-key cua--global-mark-keymap "\r" 'cua-insert-newline-at-global-mark) + + (define-key cua--global-mark-keymap "\t" 'cua-indent-to-global-mark-column) + + (setq cua--global-mark-initialized t)) + +;;; cua-gmrk.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulation/cua-rect.el Sun Apr 28 21:48:39 2002 +0000 @@ -0,0 +1,1375 @@ +;;; cua-rect.el --- CUA unified rectangle support + +;; Copyright (C) 1997-2002 Free Software Foundation, Inc. + +;; Author: Kim F. Storm <storm@cua.dk> +;; Keywords: keyboard emulations convenience CUA + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Acknowledgements + +;; The rectangle handling and display code borrows from the standard +;; GNU emacs rect.el package and the the rect-mark.el package by Rick +;; Sladkey <jrs@world.std.com>. + +(provide 'cua-rect) + +(eval-when-compile + (require 'cua-base) + (require 'cua-gmrk) +) + +;;; Rectangle support + +(require 'rect) + +;; If non-nil, restrict current region to this rectangle. +;; Value is a vector [top bot left right corner ins pad select]. +;; CORNER specifies currently active corner 0=t/l 1=t/r 2=b/l 3=b/r. +;; INS specifies whether to insert on left(nil) or right(t) side. +;; If PAD is non-nil, tabs are converted to spaces when necessary. +;; If SELECT is a regexp, only lines starting with that regexp are affected.") +(defvar cua--rectangle nil) +(make-variable-buffer-local 'cua--rectangle) + +;; Most recent rectangle geometry. Note: car is buffer. +(defvar cua--last-rectangle nil) + +;; Rectangle restored by undo. +(defvar cua--restored-rectangle nil) + +;; Last rectangle copied/killed; nil if last kill was not a rectangle. +(defvar cua--last-killed-rectangle nil) + +;; List of overlays used to display current rectangle. +(defvar cua--rectangle-overlays nil) +(make-variable-buffer-local 'cua--rectangle-overlays) + +;; Per-buffer CUA mode undo list. +(defvar cua--undo-list nil) +(make-variable-buffer-local 'cua--undo-list) + +;; Record undo boundary for rectangle undo. +(defun cua--rectangle-undo-boundary () + (when (listp buffer-undo-list) + (if (> (length cua--undo-list) cua-undo-max) + (setcdr (nthcdr (1- cua-undo-max) cua--undo-list) nil)) + (undo-boundary) + (setq cua--undo-list + (cons (cons (cdr buffer-undo-list) (copy-sequence cua--rectangle)) cua--undo-list)))) + +(defun cua--rectangle-undo (&optional arg) + "Undo some previous changes. +Knows about CUA rectangle highlighting in addition to standard undo." + (interactive "*P") + (if cua--rectangle + (cua--rectangle-undo-boundary)) + (undo arg) + (let ((l cua--undo-list)) + (while l + (if (eq (car (car l)) pending-undo-list) + (setq cua--restored-rectangle + (and (vectorp (cdr (car l))) (cdr (car l))) + l nil) + (setq l (cdr l))))) + (setq cua--buffer-and-point-before-command nil)) + +(defvar cua--tidy-undo-counter 0 + "Number of times `cua--tidy-undo-lists' have run successfully.") + +;; Clean out danling entries from cua's undo list. +;; Since this list contains pointers into the standard undo list, +;; such references are only meningful as undo information if the +;; corresponding entry is still on the standard undo list. + +(defun cua--tidy-undo-lists (&optional clean) + (let ((buffers (buffer-list)) (cnt cua--tidy-undo-counter)) + (while (and buffers (or clean (not (input-pending-p)))) + (with-current-buffer (car buffers) + (when (local-variable-p 'cua--undo-list) + (if (or clean (null cua--undo-list) (eq buffer-undo-list t)) + (progn + (kill-local-variable 'cua--undo-list) + (setq cua--tidy-undo-counter (1+ cua--tidy-undo-counter))) + (let* ((bul buffer-undo-list) + (cul (cons nil cua--undo-list)) + (cc (car (car (cdr cul))))) + (while (and bul cc) + (if (setq bul (memq cc bul)) + (setq cul (cdr cul) + cc (and (cdr cul) (car (car (cdr cul))))))) + (when cc + (if cua--debug + (setq cc (length (cdr cul)))) + (if (eq (cdr cul) cua--undo-list) + (setq cua--undo-list nil) + (setcdr cul nil)) + (setq cua--tidy-undo-counter (1+ cua--tidy-undo-counter)) + (if cua--debug + (message "Clean undo list in %s (%d)" + (buffer-name) cc))))))) + (setq buffers (cdr buffers))) + (/= cnt cua--tidy-undo-counter))) + +;;; Rectangle geometry + +(defun cua--rectangle-top (&optional val) + ;; Top of CUA rectangle (buffer position on first line). + (if (not val) + (aref cua--rectangle 0) + (setq val (line-beginning-position)) + (if (<= val (aref cua--rectangle 1)) + (aset cua--rectangle 0 val) + (aset cua--rectangle 1 val) + (cua--rectangle-corner 2)))) + +(defun cua--rectangle-bot (&optional val) + ;; Bot of CUA rectangle (buffer position on last line). + (if (not val) + (aref cua--rectangle 1) + (setq val (line-end-position)) + (if (>= val (aref cua--rectangle 0)) + (aset cua--rectangle 1 val) + (aset cua--rectangle 0 val) + (cua--rectangle-corner 2)))) + +(defun cua--rectangle-left (&optional val) + ;; Left column of CUA rectangle. + (if (integerp val) + (if (<= val (aref cua--rectangle 3)) + (aset cua--rectangle 2 val) + (aset cua--rectangle 3 val) + (cua--rectangle-corner (if (cua--rectangle-right-side) -1 1))) + (aref cua--rectangle 2))) + +(defun cua--rectangle-right (&optional val) + ;; Right column of CUA rectangle. + (if (integerp val) + (if (>= val (aref cua--rectangle 2)) + (aset cua--rectangle 3 val) + (aset cua--rectangle 2 val) + (cua--rectangle-corner (if (cua--rectangle-right-side) -1 1))) + (aref cua--rectangle 3))) + +(defun cua--rectangle-corner (&optional advance) + ;; Currently active corner of rectangle. + (let ((c (aref cua--rectangle 4))) + (if (not (integerp advance)) + c + (aset cua--rectangle 4 + (if (= advance 0) + (- 3 c) ; opposite corner + (mod (+ c 4 advance) 4))) + (aset cua--rectangle 5 0)))) + +(defun cua--rectangle-right-side (&optional topbot) + ;; t if point is on right side of rectangle. + (if (and topbot (= (cua--rectangle-left) (cua--rectangle-right))) + (< (cua--rectangle-corner) 2) + (= (mod (cua--rectangle-corner) 2) 1))) + +(defun cua--rectangle-column () + (if (cua--rectangle-right-side) + (cua--rectangle-right) + (cua--rectangle-left))) + +(defun cua--rectangle-insert-col (&optional col) + ;; Currently active corner of rectangle. + (if (integerp col) + (aset cua--rectangle 5 col) + (if (cua--rectangle-right-side t) + (if (= (aref cua--rectangle 5) 0) + (1+ (cua--rectangle-right)) + (aref cua--rectangle 5)) + (cua--rectangle-left)))) + +(defun cua--rectangle-padding (&optional set val) + ;; Current setting of rectangle padding + (if set + (aset cua--rectangle 6 val)) + (and (not buffer-read-only) + (aref cua--rectangle 6))) + +(defun cua--rectangle-restriction (&optional val bounded negated) + ;; Current rectangle restriction + (if val + (aset cua--rectangle 7 + (and (stringp val) + (> (length val) 0) + (list val bounded negated))) + (aref cua--rectangle 7))) + +(defun cua--rectangle-assert () + (message "%S (%d)" cua--rectangle (point)) + (if (< (cua--rectangle-right) (cua--rectangle-left)) + (message "rectangle right < left")) + (if (< (cua--rectangle-bot) (cua--rectangle-top)) + (message "rectangle bot < top"))) + +(defun cua--rectangle-get-corners (&optional pad) + ;; Calculate the rectangular region represented by point and mark, + ;; putting start in the upper left corner and end in the + ;; bottom right corner. + (let ((top (point)) (bot (mark)) r l corner) + (save-excursion + (goto-char top) + (setq l (current-column)) + (goto-char bot) + (setq r (current-column)) + (if (<= top bot) + (setq corner (if (<= l r) 0 1)) + (setq top (prog1 bot (setq bot top))) + (setq corner (if (<= l r) 2 3))) + (if (<= l r) + (if (< l r) + (setq r (1- r))) + (setq l (prog1 r (setq r l))) + (goto-char top) + (move-to-column l pad) + (setq top (point)) + (goto-char bot) + (move-to-column r pad) + (setq bot (point)))) + (vector top bot l r corner 0 pad nil))) + +(defun cua--rectangle-set-corners () + ;; Set mark and point in opposite corners of current rectangle. + (let (pp pc mp mc (c (cua--rectangle-corner))) + (cond + ((= c 0) ; top/left -> bot/right + (setq pp (cua--rectangle-top) pc (cua--rectangle-left) + mp (cua--rectangle-bot) mc (cua--rectangle-right))) + ((= c 1) ; top/right -> bot/left + (setq pp (cua--rectangle-top) pc (cua--rectangle-right) + mp (cua--rectangle-bot) mc (cua--rectangle-left))) + ((= c 2) ; bot/left -> top/right + (setq pp (cua--rectangle-bot) pc (cua--rectangle-left) + mp (cua--rectangle-top) mc (cua--rectangle-right))) + ((= c 3) ; bot/right -> top/left + (setq pp (cua--rectangle-bot) pc (cua--rectangle-right) + mp (cua--rectangle-top) mc (cua--rectangle-left)))) + (goto-char mp) + (move-to-column mc (cua--rectangle-padding)) + (set-mark (point)) + (goto-char pp) + (move-to-column pc (cua--rectangle-padding)))) + +;;; Rectangle resizing + +(defun cua--forward-line (n pad) + ;; Move forward/backward one line. Returns t if movement. + (if (or (not pad) (< n 0)) + (= (forward-line n) 0) + (next-line 1) + t)) + +(defun cua--rectangle-resized () + ;; Refresh state after resizing rectangle + (setq cua--buffer-and-point-before-command nil) + (cua--pad-rectangle) + (cua--rectangle-insert-col 0) + (cua--rectangle-set-corners) + (cua--keep-active)) + +(defun cua-resize-rectangle-right (n) + "Resize rectangle to the right." + (interactive "p") + (let ((pad (cua--rectangle-padding)) (resized (> n 0))) + (while (> n 0) + (setq n (1- n)) + (cond + ((and (cua--rectangle-right-side) (or pad (eolp))) + (cua--rectangle-right (1+ (cua--rectangle-right))) + (move-to-column (cua--rectangle-right) pad)) + ((cua--rectangle-right-side) + (forward-char 1) + (cua--rectangle-right (current-column))) + ((or pad (eolp)) + (cua--rectangle-left (1+ (cua--rectangle-left))) + (move-to-column (cua--rectangle-right) pad)) + (t + (forward-char 1) + (cua--rectangle-left (current-column))))) + (if resized + (cua--rectangle-resized)))) + +(defun cua-resize-rectangle-left (n) + "Resize rectangle to the left." + (interactive "p") + (let ((pad (cua--rectangle-padding)) resized) + (while (> n 0) + (setq n (1- n)) + (if (or (= (cua--rectangle-right) 0) + (and (not (cua--rectangle-right-side)) (= (cua--rectangle-left) 0))) + (setq n 0) + (cond + ((and (cua--rectangle-right-side) (or pad (eolp) (bolp))) + (cua--rectangle-right (1- (cua--rectangle-right))) + (move-to-column (cua--rectangle-right) pad)) + ((cua--rectangle-right-side) + (backward-char 1) + (cua--rectangle-right (current-column))) + ((or pad (eolp) (bolp)) + (cua--rectangle-left (1- (cua--rectangle-left))) + (move-to-column (cua--rectangle-right) pad)) + (t + (backward-char 1) + (cua--rectangle-left (current-column)))) + (setq resized t))) + (if resized + (cua--rectangle-resized)))) + +(defun cua-resize-rectangle-down (n) + "Resize rectangle downwards." + (interactive "p") + (let ((pad (cua--rectangle-padding)) resized) + (while (> n 0) + (setq n (1- n)) + (cond + ((>= (cua--rectangle-corner) 2) + (goto-char (cua--rectangle-bot)) + (when (cua--forward-line 1 pad) + (move-to-column (cua--rectangle-column) pad) + (cua--rectangle-bot t) + (setq resized t))) + (t + (goto-char (cua--rectangle-top)) + (when (cua--forward-line 1 pad) + (move-to-column (cua--rectangle-column) pad) + (cua--rectangle-top t) + (setq resized t))))) + (if resized + (cua--rectangle-resized)))) + +(defun cua-resize-rectangle-up (n) + "Resize rectangle upwards." + (interactive "p") + (let ((pad (cua--rectangle-padding)) resized) + (while (> n 0) + (setq n (1- n)) + (cond + ((>= (cua--rectangle-corner) 2) + (goto-char (cua--rectangle-bot)) + (when (cua--forward-line -1 pad) + (move-to-column (cua--rectangle-column) pad) + (cua--rectangle-bot t) + (setq resized t))) + (t + (goto-char (cua--rectangle-top)) + (when (cua--forward-line -1 pad) + (move-to-column (cua--rectangle-column) pad) + (cua--rectangle-top t) + (setq resized t))))) + (if resized + (cua--rectangle-resized)))) + +(defun cua-resize-rectangle-eol () + "Resize rectangle to end of line." + (interactive) + (unless (eolp) + (end-of-line) + (if (> (current-column) (cua--rectangle-right)) + (cua--rectangle-right (current-column))) + (if (not (cua--rectangle-right-side)) + (cua--rectangle-corner 1)) + (cua--rectangle-resized))) + +(defun cua-resize-rectangle-bol () + "Resize rectangle to beginning of line." + (interactive) + (unless (bolp) + (beginning-of-line) + (cua--rectangle-left (current-column)) + (if (cua--rectangle-right-side) + (cua--rectangle-corner -1)) + (cua--rectangle-resized))) + +(defun cua-resize-rectangle-bot () + "Resize rectangle to bottom of buffer." + (interactive) + (goto-char (point-max)) + (move-to-column (cua--rectangle-column) (cua--rectangle-padding)) + (cua--rectangle-bot t) + (cua--rectangle-resized)) + +(defun cua-resize-rectangle-top () + "Resize rectangle to top of buffer." + (interactive) + (goto-char (point-min)) + (move-to-column (cua--rectangle-column) (cua--rectangle-padding)) + (cua--rectangle-top t) + (cua--rectangle-resized)) + +(defun cua-resize-rectangle-page-up () + "Resize rectangle upwards by one scroll page." + (interactive) + (let ((pad (cua--rectangle-padding))) + (scroll-down) + (move-to-column (cua--rectangle-column) pad) + (if (>= (cua--rectangle-corner) 2) + (cua--rectangle-bot t) + (cua--rectangle-top t)) + (cua--rectangle-resized))) + +(defun cua-resize-rectangle-page-down () + "Resize rectangle downwards by one scroll page." + (interactive) + (let ((pad (cua--rectangle-padding))) + (scroll-up) + (move-to-column (cua--rectangle-column) pad) + (if (>= (cua--rectangle-corner) 2) + (cua--rectangle-bot t) + (cua--rectangle-top t)) + (cua--rectangle-resized))) + +;;; Mouse support + +;; This is pretty simplistic, but it does the job... + +(defun cua-mouse-resize-rectangle (event) + "Set rectangle corner at mouse click position." + (interactive "e") + (mouse-set-point event) + (if (cua--rectangle-padding) + (move-to-column (car (posn-col-row (event-end event))) t)) + (if (cua--rectangle-right-side) + (cua--rectangle-right (current-column)) + (cua--rectangle-left (current-column))) + (if (>= (cua--rectangle-corner) 2) + (cua--rectangle-bot t) + (cua--rectangle-top t)) + (cua--rectangle-resized)) + +(defvar cua--mouse-last-pos nil) + +(defun cua-mouse-set-rectangle-mark (event) + "Start rectangle at mouse click position." + (interactive "e") + (when cua--rectangle + (cua--deactivate-rectangle) + (cua--deactivate t)) + (setq cua--last-rectangle nil) + (mouse-set-point event) + (cua-set-rectangle-mark) + (setq cua--buffer-and-point-before-command nil) + (setq cua--mouse-last-pos nil)) + +(defun cua-mouse-save-then-kill-rectangle (event arg) + "Expand rectangle to mouse click position and copy rectangle. +If command is repeated at same position, delete the rectangle." + (interactive "e\nP") + (if (and (eq this-command last-command) + (eq (point) (car-safe cua--mouse-last-pos)) + (eq cua--last-killed-rectangle (cdr-safe cua--mouse-last-pos))) + (progn + (unless buffer-read-only + (cua--delete-rectangle)) + (cua--deactivate)) + (cua-mouse-resize-rectangle event) + (let ((cua-keep-region-after-copy t)) + (cua-copy-rectangle arg) + (setq cua--mouse-last-pos (cons (point) cua--last-killed-rectangle))))) +(defun cua--mouse-ignore (event) + (interactive "e") + (setq this-command last-command)) + +(defun cua--rectangle-move (dir) + (let ((pad (cua--rectangle-padding)) + (moved t) + (top (cua--rectangle-top)) + (bot (cua--rectangle-bot)) + (l (cua--rectangle-left)) + (r (cua--rectangle-right))) + (cond + ((eq dir 'up) + (goto-char top) + (when (cua--forward-line -1 pad) + (cua--rectangle-top t) + (goto-char bot) + (forward-line -1) + (cua--rectangle-bot t))) + ((eq dir 'down) + (goto-char bot) + (when (cua--forward-line 1 pad) + (cua--rectangle-bot t) + (goto-char top) + (cua--forward-line 1 pad) + (cua--rectangle-top t))) + ((eq dir 'left) + (when (> l 0) + (cua--rectangle-left (1- l)) + (cua--rectangle-right (1- r)))) + ((eq dir 'right) + (cua--rectangle-right (1+ r)) + (cua--rectangle-left (1+ l))) + (t + (setq moved nil))) + (when moved + (setq cua--buffer-and-point-before-command nil) + (cua--pad-rectangle) + (cua--rectangle-set-corners) + (cua--keep-active)))) + + +;;; Operations on current rectangle + +(defun cua--rectangle-operation (keep-clear visible undo pad &optional fct post-fct) + ;; Call FCT for each line of region with 4 parameters: + ;; Region start, end, left-col, right-col + ;; Point is at start when FCT is called + ;; Set undo boundary if UNDO is non-nil. + ;; Rectangle is padded if PAD = t or numeric and (cua--rectangle-padding) + ;; Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear. + (let* ((start (cua--rectangle-top)) + (end (cua--rectangle-bot)) + (l (cua--rectangle-left)) + (r (1+ (cua--rectangle-right))) + (m (make-marker)) + (tabpad (and (integerp pad) (= pad 2))) + (sel (cua--rectangle-restriction))) + (if undo + (cua--rectangle-undo-boundary)) + (if (integerp pad) + (setq pad (cua--rectangle-padding))) + (save-excursion + (save-restriction + (widen) + (when (> (cua--rectangle-corner) 1) + (goto-char end) + (and (bolp) (not (eolp)) (not (eobp)) + (setq end (1+ end)))) + (when visible + (setq start (max (window-start) start)) + (setq end (min (window-end) end))) + (goto-char end) + (setq end (line-end-position)) + (goto-char start) + (setq start (line-beginning-position)) + (narrow-to-region start end) + (goto-char (point-min)) + (while (< (point) (point-max)) + (move-to-column r pad) + (and (not pad) (not visible) (> (current-column) r) + (backward-char 1)) + (if (and tabpad (not pad) (looking-at "\t")) + (forward-char 1)) + (set-marker m (point)) + (move-to-column l pad) + (if fct + (let ((v t) (p (point))) + (when sel + (if (car (cdr sel)) + (setq v (looking-at (car sel))) + (setq v (re-search-forward (car sel) m t)) + (goto-char p)) + (if (car (cdr (cdr sel))) + (setq v (null v)))) + (if visible + (funcall fct p m l r v) + (if v + (funcall fct p m l r))))) + (set-marker m nil) + (forward-line 1)) + (if (not visible) + (cua--rectangle-bot t)) + (if post-fct + (funcall post-fct l r)))) + (cond + ((eq keep-clear 'keep) + (cua--keep-active)) + ((eq keep-clear 'clear) + (cua--deactivate)) + ((eq keep-clear 'corners) + (cua--rectangle-set-corners) + (cua--keep-active))) + (setq cua--buffer-and-point-before-command nil))) + +(put 'cua--rectangle-operation 'lisp-indent-function 4) + +(defun cua--pad-rectangle (&optional pad) + (if (or pad (cua--rectangle-padding)) + (cua--rectangle-operation nil nil t t))) + +(defun cua--delete-rectangle () + (cua--rectangle-operation nil nil t 2 + '(lambda (s e l r) + (delete-region s (if (> e s) e (1+ e)))))) + +(defun cua--extract-rectangle () + (let (rect) + (cua--rectangle-operation nil nil nil 1 + '(lambda (s e l r) + (setq rect (cons (buffer-substring-no-properties s e) rect)))) + (nreverse rect))) + +(defun cua--insert-rectangle (rect &optional below) + ;; Insert rectangle as insert-rectangle, but don't set mark and exit with + ;; point at either next to top right or below bottom left corner + ;; Notice: In overwrite mode, the rectangle is inserted as separate text lines. + (if (and below (eq below 'auto)) + (setq below (and (bolp) + (or (eolp) (eobp) (= (1+ (point)) (point-max)))))) + (let ((lines rect) + (insertcolumn (current-column)) + (first t) + p) + (while (or lines below) + (or first + (if overwrite-mode + (insert ?\n) + (forward-line 1) + (or (bolp) (insert ?\n)) + (move-to-column insertcolumn t))) + (if (not lines) + (setq below nil) + (insert-for-yank (car lines)) + (setq lines (cdr lines)) + (and first (not below) + (setq p (point)))) + (setq first nil)) + (and p (not overwrite-mode) + (goto-char p)))) + +(defun cua--copy-rectangle-as-kill (&optional ring) + (if cua--register + (set-register cua--register (cua--extract-rectangle)) + (setq killed-rectangle (cua--extract-rectangle)) + (setq cua--last-killed-rectangle (cons (and kill-ring (car kill-ring)) killed-rectangle)) + (if ring + (kill-new (mapconcat + (function (lambda (row) (concat row "\n"))) + killed-rectangle ""))))) + +(defun cua--activate-rectangle (&optional force) + ;; Turn on rectangular marking mode by disabling transient mark mode + ;; and manually handling highlighting from a post command hook. + ;; Be careful if we are already marking a rectangle. + (setq cua--rectangle + (if (and cua--last-rectangle + (eq (car cua--last-rectangle) (current-buffer)) + (eq (car (cdr cua--last-rectangle)) (point))) + (cdr (cdr cua--last-rectangle)) + (cua--rectangle-get-corners + (and (not buffer-read-only) + (or cua-auto-expand-rectangles + force + (eq major-mode 'picture-mode))))) + cua--status-string (if (cua--rectangle-padding) " Pad" "") + cua--last-rectangle nil)) + +;; (defvar cua-save-point nil) + +(defun cua--deactivate-rectangle () + ;; This is used to clean up after `cua--activate-rectangle'. + (mapcar (function delete-overlay) cua--rectangle-overlays) + (setq cua--last-rectangle (cons (current-buffer) + (cons (point) ;; cua-save-point + cua--rectangle)) + cua--rectangle nil + cua--rectangle-overlays nil + cua--status-string nil + cua--mouse-last-pos nil)) + +(defun cua--highlight-rectangle () + ;; This function is used to highlight the rectangular region. + ;; We do this by putting an overlay on each line within the rectangle. + ;; Each overlay extends across all the columns of the rectangle. + ;; We try to reuse overlays where possible because this is more efficient + ;; and results in less flicker. + ;; If cua--rectangle-padding is nil and the buffer contains tabs or short lines, + ;; the higlighted region may not be perfectly rectangular. + (let ((deactivate-mark deactivate-mark) + (old cua--rectangle-overlays) + (new nil) + (left (cua--rectangle-left)) + (right (1+ (cua--rectangle-right)))) + (when (/= left right) + (sit-for 0) ; make window top/bottom reliable + (cua--rectangle-operation nil t nil nil + '(lambda (s e l r v) + (let ((rface (if v 'cua-rectangle-face 'cua-rectangle-noselect-face)) + overlay) + ;; Trim old leading overlays. + (if (= s e) (setq e (1+ e))) + (while (and old + (setq overlay (car old)) + (< (overlay-start overlay) s) + (/= (overlay-end overlay) e)) + (delete-overlay overlay) + (setq old (cdr old))) + ;; Reuse an overlay if possible, otherwise create one. + (if (and old + (setq overlay (car old)) + (or (= (overlay-start overlay) s) + (= (overlay-end overlay) e))) + (progn + (move-overlay overlay s e) + (setq old (cdr old))) + (setq overlay (make-overlay s e))) + (overlay-put overlay 'face rface) + (setq new (cons overlay new)))))) + ;; Trim old trailing overlays. + (mapcar (function delete-overlay) old) + (setq cua--rectangle-overlays (nreverse new)))) + +(defun cua--indent-rectangle (&optional ch to-col clear) + ;; Indent current rectangle. + (let ((col (cua--rectangle-insert-col)) + (pad (cua--rectangle-padding)) + indent) + (cua--rectangle-operation (if clear 'clear 'corners) nil t pad + '(lambda (s e l r) + (move-to-column col pad) + (if (and (eolp) + (< (current-column) col)) + (move-to-column col t)) + (cond + (to-col (indent-to to-col)) + (ch (insert ch)) + (t (tab-to-tab-stop))) + (if (cua--rectangle-right-side t) + (cua--rectangle-insert-col (current-column)) + (setq indent (- (current-column) l)))) + '(lambda (l r) + (when (and indent (> indent 0)) + (aset cua--rectangle 2 (+ l indent)) + (aset cua--rectangle 3 (+ r indent -1))))))) + +;; +;; rectangle functions / actions +;; + +(defvar cua--rectangle-initialized nil) + +(defun cua-set-rectangle-mark (&optional reopen) + "Set mark and start in CUA rectangle mode. +With prefix argument, activate previous rectangle if possible." + (interactive "P") + (unless cua--rectangle-initialized + (cua--init-rectangles)) + (when (not cua--rectangle) + (if (and reopen + cua--last-rectangle + (eq (car cua--last-rectangle) (current-buffer))) + (goto-char (car (cdr cua--last-rectangle))) + (if (not mark-active) + (push-mark nil nil t))) + (cua--activate-rectangle) + (cua--rectangle-set-corners) + (setq mark-active t + cua--explicit-region-start t) + (if cua-enable-rectangle-auto-help + (cua-help-for-rectangle t)))) + +(defun cua-clear-rectangle-mark () + "Cancel current rectangle." + (interactive) + (when cua--rectangle + (setq mark-active nil + cua--explicit-region-start nil) + (cua--deactivate-rectangle))) + +(defun cua-toggle-rectangle-mark () + (interactive) + (if cua--rectangle + (cua--deactivate-rectangle) + (unless cua--rectangle-initialized + (cua--init-rectangles)) + (cua--activate-rectangle)) + (if cua--rectangle + (if cua-enable-rectangle-auto-help + (cua-help-for-rectangle t)) + (if cua-enable-region-auto-help + (cua-help-for-region t)))) + +(defun cua-restrict-regexp-rectangle (arg) + "Restrict rectangle to lines (not) matching REGEXP. +With prefix argument, the toggle restriction." + (interactive "P") + (let ((r (cua--rectangle-restriction)) regexp) + (if (and r (null (car (cdr r)))) + (if arg + (cua--rectangle-restriction (car r) nil (not (car (cdr (cdr r))))) + (cua--rectangle-restriction "" nil nil)) + (cua--rectangle-restriction + (read-from-minibuffer "Restrict rectangle (regexp): " + nil nil nil nil) nil arg)))) + +(defun cua-restrict-prefix-rectangle (arg) + "Restrict rectangle to lines (not) starting with CHAR. +With prefix argument, the toggle restriction." + (interactive "P") + (let ((r (cua--rectangle-restriction)) regexp) + (if (and r (car (cdr r))) + (if arg + (cua--rectangle-restriction (car r) t (not (car (cdr (cdr r))))) + (cua--rectangle-restriction "" nil nil)) + (cua--rectangle-restriction + (format "[%c]" + (read-char "Restrictive rectangle (char): ")) t arg)))) + +(defun cua-move-rectangle-up () + (interactive) + (cua--rectangle-move 'up)) + +(defun cua-move-rectangle-down () + (interactive) + (cua--rectangle-move 'down)) + +(defun cua-move-rectangle-left () + (interactive) + (cua--rectangle-move 'left)) + +(defun cua-move-rectangle-right () + (interactive) + (cua--rectangle-move 'right)) + +(defun cua-copy-rectangle (arg) + (interactive "P") + (setq arg (cua--prefix-arg arg)) + (cua--copy-rectangle-as-kill arg) + (if cua-keep-region-after-copy + (cua--keep-active) + (cua--deactivate))) + +(defun cua-cut-rectangle (arg) + (interactive "P") + (if buffer-read-only + (cua-copy-rectangle arg) + (setq arg (cua--prefix-arg arg)) + (goto-char (min (mark) (point))) + (cua--copy-rectangle-as-kill arg) + (cua--delete-rectangle)) + (cua--deactivate)) + +(defun cua-delete-rectangle () + (interactive) + (goto-char (min (point) (mark))) + (if cua-delete-copy-to-register-0 + (set-register ?0 (cua--extract-rectangle))) + (cua--delete-rectangle) + (cua--deactivate)) + +(defun cua-rotate-rectangle () + (interactive) + (cua--rectangle-corner (if (= (cua--rectangle-left) (cua--rectangle-right)) 0 1)) + (cua--rectangle-set-corners)) + +(defun cua-toggle-rectangle-padding () + (interactive) + (if buffer-read-only + (message "Cannot do padding in read-only buffer.") + (cua--rectangle-padding t (not (cua--rectangle-padding))) + (cua--pad-rectangle) + (cua--rectangle-set-corners)) + (setq cua--status-string (and (cua--rectangle-padding) " Pad")) + (cua--keep-active)) + +(defun cua-do-rectangle-padding () + (interactive) + (if buffer-read-only + (message "Cannot do padding in read-only buffer.") + (cua--pad-rectangle t) + (cua--rectangle-set-corners)) + (cua--keep-active)) + +(defun cua-open-rectangle () + "Blank out CUA rectangle, shifting text right. +The text previously in the region is not overwritten by the blanks, +but instead winds up to the right of the rectangle." + (interactive) + (cua--rectangle-operation 'corners nil t 1 + '(lambda (s e l r) + (skip-chars-forward " \t") + (let ((ws (- (current-column) l)) + (p (point))) + (skip-chars-backward " \t") + (delete-region (point) p) + (indent-to (+ r ws)))))) + +(defun cua-close-rectangle (arg) + "Delete all whitespace starting at left edge of CUA rectangle. +On each line in the rectangle, all continuous whitespace starting +at that column is deleted. +With prefix arg, also delete whitespace to the left of that column." + (interactive "P") + (cua--rectangle-operation 'clear nil t 1 + '(lambda (s e l r) + (when arg + (skip-syntax-backward " " (line-beginning-position)) + (setq s (point))) + (skip-syntax-forward " " (line-end-position)) + (delete-region s (point))))) + +(defun cua-blank-rectangle () + "Blank out CUA rectangle. +The text previously in the rectangle is overwritten by the blanks." + (interactive) + (cua--rectangle-operation 'keep nil nil 1 + '(lambda (s e l r) + (goto-char e) + (skip-syntax-forward " " (line-end-position)) + (setq e (point)) + (let ((column (current-column))) + (goto-char s) + (skip-syntax-backward " " (line-beginning-position)) + (delete-region (point) e) + (indent-to column))))) + +(defun cua-align-rectangle () + "Align rectangle lines to left column." + (interactive) + (let (x) + (cua--rectangle-operation 'clear nil t t + '(lambda (s e l r) + (let ((b (line-beginning-position))) + (skip-syntax-backward "^ " b) + (skip-syntax-backward " " b) + (setq s (point))) + (skip-syntax-forward " " (line-end-position)) + (delete-region s (point)) + (indent-to l)) + '(lambda (l r) + (move-to-column l) + ;; (setq cua-save-point (point)) + )))) + +(defun cua-copy-rectangle-as-text (&optional arg delete) + "Copy rectangle, but store as normal text." + (interactive "P") + (if cua--global-mark-active + (if delete + (cua--cut-rectangle-to-global-mark t) + (cua--copy-rectangle-to-global-mark t)) + (let* ((rect (cua--extract-rectangle)) + (text (mapconcat + (function (lambda (row) (concat row "\n"))) + rect ""))) + (setq arg (cua--prefix-arg arg)) + (if cua--register + (set-register cua--register text) + (kill-new text))) + (if delete + (cua--delete-rectangle)) + (cua--deactivate))) + +(defun cua-cut-rectangle-as-text (arg) + "Kill rectangle, but store as normal text." + (interactive "P") + (cua-copy-rectangle-as-text arg (not buffer-read-only))) + +(defun cua-string-rectangle (string) + "Replace CUA rectangle contents with STRING on each line. +The length of STRING need not be the same as the rectangle width." + (interactive "sString rectangle: ") + (cua--rectangle-operation 'keep nil t t + '(lambda (s e l r) + (delete-region s e) + (skip-chars-forward " \t") + (let ((ws (- (current-column) l))) + (delete-region s (point)) + (insert string) + (indent-to (+ (current-column) ws)))) + (unless (cua--rectangle-restriction) + '(lambda (l r) + (cua--rectangle-right (max l (+ l (length string) -1))))))) + +(defun cua-fill-char-rectangle (ch) + "Replace CUA rectangle contents with CHARACTER." + (interactive "cFill rectangle with character: ") + (cua--rectangle-operation 'clear nil t 1 + '(lambda (s e l r) + (delete-region s e) + (move-to-column l t) + (insert-char ch (- r l))))) + +(defun cua-replace-in-rectangle (regexp newtext) + "Replace REGEXP with NEWTEXT in each line of CUA rectangle." + (interactive "sReplace regexp: \nsNew text: ") + (if buffer-read-only + (message "Cannot replace in read-only buffer") + (cua--rectangle-operation 'keep nil t 1 + '(lambda (s e l r) + (if (re-search-forward regexp e t) + (replace-match newtext nil nil)))))) + +(defun cua-incr-rectangle (increment) + "Increment each line of CUA rectangle by prefix amount." + (interactive "p") + (cua--rectangle-operation 'keep nil t 1 + '(lambda (s e l r) + (cond + ((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t) + (let* ((txt (buffer-substring-no-properties (match-beginning 1) (match-end 1))) + (n (string-to-number txt 16)) + (fmt (format "0x%%0%dx" (length txt)))) + (replace-match (format fmt (+ n increment))))) + ((re-search-forward "\\( *-?[0-9]+\\)" e t) + (let* ((txt (buffer-substring-no-properties (match-beginning 1) (match-end 1))) + (prefix (if (= (aref txt 0) ?0) "0" "")) + (n (string-to-number txt 10)) + (fmt (format "%%%s%dd" prefix (length txt)))) + (replace-match (format fmt (+ n increment))))) + (t nil))))) + +(defvar cua--rectangle-seq-format "%d" + "Last format used by cua-sequence-rectangle.") + +(defun cua-sequence-rectangle (first incr fmt) + "Resequence each line of CUA rectangle starting from FIRST. +The numbers are formatted according to the FORMAT string." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (string-to-number + (read-string "Start value: (0) " nil nil "0"))) + (string-to-number + (read-string "Increment: (1) " nil nil "1")) + (read-string (concat "Format: (" cua--rectangle-seq-format ") ")))) + (if (= (length fmt) 0) + (setq fmt cua--rectangle-seq-format) + (setq cua--rectangle-seq-format fmt)) + (cua--rectangle-operation 'clear nil t 1 + '(lambda (s e l r) + (delete-region s e) + (insert (format fmt first)) + (setq first (+ first incr))))) + +(defun cua-upcase-rectangle () + "Convert the rectangle to upper case." + (interactive) + (cua--rectangle-operation 'clear nil nil nil + '(lambda (s e l r) + (upcase-region s e)))) + +(defun cua-downcase-rectangle () + "Convert the rectangle to lower case." + (interactive) + (cua--rectangle-operation 'clear nil nil nil + '(lambda (s e l r) + (downcase-region s e)))) + + +;;; Replace/rearrange text in current rectangle + +(defun cua--rectangle-aux-replace (width adjust keep replace pad format-fct &optional setup-fct) + ;; Process text inserted by calling SETUP-FCT or current rectangle if nil. + ;; Then call FORMAT-FCT on text (if non-nil); takes two args: start and end. + ;; Fill to WIDTH characters if > 0 or fill to current width if == 0. + ;; Don't fill if WIDTH < 0. + ;; Replace current rectangle by filled text if REPLACE is non-nil + (let ((auxbuf (get-buffer-create "*CUA temp*")) + (w (if (> width 1) width + (- (cua--rectangle-right) (cua--rectangle-left) -1))) + (r (or setup-fct (cua--extract-rectangle))) + y z (tr 0)) + (save-excursion + (set-buffer auxbuf) + (erase-buffer) + (if setup-fct + (funcall setup-fct) + (cua--insert-rectangle r)) + (if format-fct + (let ((fill-column w)) + (funcall format-fct (point-min) (point-max)))) + (when replace + (goto-char (point-min)) + (while (not (eobp)) + (setq z (cons (buffer-substring (point) (line-end-position)) z)) + (forward-line 1)))) + (if (not cua--debug) + (kill-buffer auxbuf)) + (when replace + (setq z (reverse z)) + (if cua--debug + (print z auxbuf)) + (cua--rectangle-operation nil nil t pad + '(lambda (s e l r) + (let (cc) + (goto-char e) + (skip-chars-forward " \t") + (setq cc (current-column)) + (if cua--debug + (print (list cc s e) auxbuf)) + (delete-region s (point)) + (if (not z) + (setq y 0) + (move-to-column l t) + (insert (car z)) + (when (> (current-column) (+ l w)) + (setq y (point)) + (move-to-column (+ l w) t) + (delete-region (point) y) + (setq tr (1+ tr))) + (setq z (cdr z))) + (if cua--debug + (print (list (current-column) cc) auxbuf)) + (indent-to cc)))) + (if (> tr 0) + (message "Warning: Truncated %d row%s" tr (if (> tr 1) "s" ""))) + (if adjust + (cua--rectangle-right (+ (cua--rectangle-left) w -1))) + (if keep + (cua--rectangle-resized))))) + +(put 'cua--rectangle-aux-replace 'lisp-indent-function 4) + +(defun cua--left-fill-rectangle (start end) + (beginning-of-line) + (while (< (point) (point-max)) + (delete-horizontal-space nil) + (forward-line 1)) + (fill-region-as-paragraph (point-min) (point-max) 'left nil) + (untabify (point-min) (point-max))) + +(defun cua-text-fill-rectangle (width text) + "Replace rectagle with filled TEXT read from minibuffer. +A numeric prefix argument is used a new width for the filled rectangle." + (interactive (list + (prefix-numeric-value current-prefix-arg) + (read-from-minibuffer "Enter text: " + nil nil nil nil))) + (cua--rectangle-aux-replace width t t t 1 + 'cua--left-fill-rectangle + '(lambda () (insert text)))) + +(defun cua-refill-rectangle (width) + "Fill contents of current rectagle. +A numeric prefix argument is used as new width for the filled rectangle." + (interactive "P") + (cua--rectangle-aux-replace + (if width (prefix-numeric-value width) 0) + t t t 1 'cua--left-fill-rectangle)) + +(defun cua-shell-command-on-rectangle (replace command) + "Run shell command on rectangle like `shell-command-on-region'. +With prefix arg, replace rectangle with output from command." + (interactive (list + current-prefix-arg + (read-from-minibuffer "Shell command on rectangle: " + nil nil nil + 'shell-command-history))) + (cua--rectangle-aux-replace -1 t t replace 1 + '(lambda (s e) + (shell-command-on-region s e command + replace replace nil)))) + +(defun cua-reverse-rectangle () + "Reverse the lines of the rectangle." + (interactive) + (cua--rectangle-aux-replace 0 t t t t 'reverse-region)) + +(defun cua-scroll-rectangle-up () + "Remove the first line of the rectangle and scroll remaining lines up." + (interactive) + (cua--rectangle-aux-replace 0 t t t t + '(lambda (s e) + (if (= (forward-line 1) 0) + (delete-region s (point)))))) + +(defun cua-scroll-rectangle-down () + "Insert a blank line at the first line of the rectangle. +The remaining lines are scrolled down, losing the last line." + (interactive) + (cua--rectangle-aux-replace 0 t t t t + '(lambda (s e) + (goto-char s) + (insert "\n")))) + + +;;; Insert/delete text to left or right of rectangle + +(defun cua-insert-char-rectangle (&optional ch) + (interactive) + (if buffer-read-only + (ding) + (cua--indent-rectangle (or ch (aref (this-single-command-keys) 0))) + (cua--keep-active)) + t) + +(defun cua-indent-rectangle (column) + "Indent rectangle to next tab stop. +With prefix arg, indent to that column." + (interactive "P") + (if (null column) + (cua-insert-char-rectangle ?\t) + (cua--indent-rectangle nil (prefix-numeric-value column)))) + +(defun cua-delete-char-rectangle () + "Delete char to left or right of rectangle." + (interactive) + (let ((col (cua--rectangle-insert-col)) + (pad (cua--rectangle-padding)) + indent) + (cua--rectangle-operation 'corners nil t pad + '(lambda (s e l r) + (move-to-column + (if (cua--rectangle-right-side t) + (max (1+ r) col) l) + pad) + (if (bolp) + nil + (delete-backward-char 1) + (if (cua--rectangle-right-side t) + (cua--rectangle-insert-col (current-column)) + (setq indent (- l (current-column)))))) + '(lambda (l r) + (when (and indent (> indent 0)) + (aset cua--rectangle 2 (- l indent)) + (aset cua--rectangle 3 (- r indent 1))))))) + +(defun cua-help-for-rectangle (&optional help) + (interactive) + (let ((M (if cua-use-hyper-key " H-" " M-"))) + (message + (concat (if help "C-?:help" "") + M "p:pad" M "o:open" M "c:close" M "b:blank" + M "s:string" M "f:fill" M "i:incr" M "n:seq")))) + + +;;; CUA-like cut & paste for rectangles + +(defun cua--cancel-rectangle () + ;; Cancel rectangle + (if cua--rectangle + (cua--deactivate-rectangle)) + (setq cua--last-rectangle nil)) + +(defun cua--rectangle-post-command () + (if cua--restored-rectangle + (setq cua--rectangle cua--restored-rectangle + cua--restored-rectangle nil + mark-active t + deactivate-mark nil) + (when (and cua--rectangle cua--buffer-and-point-before-command + (equal (car cua--buffer-and-point-before-command) (current-buffer)) + (not (= (cdr cua--buffer-and-point-before-command) (point)))) + (if (cua--rectangle-right-side) + (cua--rectangle-right (current-column)) + (cua--rectangle-left (current-column))) + (if (>= (cua--rectangle-corner) 2) + (cua--rectangle-bot t) + (cua--rectangle-top t)) + (if (cua--rectangle-padding) + (setq unread-command-events + (cons (if cua-use-hyper-key ?\H-P ?\M-P) unread-command-events))))) + (if cua--rectangle + (if (and mark-active + (not deactivate-mark)) + (cua--highlight-rectangle) + (cua--deactivate-rectangle)))) + + +;;; Initialization + +(defun cua--rect-M/H-key (key cmd) + (cua--M/H-key cua--rectangle-keymap key cmd)) + +(defun cua--rectangle-on-off (on) + (cancel-function-timers 'cua--tidy-undo-lists) + (if on + (run-with-idle-timer 10 t 'cua--tidy-undo-lists) + (cua--tidy-undo-lists t))) + +(defun cua--init-rectangles () + (unless (face-background 'cua-rectangle-face) + (copy-face 'region 'cua-rectangle-face) + (set-face-background 'cua-rectangle-face "maroon") + (set-face-foreground 'cua-rectangle-face "white")) + + (unless (face-background 'cua-rectangle-noselect-face) + (copy-face 'region 'cua-rectangle-noselect-face) + (set-face-background 'cua-rectangle-noselect-face "dimgray") + (set-face-foreground 'cua-rectangle-noselect-face "white")) + + (unless (eq cua-use-hyper-key 'only) + (define-key cua--rectangle-keymap [(shift return)] 'cua-clear-rectangle-mark) + (define-key cua--region-keymap [(shift return)] 'cua-toggle-rectangle-mark)) + (when cua-use-hyper-key + (cua--rect-M/H-key 'space 'cua-clear-rectangle-mark) + (cua--M/H-key cua--region-keymap 'space 'cua-toggle-rectangle-mark)) + + (define-key cua--rectangle-keymap [remap copy-region-as-kill] 'cua-copy-rectangle) + (define-key cua--rectangle-keymap [remap kill-ring-save] 'cua-copy-rectangle) + (define-key cua--rectangle-keymap [remap kill-region] 'cua-cut-rectangle) + (define-key cua--rectangle-keymap [remap delete-char] 'cua-delete-rectangle) + (define-key cua--rectangle-keymap [remap set-mark-command] 'cua-toggle-rectangle-mark) + + (define-key cua--rectangle-keymap [remap forward-char] 'cua-resize-rectangle-right) + (define-key cua--rectangle-keymap [remap backward-char] 'cua-resize-rectangle-left) + (define-key cua--rectangle-keymap [remap next-line] 'cua-resize-rectangle-down) + (define-key cua--rectangle-keymap [remap previous-line] 'cua-resize-rectangle-up) + (define-key cua--rectangle-keymap [remap end-of-line] 'cua-resize-rectangle-eol) + (define-key cua--rectangle-keymap [remap beginning-of-line] 'cua-resize-rectangle-bol) + (define-key cua--rectangle-keymap [remap end-of-buffer] 'cua-resize-rectangle-bot) + (define-key cua--rectangle-keymap [remap beginning-of-buffer] 'cua-resize-rectangle-top) + (define-key cua--rectangle-keymap [remap scroll-down] 'cua-resize-rectangle-page-up) + (define-key cua--rectangle-keymap [remap scroll-up] 'cua-resize-rectangle-page-down) + + (define-key cua--rectangle-keymap [remap delete-backward-char] 'cua-delete-char-rectangle) + (define-key cua--rectangle-keymap [remap backward-delete-char] 'cua-delete-char-rectangle) + (define-key cua--rectangle-keymap [remap backward-delete-char-untabify] 'cua-delete-char-rectangle) + (define-key cua--rectangle-keymap [remap self-insert-command] 'cua-insert-char-rectangle) + (define-key cua--rectangle-keymap [remap self-insert-iso] 'cua-insert-char-rectangle) + + (define-key cua--rectangle-keymap "\r" 'cua-rotate-rectangle) + (define-key cua--rectangle-keymap "\t" 'cua-indent-rectangle) + + (define-key cua--rectangle-keymap [(control ??)] 'cua-help-for-rectangle) + + (define-key cua--rectangle-keymap [mouse-1] 'cua-mouse-set-rectangle-mark) + (define-key cua--rectangle-keymap [down-mouse-1] 'cua--mouse-ignore) + (define-key cua--rectangle-keymap [drag-mouse-1] 'cua--mouse-ignore) + (define-key cua--rectangle-keymap [mouse-3] 'cua-mouse-save-then-kill-rectangle) + (define-key cua--rectangle-keymap [down-mouse-3] 'cua--mouse-ignore) + (define-key cua--rectangle-keymap [drag-mouse-3] 'cua--mouse-ignore) + + (cua--rect-M/H-key 'up 'cua-move-rectangle-up) + (cua--rect-M/H-key 'down 'cua-move-rectangle-down) + (cua--rect-M/H-key 'left 'cua-move-rectangle-left) + (cua--rect-M/H-key 'right 'cua-move-rectangle-right) + + (cua--rect-M/H-key '(control up) 'cua-scroll-rectangle-up) + (cua--rect-M/H-key '(control down) 'cua-scroll-rectangle-down) + + (cua--rect-M/H-key ?a 'cua-align-rectangle) + (cua--rect-M/H-key ?b 'cua-blank-rectangle) + (cua--rect-M/H-key ?c 'cua-close-rectangle) + (cua--rect-M/H-key ?f 'cua-fill-char-rectangle) + (cua--rect-M/H-key ?i 'cua-incr-rectangle) + (cua--rect-M/H-key ?k 'cua-cut-rectangle-as-text) + (cua--rect-M/H-key ?l 'cua-downcase-rectangle) + (cua--rect-M/H-key ?m 'cua-copy-rectangle-as-text) + (cua--rect-M/H-key ?n 'cua-sequence-rectangle) + (cua--rect-M/H-key ?o 'cua-open-rectangle) + (cua--rect-M/H-key ?p 'cua-toggle-rectangle-padding) + (cua--rect-M/H-key ?P 'cua-do-rectangle-padding) + (cua--rect-M/H-key ?q 'cua-refill-rectangle) + (cua--rect-M/H-key ?r 'cua-replace-in-rectangle) + (cua--rect-M/H-key ?R 'cua-reverse-rectangle) + (cua--rect-M/H-key ?s 'cua-string-rectangle) + (cua--rect-M/H-key ?t 'cua-text-fill-rectangle) + (cua--rect-M/H-key ?u 'cua-upcase-rectangle) + (cua--rect-M/H-key ?| 'cua-shell-command-on-rectangle) + (cua--rect-M/H-key ?' 'cua-restrict-prefix-rectangle) + (cua--rect-M/H-key ?/ 'cua-restrict-regexp-rectangle) + + (setq cua--rectangle-initialized t)) + +;;; cua-rect.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulation/keypad.el Sun Apr 28 21:48:39 2002 +0000 @@ -0,0 +1,185 @@ +;;; keypad.el --- simplified keypad bindings + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Kim F. Storm <storm@cua.dk> +;; Keywords: keyboard convenience + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The keypad package allows easy binding of the keypad keys to +;; various commonly used sets of commands. +;; +;; With the following setup, the keypad can be used for numeric data +;; entry, or to give numeric prefix arguments to emacs commands. +;; +;; (keypad-setup 'numeric) +;; (keypad-setup 'prefix t) +;; +;; +--------+--------+--------+ +;; | M-7 | M-8 | M-9 | +;; | 7 | 8 | 9 | +;; +--------+--------+--------+ +;; | M-4 | M-5 | M-6 | +;; | 4 | 5 | 6 | +;; +--------+--------+--------+ +;; | M-1 | M-2 | M-3 | +;; | 1 | 2 | 3 | +;; +--------+--------+--------+ +;; | M-0 | M-- | +;; | 0 | . | +;; +-----------------+--------+ + +;; The following keypad setup is used for navigation: +;; +;; (keypad-setup 'cursor) +;; (keypad-setup 'S-cursor t) +;; +;; +--------+--------+--------+ +;; | S-home | S-up | S-PgUp | +;; | Home | up | PgUp | +;; +--------+--------+--------+ +;; | S-left |S-space |S-right | +;; | left | space | right | +;; +--------+--------+--------+ +;; | S-end | S-down | S-PgDn | +;; | end | down | PgDn | +;; +--------+--------+--------+ +;; | S-insert |S-delete| +;; | insert | delete | +;; +-----------------+--------+ + + +;;; Code: + +(provide 'keypad) + +;;; Customization + +;;;###autoload +(defcustom keypad-setup nil + "Specifies the keypad setup for unshifted keypad keys. +The options are: + 'prefix Numeric prefix argument, i.e. M-0 .. M-9 and M-- + 'cursor Cursor movement keys. + 'S-cursor Shifted cursor movement keys. + 'numeric Plain numeric, i.e. 0 .. 9 and . (or DECIMAL arg) + 'none Removes all bindings for keypad keys in function-key-map. + nil Keep existing bindings for the keypad keys." + :set (lambda (symbol value) + (if value + (keypad-setup value nil keypad-decimal-key))) + :initialize 'custom-initialize-default + :set-after '(keypad-decimal-key) + :require 'keypad + :link '(emacs-commentary-link "keypad.el") + :version "21.4" + :type '(choice (const :tag "Numeric prefix arguments" prefix) + (const :tag "Cursor keys" cursor) + (const :tag "Shifted cursor keys" S-cursor) + (const :tag "Plain Numeric Keypad" numeric) + (const :tag "Remove bindings" none) + (other :tag "Keep existing bindings" :value nil)) + :group 'keyboard) + +(defcustom keypad-decimal-key ?. + "Character produced by the unshifted decimal key on the keypad." + :type 'character + :group 'keyboard) + +;;;###autoload +(defcustom keypad-shifted-setup nil + "Specifies the keypad setup for shifted keypad keys. +See `keypad-setup' for available options." + :set (lambda (symbol value) + (if value + (keypad-setup value t keypad-shifted-decimal-key))) + :initialize 'custom-initialize-default + :set-after '(keypad-shifted-decimal-key) + :require 'keypad + :link '(emacs-commentary-link "keypad.el") + :version "21.4" + :type '(choice (const :tag "Numeric prefix arguments" prefix) + (const :tag "Cursor keys" cursor) + (const :tag "Shifted cursor keys" S-cursor) + (const :tag "Plain Numeric Keypad" numeric) + (const :tag "Remove bindings" none) + (other :tag "Keep existing bindings" :value nil)) + :group 'keyboard) + +(defcustom keypad-shifted-decimal-key ?. + "Character produced by the unshifted decimal key on the keypad." + :type 'character + :group 'keyboard) + +;;;###autoload +(defun keypad-setup (setup &optional numlock decimal) + "Set keypad bindings in function-key-map according to SETUP. +If optional second argument NUMLOCK is non-nil, the NumLock On bindings +are changed. Otherwise, the NumLock Off bindings are changed. + + Setup Binding + ------------------------------------------------------------- + 'prefix Command prefix argument, i.e. M-0 .. M-9 and M-- + 'S-cursor Bind shifted keypad keys to the shifted cursor movement keys. + 'cursor Bind keypad keys to the cursor movement keys. + 'numeric Plain numeric, i.e. 0 .. 9 and . (or DECIMAL arg) + 'none Removes all bindings for keypad keys in function-key-map. + +If SETUP is 'numeric and the optional third argument DECIMAL is non-nil, +the decimal key on the keypad is mapped to DECIMAL instead of `.'" + (let ((i 0) + (kp + (cond + (numlock + [kp-decimal kp-0 kp-1 kp-2 kp-3 kp-4 + kp-5 kp-6 kp-7 kp-8 kp-9]) + (t + [kp-delete kp-insert kp-end kp-down kp-next kp-left + kp-space kp-right kp-home kp-up kp-prior]))) + (bind + (cond + ((eq setup 'numeric) + (vector (or decimal ?.) ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) + ((eq setup 'prefix) + [?\M-- ?\M-0 ?\M-1 ?\M-2 ?\M-3 ?\M-4 + ?\M-5 ?\M-6 ?\M-7 ?\M-8 ?\M-9]) + ((eq setup 'cursor) + [delete insert end down next left + space right home up prior]) + ((eq setup 'S-cursor) + [S-delete S-insert S-end S-down S-next S-left + S-space S-right S-home S-up S-prior]) + ((eq setup 'none) + nil) + (t + (signal 'error (list "Unknown keypad setup: " setup)))))) + + ;; Bind the keys in KP list to BIND list in function-key-map. + ;; If BIND is nil, all bindings for the keys are removed. + (if (not (boundp 'function-key-map)) + (setq function-key-map (make-sparse-keymap))) + + (while (< i 11) + (define-key function-key-map (vector (aref kp i)) + (if bind (vector (aref bind i)))) + (setq i (1+ i))))) + +;;; keypad.el ends here