]> code.delx.au - gnu-emacs/blob - lisp/s-region.el
(Abbrevs): A @node line without explicit Prev, Next, and Up links.
[gnu-emacs] / lisp / s-region.el
1 ;;; s-region.el --- set region using shift key
2
3 ;; Copyright (C) 1994, 1995, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
5
6 ;; Author: Morten Welinder <terra@diku.dk>
7 ;; Keywords: terminals
8 ;; Favourite-brand-of-beer: None, I hate beer.
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
26
27 ;;; Commentary:
28
29 ;; Having loaded this code you can set the region by holding down the
30 ;; shift key and move the cursor to the other end of the region. The
31 ;; functionality provided by this code is similar to that provided by
32 ;; the editors of Borland International's compilers for ms-dos.
33
34 ;; Currently, s-region-move may be bound only to events that are vectors
35 ;; of length one and whose last element is a symbol. Also, the functions
36 ;; that are given this kind of overlay should be (interactive "p")
37 ;; functions.
38
39 ;; If the following keys are not already bound then...
40 ;; C-insert is bound to copy-region-as-kill
41 ;; S-delete is bound to kill-region
42 ;; S-insert is bound to yank
43
44 ;;; Code:
45
46 (defvar s-region-overlay (make-overlay 1 1))
47 (overlay-put s-region-overlay 'face 'region)
48 (overlay-put s-region-overlay 'priority 1000000) ; for hilit19
49
50 (defun s-region-unshift (key)
51 "Remove shift modifier from last keypress KEY and return that as a key."
52 (if (vectorp key)
53 (let ((last (aref key (1- (length key)))))
54 (if (symbolp last)
55 (let* ((keyname (symbol-name last))
56 (pos (string-match "S-" keyname)))
57 (if pos
58 ;; We skip all initial parts of the event assuming that
59 ;; those are setting up the prefix argument to the command.
60 (vector (intern (concat (substring keyname 0 pos)
61 (substring keyname (+ 2 pos)))))
62 (error "Non-shifted key: %S" key)))
63 (error "Key does not end in a symbol: %S" key)))
64 (error "Non-vector key: %S" key)))
65
66 (defun s-region-move-p1 (&rest arg)
67 "This is an overlay function to point-moving keys that are interactive \"p\"."
68 (interactive "p")
69 (apply (function s-region-move) arg))
70
71 (defun s-region-move-p2 (&rest arg)
72 "This is an overlay function to point-moving keys that are interactive \"P\"."
73 (interactive "P")
74 (apply (function s-region-move) arg))
75
76 (defun s-region-move (&rest arg)
77 (if (if mark-active (not (equal last-command 's-region-move)) t)
78 (set-mark-command nil)
79 (message "")) ; delete the "Mark set" message
80 (setq this-command 's-region-move)
81 (apply (key-binding (s-region-unshift (this-command-keys))) arg)
82 (move-overlay s-region-overlay (mark) (point) (current-buffer))
83 (sit-for 1)
84 (delete-overlay s-region-overlay))
85
86 (defun s-region-bind (keylist &optional map)
87 "Bind shifted keys in KEYLIST to `s-region-move-p1' or `s-region-move-p2'.
88 Each key in KEYLIST is shifted and bound to one of the `s-region-move'
89 functions provided it is already bound to some command or other.
90 Optional second argument MAP specifies keymap to add binding to, defaulting
91 to global keymap."
92 (let ((p2 (list 'scroll-up 'scroll-down
93 'beginning-of-buffer 'end-of-buffer)))
94 (or map (setq map global-map))
95 (while keylist
96 (let* ((key (car keylist))
97 (binding (key-binding key)))
98 (if (commandp binding)
99 (define-key
100 map
101 (vector (intern (concat "S-" (symbol-name (aref key 0)))))
102 (cond ((memq binding p2)
103 's-region-move-p2)
104 (t 's-region-move-p1)))))
105 (setq keylist (cdr keylist)))))
106
107 ;; Single keys (plus modifiers) only!
108 (s-region-bind
109 (list [right] [left] [up] [down]
110 [C-left] [C-right] [C-up] [C-down]
111 [M-left] [M-right] [M-up] [M-down]
112 [next] [previous] [home] [end]
113 [C-next] [C-previous] [C-home] [C-end]
114 [M-next] [M-previous] [M-home] [M-end]))
115
116 (or (global-key-binding [C-insert])
117 (global-set-key [C-insert] 'copy-region-as-kill))
118 (or (global-key-binding [S-delete])
119 (global-set-key [S-delete] 'kill-region))
120 (or (global-key-binding [S-insert])
121 (global-set-key [S-insert] 'yank))
122
123 (provide 's-region)
124
125 ;;; arch-tag: a471e912-18d7-4247-a29b-2100bca180ff
126 ;;; s-region.el ends here