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 |
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 |
|
|
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. |
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 |
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) |
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 |
|
|
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) |