annotate lisp/s-region.el @ 83310:e58cb448e07c

Merged from [e-mail]--gnu-2005 (patch 80-82, 350-422) Patches applied: * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-350 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-351 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-352 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-353 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-354 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-355 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-356 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-357 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-358 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-359 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-360 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-361 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-362 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-363 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-364 Remove "-face" suffix from widget faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-365 Remove "-face" suffix from custom faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-366 Remove "-face" suffix from change-log faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-367 Remove "-face" suffix from compilation faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-368 Remove "-face" suffix from diff-mode faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-369 lisp/longlines.el (longlines-visible-face): Face removed * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-370 Remove "-face" suffix from woman faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-371 Remove "-face" suffix from whitespace-highlight face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-372 Remove "-face" suffix from ruler-mode faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-373 Remove "-face" suffix from show-paren faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-374 Remove "-face" suffix from log-view faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-375 Remove "-face" suffix from smerge faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-376 Remove "-face" suffix from show-tabs faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-377 Remove "-face" suffix from highlight-changes faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-378 Remove "-face" suffix from and downcase info faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-379 Remove "-face" suffix from pcvs faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-380 Update uses of renamed pcvs faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-381 Tweak ChangeLog * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-382 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-383 Remove "-face" suffix from strokes-char face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-384 Remove "-face" suffix from compare-windows face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-385 Remove "-face" suffix from calendar faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-386 Remove "-face" suffix from diary-button face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-387 Remove "-face" suffix from testcover faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-388 Remove "-face" suffix from viper faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-389 Remove "-face" suffix from org faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-390 Remove "-face" suffix from sgml-namespace face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-391 Remove "-face" suffix from table-cell face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-392 Remove "-face" suffix from tex-mode faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-393 Remove "-face" suffix from texinfo-heading face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-394 Remove "-face" suffix from flyspell faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-395 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-396 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-397 Remove "-face" suffix from gomoku faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-398 Remove "-face" suffix from mpuz faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-399 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-400 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-401 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-402 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-403 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-404 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-405 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-406 Merge from gnus--rel--5.10 * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-407 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-408 Remove "-face" suffix from Buffer-menu-buffer face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-409 Remove "-face" suffix from antlr-mode faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-410 Remove "-face" suffix from ebrowse faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-411 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-412 Remove "-face" suffix from flymake faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-413 Remove "-face" suffix from idlwave faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-414 Remove "-face" suffix from sh-script faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-415 Remove "-face" suffix from vhdl-mode faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-416 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-417 Remove "-face" suffix from which-func face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-418 Remove "-face" suffix from cperl-mode faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-419 Remove "-face" suffix from ld-script faces * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-420 Fix cperl-mode font-lock problem * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-421 Tweak which-func face * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-422 Update from CVS * [e-mail]--gnu-2005/gnus--rel--5.10--patch-80 Merge from emacs--cvs-trunk--0 * [e-mail]--gnu-2005/gnus--rel--5.10--patch-81 Update from CVS * [e-mail]--gnu-2005/gnus--rel--5.10--patch-82 Update from CVS git-archimport-id: [e-mail]--2004/emacs--multi-tty--0--patch-350

;;; s-region.el --- set region using shift key

;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.

;; Author: Morten Welinder <[e-mail]>
;; Keywords: terminals
;; Favourite-brand-of-beer: None, I hate beer.

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Having loaded this code you can set the region by holding down the
;; shift key and move the cursor to the other end of the region.  The
;; functionality provided by this code is similar to that provided by
;; the editors of Borland International's compilers for ms-dos.

;; Currently, s-region-move may be bound only to events that are vectors
;; of length one and whose last element is a symbol.  Also, the functions
;; that are given this kind of overlay should be (interactive "p")
;; functions.

;; If the following keys are not already bound then...
;; C-insert is bound to copy-region-as-kill
;; S-delete is bound to kill-region
;; S-insert is bound to yank

;;; Code:

(defvar s-region-overlay (make-overlay 1 1))
(overlay-put s-region-overlay 'face 'region)
(overlay-put s-region-overlay 'priority 1000000) ; for hilit19

(defun s-region-unshift (key)
  "Remove shift modifier from last keypress KEY and return that as a key."
  (if (vectorp key)
      (let ((last (aref key (1- (length key)))))
	(if (symbolp last)
	    (let* ((keyname (symbol-name last))
		   (pos (string-match "S-" keyname)))
	      (if pos
		  ;; We skip all initial parts of the event assuming that
		  ;; those are setting up the prefix argument to the command.
		  (vector (intern (concat (substring keyname 0 pos)
					  (substring keyname (+ 2 pos)))))
		(error "Non-shifted key: %S" key)))
	  (error "Key does not end in a symbol: %S" key)))
    (error "Non-vector key: %S" key)))

(defun s-region-move-p1 (&rest arg)
  "This is an overlay function to point-moving keys that are interactive \"p\""
  (interactive "p")
  (apply (function s-region-move) arg))

(defun s-region-move-p2 (&rest arg)
  "This is an overlay function to point-moving keys that are interactive \"P\""
  (interactive "P")
  (apply (function s-region-move) arg))

(defun s-region-move (&rest arg)
  (if (if mark-active (not (equal last-command 's-region-move)) t)
      (set-mark-command nil)
    (message "")) ; delete the "Mark set" message
  (setq this-command 's-region-move)
  (apply (key-binding (s-region-unshift (this-command-keys))) arg)
  (move-overlay s-region-overlay (mark) (point) (current-buffer))
  (sit-for 1)
  (delete-overlay s-region-overlay))

(defun s-region-bind (keylist &optional map)
  "Bind shifted keys in KEYLIST to s-region-move-p1 or s-region-move-p2.
Each key in KEYLIST is shifted and bound to one of the s-region-move
functions provided it is already bound to some command or other.
Optional third argument MAP specifies keymap to add binding to, defaulting
to global keymap."
  (let ((p2 (list 'scroll-up 'scroll-down
		  'beginning-of-buffer 'end-of-buffer)))
    (or map (setq map global-map))
    (while keylist
      (let* ((key (car keylist))
	     (binding (key-binding key)))
	(if (commandp binding)
	    (define-key
	      map
	      (vector (intern (concat "S-" (symbol-name (aref key 0)))))
	      (cond ((memq binding p2)
		     's-region-move-p2)
		    (t 's-region-move-p1)))))
      (setq keylist (cdr keylist)))))

;; Single keys (plus modifiers) only!
(s-region-bind
 (list [right] [left] [up] [down]
       [C-left] [C-right] [C-up] [C-down]
       [M-left] [M-right] [M-up] [M-down]
       [next] [previous] [home] [end]
       [C-next] [C-previous] [C-home] [C-end]
       [M-next] [M-previous] [M-home] [M-end]))

(or (global-key-binding [C-insert])
    (global-set-key [C-insert] 'copy-region-as-kill))
(or (global-key-binding [S-delete])
    (global-set-key [S-delete] 'kill-region))
(or (global-key-binding [S-insert])
    (global-set-key [S-insert] 'yank))

(provide 's-region)

;;; arch-tag: a471e912-18d7-4247-a29b-2100bca180ff
;;; s-region.el ends here