/[emacs]/emacs/lisp/emulation/cua-base.el
ViewVC logotype

Diff of /emacs/lisp/emulation/cua-base.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.25.2.1 by handa, Fri Apr 16 12:50:14 2004 UTC revision 1.25.2.2 by miles, Mon Jun 28 07:29:46 2004 UTC
# Line 1  Line 1 
1  ;;; cua-base.el --- emulate CUA key bindings  ;;; cua-base.el --- emulate CUA key bindings
2    
3  ;; Copyright (C) 1997,98,99,200,01,02,03  Free Software Foundation, Inc.  ;; Copyright (C) 1997,98,99,200,01,02,03,04  Free Software Foundation, Inc.
4    
5  ;; Author: Kim F. Storm <storm@cua.dk>  ;; Author: Kim F. Storm <storm@cua.dk>
6  ;; Keywords: keyboard emulation convenience cua  ;; Keywords: keyboard emulation convenience cua
# Line 413  Can be toggled by [M-p] while the rectan Line 413  Can be toggled by [M-p] while the rectan
413                                         "red")                                         "red")
414    "Normal (non-overwrite) cursor color.    "Normal (non-overwrite) cursor color.
415  Also used to indicate that rectangle padding is not in effect.  Also used to indicate that rectangle padding is not in effect.
416  Default is to load cursor color from initial or default frame parameters."  Default is to load cursor color from initial or default frame parameters.
417    
418    If the value is a COLOR name, then only the `cursor-color' attribute will be
419    affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
420    then only the `cursor-type' property will be affected.  If the value is
421    a cons (TYPE . COLOR), then both properties are affected."
422    :initialize 'custom-initialize-default    :initialize 'custom-initialize-default
423    :type 'color    :type '(choice
424              (color :tag "Color")
425              (choice :tag "Type"
426                      (const :tag "Filled box" box)
427                      (const :tag "Vertical bar" bar)
428                      (const :tag "Horisontal bar" hbar)
429                      (const :tag "Hollow box" hollow))
430              (cons :tag "Color and Type"
431                    (choice :tag "Type"
432                            (const :tag "Filled box" box)
433                            (const :tag "Vertical bar" bar)
434                            (const :tag "Horisontal bar" hbar)
435                            (const :tag "Hollow box" hollow))
436                    (color :tag "Color")))
437    :group 'cua)    :group 'cua)
438    
439  (defcustom cua-read-only-cursor-color "darkgreen"  (defcustom cua-read-only-cursor-color "darkgreen"
440    "*Cursor color used in read-only buffers, if non-nil.    "*Cursor color used in read-only buffers, if non-nil.
441  Only used when `cua-enable-cursor-indications' is non-nil."  Only used when `cua-enable-cursor-indications' is non-nil.
442    :type 'color  
443    If the value is a COLOR name, then only the `cursor-color' attribute will be
444    affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
445    then only the `cursor-type' property will be affected.  If the value is
446    a cons (TYPE . COLOR), then both properties are affected."
447      :type '(choice
448              (color :tag "Color")
449              (choice :tag "Type"
450                      (const :tag "Filled box" box)
451                      (const :tag "Vertical bar" bar)
452                      (const :tag "Horisontal bar" hbar)
453                      (const :tag "Hollow box" hollow))
454              (cons :tag "Color and Type"
455                    (choice :tag "Type"
456                            (const :tag "Filled box" box)
457                            (const :tag "Vertical bar" bar)
458                            (const :tag "Horisontal bar" hbar)
459                            (const :tag "Hollow box" hollow))
460                    (color :tag "Color")))
461    :group 'cua)    :group 'cua)
462    
463  (defcustom cua-overwrite-cursor-color "yellow"  (defcustom cua-overwrite-cursor-color "yellow"
464    "*Cursor color used when overwrite mode is set, if non-nil.    "*Cursor color used when overwrite mode is set, if non-nil.
465  Also used to indicate that rectangle padding is in effect.  Also used to indicate that rectangle padding is in effect.
466  Only used when `cua-enable-cursor-indications' is non-nil."  Only used when `cua-enable-cursor-indications' is non-nil.
467    :type 'color  
468    If the value is a COLOR name, then only the `cursor-color' attribute will be
469    affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
470    then only the `cursor-type' property will be affected.  If the value is
471    a cons (TYPE . COLOR), then both properties are affected."
472      :type '(choice
473              (color :tag "Color")
474              (choice :tag "Type"
475                      (const :tag "Filled box" box)
476                      (const :tag "Vertical bar" bar)
477                      (const :tag "Horisontal bar" hbar)
478                      (const :tag "Hollow box" hollow))
479              (cons :tag "Color and Type"
480                    (choice :tag "Type"
481                            (const :tag "Filled box" box)
482                            (const :tag "Vertical bar" bar)
483                            (const :tag "Horisontal bar" hbar)
484                            (const :tag "Hollow box" hollow))
485                    (color :tag "Color")))
486    :group 'cua)    :group 'cua)
487    
488  (defcustom cua-global-mark-cursor-color "cyan"  (defcustom cua-global-mark-cursor-color "cyan"
489    "*Indication for active global mark.    "*Indication for active global mark.
490  Will change cursor color to specified color if string.  Will change cursor color to specified color if string.
491  Only used when `cua-enable-cursor-indications' is non-nil."  Only used when `cua-enable-cursor-indications' is non-nil.
492    :type 'color  
493    If the value is a COLOR name, then only the `cursor-color' attribute will be
494    affected.  If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
495    then only the `cursor-type' property will be affected.  If the value is
496    a cons (TYPE . COLOR), then both properties are affected."
497      :type '(choice
498              (color :tag "Color")
499              (choice :tag "Type"
500                      (const :tag "Filled box" box)
501                      (const :tag "Vertical bar" bar)
502                      (const :tag "Horisontal bar" hbar)
503                      (const :tag "Hollow box" hollow))
504              (cons :tag "Color and Type"
505                    (choice :tag "Type"
506                            (const :tag "Filled box" box)
507                            (const :tag "Vertical bar" bar)
508                            (const :tag "Horisontal bar" hbar)
509                            (const :tag "Hollow box" hollow))
510                    (color :tag "Color")))
511    :group 'cua)    :group 'cua)
512    
513    
# Line 893  With a double \\[universal-argument] pre Line 965  With a double \\[universal-argument] pre
965      forward-word backward-word      forward-word backward-word
966      end-of-line beginning-of-line      end-of-line beginning-of-line
967      end-of-buffer beginning-of-buffer      end-of-buffer beginning-of-buffer
968      scroll-up scroll-down      scroll-up scroll-down cua-scroll-up cua-scroll-down
969      forward-sentence backward-sentence      forward-sentence backward-sentence
970      forward-paragraph backward-paragraph)      forward-paragraph backward-paragraph)
971    "List of standard movement commands.    "List of standard movement commands.
# Line 903  Extra commands should be added to `cua-m Line 975  Extra commands should be added to `cua-m
975    "User may add additional movement commands to this list.")    "User may add additional movement commands to this list.")
976    
977    
978    ;;; Scrolling commands which does not signal errors at top/bottom
979    ;;; of buffer at first key-press (instead moves to top/bottom
980    ;;; of buffer).
981    
982    (defun cua-scroll-up (&optional arg)
983      "Scroll text of current window upward ARG lines; or near full screen if no ARG.
984    If window cannot be scrolled further, move cursor to bottom line instead.
985    A near full screen is `next-screen-context-lines' less than a full screen.
986    Negative ARG means scroll downward.
987    If ARG is the atom `-', scroll downward by nearly full screen."
988      (interactive "P")
989      (cond
990       ((eq arg '-) (cua-scroll-down nil))
991       ((< (prefix-numeric-value arg) 0)
992        (cua-scroll-down (- (prefix-numeric-value arg))))
993       ((eobp)
994        (scroll-up arg))  ; signal error
995       (t
996        (condition-case nil
997            (scroll-up arg)
998          (end-of-buffer (goto-char (point-max)))))))
999    
1000    (defun cua-scroll-down (&optional arg)
1001      "Scroll text of current window downward ARG lines; or near full screen if no ARG.
1002    If window cannot be scrolled further, move cursor to top line instead.
1003    A near full screen is `next-screen-context-lines' less than a full screen.
1004    Negative ARG means scroll upward.
1005    If ARG is the atom `-', scroll upward by nearly full screen."
1006      (interactive "P")
1007      (cond
1008       ((eq arg '-) (cua-scroll-up nil))
1009       ((< (prefix-numeric-value arg) 0)
1010        (cua-scroll-up (- (prefix-numeric-value arg))))
1011       ((bobp)
1012        (scroll-down arg))  ; signal error
1013       (t
1014        (condition-case nil
1015            (scroll-down arg)
1016          (beginning-of-buffer (goto-char (point-min)))))))
1017    
1018  ;;; Cursor indications  ;;; Cursor indications
1019    
1020  (defun cua--update-indications ()  (defun cua--update-indications ()
1021    (let ((cursor    (let* ((cursor
1022           (cond            (cond
1023            ((and cua--global-mark-active             ((and cua--global-mark-active
1024                  (stringp cua-global-mark-cursor-color))                   cua-global-mark-cursor-color)
1025             cua-global-mark-cursor-color)              cua-global-mark-cursor-color)
1026            ((and buffer-read-only             ((and buffer-read-only
1027                  (stringp cua-read-only-cursor-color))                   cua-read-only-cursor-color)
1028             cua-read-only-cursor-color)              cua-read-only-cursor-color)
1029            ((and (stringp cua-overwrite-cursor-color)             ((and cua-overwrite-cursor-color
1030                  (or overwrite-mode                   (or overwrite-mode
1031                      (and cua--rectangle (cua--rectangle-padding))))                       (and cua--rectangle (cua--rectangle-padding))))
1032             cua-overwrite-cursor-color)              cua-overwrite-cursor-color)
1033            (t cua-normal-cursor-color))))             (t cua-normal-cursor-color)))
1034      (if (and cursor           (color (if (consp cursor) (cdr cursor) cursor))
1035               (not (equal cursor (frame-parameter nil 'cursor-color))))           (type (if (consp cursor) (car cursor) cursor)))
1036          (set-cursor-color cursor))      (if (and color
1037      cursor))               (stringp color)
1038                 (not (equal color (frame-parameter nil 'cursor-color))))
1039            (set-cursor-color color))
1040        (if (and type
1041                 (symbolp type)
1042                 (not (eq type default-cursor-type)))
1043            (setq default-cursor-type type))))
1044    
1045    
1046  ;;; Pre-command hook  ;;; Pre-command hook
# Line 1108  Extra commands should be added to `cua-m Line 1226  Extra commands should be added to `cua-m
1226    (define-key cua-global-keymap [remap undo]            'cua-undo)    (define-key cua-global-keymap [remap undo]            'cua-undo)
1227    (define-key cua-global-keymap [remap advertised-undo] 'cua-undo)    (define-key cua-global-keymap [remap advertised-undo] 'cua-undo)
1228    
1229      ;; scrolling
1230      (define-key cua-global-keymap [remap scroll-up]       'cua-scroll-up)
1231      (define-key cua-global-keymap [remap scroll-down]     'cua-scroll-down)
1232    
1233    (define-key cua--cua-keys-keymap [(control x) timeout] 'kill-region)    (define-key cua--cua-keys-keymap [(control x) timeout] 'kill-region)
1234    (define-key cua--cua-keys-keymap [(control c) timeout] 'copy-region-as-kill)    (define-key cua--cua-keys-keymap [(control c) timeout] 'copy-region-as-kill)
1235    (define-key cua--cua-keys-keymap [(control z)] 'undo)    (define-key cua--cua-keys-keymap [(control z)] 'undo)
# Line 1189  paste (in addition to the normal emacs b Line 1311  paste (in addition to the normal emacs b
1311          (add-hook 'post-command-hook 'cua--post-command-handler)          (add-hook 'post-command-hook 'cua--post-command-handler)
1312          (if (and cua-enable-modeline-indications (not (assoc 'cua-mode minor-mode-alist)))          (if (and cua-enable-modeline-indications (not (assoc 'cua-mode minor-mode-alist)))
1313              (setq minor-mode-alist (cons '(cua-mode cua--status-string) minor-mode-alist)))              (setq minor-mode-alist (cons '(cua-mode cua--status-string) minor-mode-alist)))
1314          )          (if cua-enable-cursor-indications
1315                (cua--update-indications)))
1316    
1317      (remove-hook 'pre-command-hook 'cua--pre-command-handler)      (remove-hook 'pre-command-hook 'cua--pre-command-handler)
1318      (remove-hook 'post-command-hook 'cua--post-command-handler))      (remove-hook 'post-command-hook 'cua--post-command-handler))
1319    
# Line 1212  paste (in addition to the normal emacs b Line 1336  paste (in addition to the normal emacs b
1336          (delete-selection-mode -1))          (delete-selection-mode -1))
1337      (if (and (boundp 'pc-selection-mode) pc-selection-mode)      (if (and (boundp 'pc-selection-mode) pc-selection-mode)
1338          (pc-selection-mode -1))          (pc-selection-mode -1))
1339        (cua--deactivate)
1340      (setq transient-mark-mode (and cua-mode      (setq transient-mark-mode (and cua-mode
1341                                     (if cua-highlight-region-shift-only                                     (if cua-highlight-region-shift-only
1342                                         (not cua--explicit-region-start)                                         (not cua--explicit-region-start)

Legend:
Removed from v.1.25.2.1  
changed lines
  Added in v.1.25.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26