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

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

;; Author: Morten Welinder (terra@diku.dk)
;; XEmacs rewrite: Tomasz Cholewo (tjchol01@mecca.spd.louisville.edu)
;; Version: 0.95
;; Last modified: Sun Nov  2 17:20:26 EST 1997

;; Keywords: terminals

;;; Synched up with: not synched with FSF
;;; Requires: XEmacs 20.3

;;; Commentary:

;; This code allows to set the region by holding down the shift key and
;; moving the cursor to the other end of the region.  The functionality
;; is similar to that provided by many DOS and Windows editors except
;; that the standard movement commands deactivate region only if the
;; previous command was one of shift marking commands.  This ensures
;; that the standard Emacs method of selecting regions are also still
;; available.

;; Currently, only movement commands that are interactive "p" or "P"
;; functions and are bound to single keystrokes may be adapted.

;; Function `s-region-bind-cua' adds several additional PC-like bindings.

;; To use s-region, put the following to `~/.emacs':
;;
;;   (require 's-region)
;;   (s-region-bind)
;;   (s-region-bind-cua)


;;; User variables:

(defvar s-region-key-list
 (list [right] [left] [up] [down]
       [(control left)] [(control right)] [(control up)] [(control down)]
       [(meta left)] [(meta right)] [(meta up)] [(meta down)]
       [next] [prior] [home] [end]
       [(control next)] [(control prior)] [(control home)] [(control end)])
"*A list of movement keystrokes to be used for region marking with a
shift key.  Only single keystrokes (with modifiers) bound to interactive
\"p\" or \"P\" functions are allowed.")

;; [(meta next)] [(meta prior)] [(meta home)] [(meta end)] are by
;; default bound to -other-window commands and hence should not be
;; modified.

;;; Code:

(defvar s-region-last-mark-p nil
  "T if shift marking was used and since then no unshifted movement
commands nor set-mark were used.")

(defun s-region-add-shift (keyseq)
  "Return the last keystroke in sequence KEYSEQ with added shift modifier.
For example:
    (s-region-add-shift [(control u) down]) => [(shift down)]"
  (let* ((v (key-sequence-list-description keyseq))
	(key (aref v (1- (length v)))))
    (vector (append
	     (list 'shift)
	     (delq 'shift key)))))

(defun s-region-nomark ()
  "Deactivate region if shift marking has been used immediately before."
  (if s-region-last-mark-p
      (zmacs-deactivate-region))
  (setq s-region-last-mark-p nil))

(defun s-region-mark ()
  "Start or continue marking a region."
  (if (if (region-active-p)
	  (not s-region-last-mark-p)
	t)
      (push-mark nil t t)
    (zmacs-activate-region))
  (setq s-region-last-mark-p t))

;; #### This should check for everything which is not a rebound
;; movement command.
(defun s-region-restore ()
  "Restore standard behavior of mark region commands when the
just-executed command is not shift-marking."
  (if (eq this-command 'set-mark-command)
      (setq s-region-last-mark-p nil)))

;;;###autoload
(defun s-region-bind (&optional keylist map)
  "Bind shifted keys from KEYLIST to region marking commands.
Each key in KEYLIST is rebound to deactivate region if the last command
was one of shift marking commands.  Keys with added shift modifier are
bound to start or continue marking a region.  Optional argument KEYLIST
defaults to `s-region-key-list'.  Optional argument MAP specifies keymap
to add binding to, defaulting to global keymap."
  (interactive)
  (let ((p2 (list 'scroll-up 'scroll-down
		  'beginning-of-buffer 'end-of-buffer)))
    (or keylist (setq keylist s-region-key-list))
    (or map (setq map global-map))
    (mapc #'(lambda (key)
	      (let ((binding (key-binding key)))
		(cond ((and (symbolp binding) (commandp binding))
		    (define-key map key
		      `(lambda (arg)
			 ,(concat
			   "Deactivate region if shift marking was used "
			   "and call `" (symbol-name binding) "'.")
			 (interactive
			  ,(if (memq binding p2)
			       "_P"
			     "_p"))
			 (s-region-nomark)
			 (,binding arg)
			 ;; next-line uses last-command to track eol
			 (setq this-command ',binding)))
		    (define-key map (s-region-add-shift key)
		      `(lambda (arg)
			 ,(concat
			   "Start or continue shift marking and call `"
			   (symbol-name binding) "'.")
			 (interactive
			  ,(if (memq binding p2)
			       "P"
			     "p"))
			 (s-region-mark)
			 (,binding arg)
			 (setq this-command ',binding)))
		    ))))
	  keylist))
  (add-hook 'post-command-hook 's-region-restore))

;;;###autoload
(defun s-region-bind-cua (&optional map)
  "Bind some of CUA keys in keymap MAP to kill and yank commands.
Optional argument MAP defaults to `global-map'.
New bindings:
  Sh-delete    kill-region
  Sh-insert    yank
  C-insert     copy-region-as-kill
  C-delete     kill-line
  C-backspace  backward-kill-word"
  (interactive)
  (or map (setq map global-map))
  (define-key map [(shift delete)] 'kill-region)
  (define-key map [(shift insert)] 'yank)
  (define-key map [(control insert)] 'copy-region-as-kill)
  (define-key map [(control delete)] 'kill-line)
  (define-key map [(control backspace)] 'backward-kill-word))

(provide 's-region)

;; s-region.el ends here.
