# HG changeset patch
# User Kim F. Storm <storm@cua.dk>
# Date 1020030519 0
# Node ID 358d42530d42ec336eeee0fd5256573d744d72e1
# Parent  75c89848438b2ced208f4eaa76f54e782e646936
Added cua-mode based files [split from original cua.el]:
cua-base.el, cua-rect.el, cua-gmrk.el, and keypad.el

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