code.delx.au - gnu-emacs/blob - lisp/s-region.el

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