[Emacs-diffs] Changes to emacs/lisp/emulation/cua-base.el [emacs-unicode-2]

[Miles Bader]

Index: emacs/lisp/emulation/cua-base.el
diff -c emacs/lisp/emulation/cua-base.el:1.25.2.1 
emacs/lisp/emulation/cua-base.el:1.25.2.2
*** emacs/lisp/emulation/cua-base.el:1.25.2.1   Fri Apr 16 12:50:14 2004
--- emacs/lisp/emulation/cua-base.el    Mon Jun 28 07:29:46 2004
***************
*** 1,6 ****
  ;;; cua-base.el --- emulate CUA key bindings
  
! ;; Copyright (C) 1997,98,99,200,01,02,03  Free Software Foundation, Inc.
  
  ;; Author: Kim F. Storm <address@hidden>
  ;; Keywords: keyboard emulation convenience cua
--- 1,6 ----
  ;;; cua-base.el --- emulate CUA key bindings
  
! ;; Copyright (C) 1997,98,99,200,01,02,03,04  Free Software Foundation, Inc.
  
  ;; Author: Kim F. Storm <address@hidden>
  ;; Keywords: keyboard emulation convenience cua
***************
*** 413,441 ****
                                       "red")
    "Normal (non-overwrite) cursor color.
  Also used to indicate that rectangle padding is not in effect.
! Default is to load cursor color from initial or default frame parameters."
    :initialize 'custom-initialize-default
!   :type 'color
    :group 'cua)
  
  (defcustom cua-read-only-cursor-color "darkgreen"
    "*Cursor color used in read-only buffers, if non-nil.
! Only used when `cua-enable-cursor-indications' is non-nil."
!   :type 'color
    :group 'cua)
  
  (defcustom cua-overwrite-cursor-color "yellow"
    "*Cursor color used when overwrite mode is set, if non-nil.
  Also used to indicate that rectangle padding is in effect.
! Only used when `cua-enable-cursor-indications' is non-nil."
!   :type 'color
    :group 'cua)
  
  (defcustom cua-global-mark-cursor-color "cyan"
    "*Indication for active global mark.
  Will change cursor color to specified color if string.
! Only used when `cua-enable-cursor-indications' is non-nil."
!   :type 'color
    :group 'cua)
  
  
--- 413,513 ----
                                       "red")
    "Normal (non-overwrite) cursor color.
  Also used to indicate that rectangle padding is not in effect.
! Default is to load cursor color from initial or default frame parameters.
! 
! If the value is a COLOR name, then only the `cursor-color' attribute will be
! affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
! then only the `cursor-type' property will be affected.  If the value is
! a cons (TYPE . COLOR), then both properties are affected."
    :initialize 'custom-initialize-default
!   :type '(choice
!         (color :tag "Color")
!         (choice :tag "Type"
!                 (const :tag "Filled box" box)
!                 (const :tag "Vertical bar" bar)
!                 (const :tag "Horisontal bar" hbar)
!                 (const :tag "Hollow box" hollow))
!         (cons :tag "Color and Type"
!               (choice :tag "Type"
!                       (const :tag "Filled box" box)
!                       (const :tag "Vertical bar" bar)
!                       (const :tag "Horisontal bar" hbar)
!                       (const :tag "Hollow box" hollow))
!               (color :tag "Color")))
    :group 'cua)
  
  (defcustom cua-read-only-cursor-color "darkgreen"
    "*Cursor color used in read-only buffers, if non-nil.
! Only used when `cua-enable-cursor-indications' is non-nil.
! 
! If the value is a COLOR name, then only the `cursor-color' attribute will be
! affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
! then only the `cursor-type' property will be affected.  If the value is
! a cons (TYPE . COLOR), then both properties are affected."
!   :type '(choice
!         (color :tag "Color")
!         (choice :tag "Type"
!                 (const :tag "Filled box" box)
!                 (const :tag "Vertical bar" bar)
!                 (const :tag "Horisontal bar" hbar)
!                 (const :tag "Hollow box" hollow))
!         (cons :tag "Color and Type"
!               (choice :tag "Type"
!                       (const :tag "Filled box" box)
!                       (const :tag "Vertical bar" bar)
!                       (const :tag "Horisontal bar" hbar)
!                       (const :tag "Hollow box" hollow))
!               (color :tag "Color")))
    :group 'cua)
  
  (defcustom cua-overwrite-cursor-color "yellow"
    "*Cursor color used when overwrite mode is set, if non-nil.
  Also used to indicate that rectangle padding is in effect.
! Only used when `cua-enable-cursor-indications' is non-nil.
! 
! If the value is a COLOR name, then only the `cursor-color' attribute will be
! affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
! then only the `cursor-type' property will be affected.  If the value is
! a cons (TYPE . COLOR), then both properties are affected."
!   :type '(choice
!         (color :tag "Color")
!         (choice :tag "Type"
!                 (const :tag "Filled box" box)
!                 (const :tag "Vertical bar" bar)
!                 (const :tag "Horisontal bar" hbar)
!                 (const :tag "Hollow box" hollow))
!         (cons :tag "Color and Type"
!               (choice :tag "Type"
!                       (const :tag "Filled box" box)
!                       (const :tag "Vertical bar" bar)
!                       (const :tag "Horisontal bar" hbar)
!                       (const :tag "Hollow box" hollow))
!               (color :tag "Color")))
    :group 'cua)
  
  (defcustom cua-global-mark-cursor-color "cyan"
    "*Indication for active global mark.
  Will change cursor color to specified color if string.
! Only used when `cua-enable-cursor-indications' is non-nil.
! 
! If the value is a COLOR name, then only the `cursor-color' attribute will be
! affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
! then only the `cursor-type' property will be affected.  If the value is
! a cons (TYPE . COLOR), then both properties are affected."
!   :type '(choice
!         (color :tag "Color")
!         (choice :tag "Type"
!                 (const :tag "Filled box" box)
!                 (const :tag "Vertical bar" bar)
!                 (const :tag "Horisontal bar" hbar)
!                 (const :tag "Hollow box" hollow))
!         (cons :tag "Color and Type"
!               (choice :tag "Type"
!                       (const :tag "Filled box" box)
!                       (const :tag "Vertical bar" bar)
!                       (const :tag "Horisontal bar" hbar)
!                       (const :tag "Hollow box" hollow))
!               (color :tag "Color")))
    :group 'cua)
  
  
***************
*** 893,899 ****
      forward-word backward-word
      end-of-line beginning-of-line
      end-of-buffer beginning-of-buffer
!     scroll-up scroll-down
      forward-sentence backward-sentence
      forward-paragraph backward-paragraph)
    "List of standard movement commands.
--- 965,971 ----
      forward-word backward-word
      end-of-line beginning-of-line
      end-of-buffer beginning-of-buffer
!     scroll-up scroll-down cua-scroll-up cua-scroll-down
      forward-sentence backward-sentence
      forward-paragraph backward-paragraph)
    "List of standard movement commands.
***************
*** 903,928 ****
    "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
--- 975,1046 ----
    "User may add additional movement commands to this list.")
  
  
+ ;;; Scrolling commands which does not signal errors at top/bottom
+ ;;; of buffer at first key-press (instead moves to top/bottom
+ ;;; of buffer).
+ 
+ (defun cua-scroll-up (&optional arg)
+   "Scroll text of current window upward ARG lines; or near full screen if no 
ARG.
+ If window cannot be scrolled further, move cursor to bottom line instead.
+ A near full screen is `next-screen-context-lines' less than a full screen.
+ Negative ARG means scroll downward.
+ If ARG is the atom `-', scroll downward by nearly full screen."
+   (interactive "P")
+   (cond
+    ((eq arg '-) (cua-scroll-down nil))
+    ((< (prefix-numeric-value arg) 0)
+     (cua-scroll-down (- (prefix-numeric-value arg))))
+    ((eobp)
+     (scroll-up arg))  ; signal error
+    (t
+     (condition-case nil
+       (scroll-up arg)
+       (end-of-buffer (goto-char (point-max)))))))
+ 
+ (defun cua-scroll-down (&optional arg)
+   "Scroll text of current window downward ARG lines; or near full screen if 
no ARG.
+ If window cannot be scrolled further, move cursor to top line instead.
+ A near full screen is `next-screen-context-lines' less than a full screen.
+ Negative ARG means scroll upward.
+ If ARG is the atom `-', scroll upward by nearly full screen."
+   (interactive "P")
+   (cond
+    ((eq arg '-) (cua-scroll-up nil))
+    ((< (prefix-numeric-value arg) 0)
+     (cua-scroll-up (- (prefix-numeric-value arg))))
+    ((bobp)
+     (scroll-down arg))  ; signal error
+    (t
+     (condition-case nil
+       (scroll-down arg)
+       (beginning-of-buffer (goto-char (point-min)))))))
+ 
  ;;; Cursor indications
  
  (defun cua--update-indications ()
!   (let* ((cursor
!         (cond
!          ((and cua--global-mark-active
!                cua-global-mark-cursor-color)
!           cua-global-mark-cursor-color)
!          ((and buffer-read-only
!                cua-read-only-cursor-color)
!           cua-read-only-cursor-color)
!          ((and cua-overwrite-cursor-color
!                (or overwrite-mode
!                    (and cua--rectangle (cua--rectangle-padding))))
!           cua-overwrite-cursor-color)
!          (t cua-normal-cursor-color)))
!        (color (if (consp cursor) (cdr cursor) cursor))
!        (type (if (consp cursor) (car cursor) cursor)))
!     (if (and color
!            (stringp color)
!            (not (equal color (frame-parameter nil 'cursor-color))))
!       (set-cursor-color color))
!     (if (and type
!            (symbolp type)
!            (not (eq type default-cursor-type)))
!       (setq default-cursor-type type))))
  
  
  ;;; Pre-command hook
***************
*** 1108,1113 ****
--- 1226,1235 ----
    (define-key cua-global-keymap [remap undo]          'cua-undo)
    (define-key cua-global-keymap [remap advertised-undo]       'cua-undo)
  
+   ;; scrolling
+   (define-key cua-global-keymap [remap scroll-up]     'cua-scroll-up)
+   (define-key cua-global-keymap [remap scroll-down]   'cua-scroll-down)
+ 
    (define-key cua--cua-keys-keymap [(control x) timeout] 'kill-region)
    (define-key cua--cua-keys-keymap [(control c) timeout] 'copy-region-as-kill)
    (define-key cua--cua-keys-keymap [(control z)] 'undo)
***************
*** 1189,1195 ****
        (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))
  
--- 1311,1319 ----
        (add-hook 'post-command-hook 'cua--post-command-handler)
        (if (and cua-enable-modeline-indications (not (assoc 'cua-mode 
minor-mode-alist)))
            (setq minor-mode-alist (cons '(cua-mode cua--status-string) 
minor-mode-alist)))
!       (if cua-enable-cursor-indications
!           (cua--update-indications)))
! 
      (remove-hook 'pre-command-hook 'cua--pre-command-handler)
      (remove-hook 'post-command-hook 'cua--post-command-handler))
  
***************
*** 1212,1217 ****
--- 1336,1342 ----
        (delete-selection-mode -1))
      (if (and (boundp 'pc-selection-mode) pc-selection-mode)
        (pc-selection-mode -1))
+     (cua--deactivate)
      (setq transient-mark-mode (and cua-mode
                                   (if cua-highlight-region-shift-only
                                       (not cua--explicit-region-start)