--- /dev/null
+;;; 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
+;;; 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
+;;; 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
+;;; 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
projects / emacs.git / commitdiff