1;;; s-region.el --- set region using shift key
2
3;; Copyright (C) 1994, 1995, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 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'.
88Each key in KEYLIST is shifted and bound to one of the `s-region-move'
89functions provided it is already bound to some command or other.
90Optional second argument MAP specifies keymap to add binding to, defaulting
91to 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
127