Commit 1a2b6c52 authored by Richard M. Stallman's avatar Richard M. Stallman

Initial revision

parent 794572af
;;; mouse-sel.el --- Multi-click selection support for Emacs 19
;; Copyright (C) 1993 Free Software Foundation, Inc.
;; Author: Mike Williams <mikew@gopher.dosli.govt.nz>
;; Keywords: mouse
;; Version: $Revision: 1.20 $
;; 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.
;;; Commentary:
;;
;; This module provides multi-click mouse support for GNU Emacs versions
;; 19.18 and later. I've tried to make it behave more like standard X
;; clients (eg. xterm) than the default Emacs 19 mouse selection handlers.
;; Basically:
;;
;; * Clicking mouse-1 starts (cancels) selection, dragging extends it.
;;
;; * Clicking or dragging mouse-3 extends the selection as well.
;;
;; * Double-clicking on word constituents selects words.
;; Double-clicking on symbol constituents selects symbols.
;; Double-clicking on quotes or parentheses selects sexps.
;; Double-clicking on whitespace selects whitespace.
;; Triple-clicking selects lines.
;;
;; * Selecting sets the region & X primary selection, but does NOT affect
;; the kill-ring. Because the mouse handlers set the primary selection
;; directly, mouse-sel sets the variables interprogram-cut-function
;; and interprogram-paste-function to nil.
;;
;; * Clicking mouse-2 pastes contents of primary selection.
;;
;; * Pressing mouse-2 while selecting or extending copies selected text
;; to the kill ring. Pressing mouse-1 or mouse-3 kills it.
;;
;; This module requires my thingatpt.el module, version 1.14 or later, which
;; it uses to find the bounds of words, lines, sexps, etc.
;;
;; Thanks to KevinB@bartley.demon.co.uk for his useful input.
;;
;; You may also want to use one or more of following:
;;
;; ;; Enable region highlight
;; (transient-mark-mode 1)
;;
;; ;; But only in the selected window
;; (setq highlight-nonselected-windows nil)
;;
;; ;; Enable pending-delete
;; (delete-selection-mode 1)
;;
;;--- Customisation -------------------------------------------------------
;;
;; * You can control the way mouse-sel binds it's keys by setting the value
;; of mouse-sel-default-bindings before loading mouse-sel.
;;
;; (a) If mouse-sel-default-bindings = t (the default)
;;
;; Mouse sets and pastes selection
;; mouse-1 mouse-select
;; mouse-2 mouse-insert-selection
;; mouse-3 mouse-extend
;;
;; Selection/kill-ring interaction is disabled
;; interprogram-cut-function = nil
;; interprogram-paste-function = nil
;;
;; (b) If mouse-sel-default-bindings = 'interprogram-cut-paste
;;
;; Mouse sets selection, and pastes from kill-ring
;; mouse-1 mouse-select
;; mouse-2 mouse-yank-at-click
;; mouse-3 mouse-extend
;;
;; Selection/kill-ring interaction is retained
;; interprogram-cut-function = x-select-text
;; interprogram-paste-function = x-cut-buffer-or-selection-value
;;
;; What you lose is the ability to select some text in
;; delete-selection-mode and yank over the top of it.
;;
;; (c) If mouse-sel-default-bindings = nil, no bindings are made.
;;
;; * I like to leave point at the end of the region nearest to where the
;; mouse was, even though this makes region highlighting mis-leading (the
;; cursor makes it look like one extra character is selected). You can
;; disable this behaviour with:
;;
;; (setq mouse-sel-leave-point-near-mouse nil)
;;
;; * Normally, the selection highlight will be removed when the mouse is
;; lifted. You can tell mouse-sel to retain the selection highlight
;; (useful if you don't use transient-mark-mode) with:
;;
;; (setq mouse-sel-retain-highlight t)
;;
;; * By default, mouse-select cycles the click count after 3 clicks. That
;; is, clicking mouse-1 four times has the same effect as clicking it
;; once, clicking five times has the same effect as clicking twice, etc.
;; Disable this behaviour with:
;;
;; (setq mouse-sel-cycle-clicks nil)
;;
;; * The variables mouse-sel-{set,get,check}-selection-function control how
;; the selection is handled. Under X Windows, these variables default so
;; that the X primary selection is used. Under other windowing systems,
;; alternate functions are used, which simply store the selection value
;; in a variable.
;;
;;--- Hints ---------------------------------------------------------------
;;
;; * You can change the selection highlight face by altering the properties
;; of mouse-drag-overlay, eg.
;;
;; (overlay-put mouse-drag-overlay 'face 'bold)
;;
;; * Pasting from the primary selection under emacs 19.19 is SLOW (there's
;; a two second delay). The following code will cause mouse-sel to use
;; the cut buffer rather than the primary selection. However, be aware
;; that cut buffers are OBSOLETE, and some X applications may not support
;; them.
;;
;; (setq mouse-sel-set-selection-function 'x-select-text
;; mouse-sel-get-selection-function 'x-get-cut-buffer)
;;
;;--- Warnings ------------------------------------------------------------
;;
;; * When selecting sexps, the selection extends by sexps at the same
;; nesting level. This also means the selection cannot be extended out
;; of the enclosing nesting level. This is INTENTIONAL.
;;; Code:
(provide 'mouse-sel)
(require 'mouse)
(require 'thingatpt)
;;=== Version =============================================================
(defconst mouse-sel-version (substring "$Revision: 1.20 $" 11 -2)
"The revision number of mouse-sel (as string). The complete RCS id is:
$Id: mouse-sel.el,v 1.20 1993/09/30 23:57:32 mike Exp $")
;;=== User Variables ======================================================
(defvar mouse-sel-leave-point-near-mouse t
"*Leave point near last mouse position.
If non-nil, \\[mouse-select] and \\[mouse-extend] will leave point at the end
of the region nearest to where the mouse last was.
If nil, point will always be placed at the beginning of the region.")
(defvar mouse-sel-retain-highlight nil
"*Retain highlight on mouse-drag-overlay.
If non-nil, regions selected using \\[mouse-select] and \\[mouse-extend] will
remain highlighted.
If nil, highlighting will be turned off when the mouse is lifted.")
(defvar mouse-sel-cycle-clicks t
"*If non-nil, \\[mouse-select] cycles the click-counts after 3 clicks.
Ie. 4 clicks = 1 click, 5 clicks = 2 clicks, etc.")
(defvar mouse-sel-default-bindings t
"Set to nil before loading mouse-sel to prevent default mouse bindings.")
;;=== Selection ===========================================================
(defvar mouse-sel-selection-type nil "Type of current selection")
(make-variable-buffer-local 'mouse-sel-selection-type)
(defvar mouse-sel-selection ""
"This variable is used to store the selection value when mouse-sel is
used on windowing systems other than X Windows.")
(defvar mouse-sel-set-selection-function
(if (eq window-system 'x)
(function (lambda (s) (x-set-selection 'PRIMARY s)))
(function (lambda (s) (setq mouse-sel-selection s))))
"Function to call to set selection.
Called with one argument, the text to select.")
(defvar mouse-sel-get-selection-function
(if (eq window-system 'x)
'x-get-selection
(function (lambda () mouse-sel-selection)))
"Function to call to get the selection.
Called with no argument, it should return the selected text.")
(defvar mouse-sel-check-selection-function
(if (eq window-system 'x)
'x-selection-owner-p
nil)
"Function to check whether emacs still owns the selection.
Called with no arguments.")
(defun mouse-sel-determine-selection-type (NCLICKS)
"Determine what `thing' \\[mouse-select] and \\[mouse-extend] should
select by. The first argument is NCLICKS, is the number of consecutive
mouse clicks at the same position."
(let* ((next-char (char-after (point)))
(char-syntax (if next-char (char-syntax next-char)))
(nclicks (if mouse-sel-cycle-clicks (1+ (% (1- NCLICKS) 3)) NCLICKS)))
(cond
((= nclicks 1) nil)
((>= nclicks 3) 'line)
((memq char-syntax '(?\( ?\) ?\" ?')) 'sexp)
((memq next-char '(? ?\t ?\n)) 'whitespace)
((eq char-syntax ?_) 'symbol)
((eq char-syntax ?w) 'word))))
(defun mouse-select (EVENT)
"Set region/selection using the mouse.
On click, point & mark are set to click position, and mark is disabled.
Dragging extends region/selection.
Double-clicking on word constituents selects words.
Double-clicking on symbol constituents selects symbols.
Double-clicking on quotes or parentheses selects sexps.
Double-clicking on whitespace selects whitespace.
Triple-clicking selects lines.
Clicking mouse-2 while selecting copies the region to the kill-ring.
Clicking mouse-1 or mouse-3 kills the region.
This should be bound to a down-mouse event."
(interactive "e")
(mouse-set-point EVENT)
(setq mouse-sel-selection-type
(mouse-sel-determine-selection-type (event-click-count EVENT)))
(let ((object-bounds (bounds-of-thing-at-point mouse-sel-selection-type)))
(if object-bounds
(progn
(setq mark-active t)
(goto-char (car object-bounds))
(set-mark (cdr object-bounds)))
(deactivate-mark)))
(mouse-extend))
(defun mouse-extend (&optional EVENT)
"Extend region/selection using the mouse.
See documentation for mouse-select for more details.
This should be bound to a down-mouse event."
(interactive "e")
(if EVENT (select-window (posn-window (event-end EVENT))))
(let* ((min (if mark-active (region-beginning) (point)))
(max (if mark-active (region-end) (point)))
(orig-window (selected-window))
(orig-window-frame (window-frame orig-window))
(top (nth 1 (window-edges orig-window)))
(bottom (nth 3 (window-edges orig-window)))
(orig-cursor-type
(cdr (assoc 'cursor-type (frame-parameters (selected-frame)))))
direction
event)
;; Inhibit normal region highlight
(setq mark-active nil)
;; Highlight region (forcing re-highlight)
(move-overlay mouse-drag-overlay min max (current-buffer))
(overlay-put mouse-drag-overlay 'face
(overlay-get mouse-drag-overlay 'face))
;; Bar cursor
(modify-frame-parameters (selected-frame) '((cursor-type . bar)))
;; Handle dragging
(unwind-protect
(progn
(track-mouse
(while (if EVENT ; Use initial event
(prog1
(setq event EVENT)
(setq EVENT nil))
(setq event (read-event))
(and (consp event)
(memq (car event) '(mouse-movement switch-frame))))
(let ((end (event-end event)))
(cond
;; Ignore any movement outside the frame
((eq (car-safe event) 'switch-frame) nil)
((and (posn-window end)
(not (eq (window-frame (posn-window end))
(window-frame orig-window)))) nil)
;; Different window, same frame
((not (eq (posn-window end) orig-window))
(let ((end-row (cdr (cdr (mouse-position)))))
(cond
((and end-row (not (bobp)) (< end-row top))
(mouse-scroll-subr (- end-row top)
mouse-drag-overlay max))
((and end-row (not (eobp)) (>= end-row bottom))
(mouse-scroll-subr (1+ (- end-row bottom))
mouse-drag-overlay min))
)))
;; On the mode line
((eq (posn-point end) 'mode-line)
(mouse-scroll-subr 1 mouse-drag-overlay min))
;; In original window
(t (goto-char (posn-point end)))
)
;; Determine direction of drag
(cond
((and (not direction) (not (eq min max)))
(setq direction (if (< (point) (/ (+ min max) 2)) -1 1)))
((and (not (eq direction -1)) (<= (point) min))
(setq direction -1))
((and (not (eq direction 1)) (>= (point) max))
(setq direction 1)))
(if (not mouse-sel-selection-type) nil
;; If dragging forward, goal is next character
(if (and (eq direction 1) (not (eobp))) (forward-char 1))
;; Move to start/end of selected thing
(let ((goal (point))
last)
(goto-char (if (eq 1 direction) min max))
(condition-case nil
(progn
(while (> (* direction (- goal (point))) 0)
(setq last (point))
(forward-thing mouse-sel-selection-type
direction))
(let ((end (point)))
(forward-thing mouse-sel-selection-type
(- direction))
(goto-char
(if (> (* direction (- goal (point))) 0)
end last))))
(error))))
;; Move overlay
(move-overlay mouse-drag-overlay
(if (eq 1 direction) min (point))
(if (eq -1 direction) max (point))
(current-buffer))
))) ; end track-mouse
(let ((overlay-start (overlay-start mouse-drag-overlay))
(overlay-end (overlay-end mouse-drag-overlay)))
;; Set region
(if (eq overlay-start overlay-end)
(deactivate-mark)
(if (and mouse-sel-leave-point-near-mouse (eq direction 1))
(progn
(set-mark overlay-start)
(goto-char overlay-end))
(set-mark overlay-end)
(goto-char overlay-start)))
;; Set selection
(if (and mark-active mouse-sel-set-selection-function)
(funcall mouse-sel-set-selection-function
(buffer-substring overlay-start overlay-end)))
;; Handle copy/kill
(cond
((eq (car-safe last-input-event) 'down-mouse-2)
(copy-region-as-kill overlay-start overlay-end)
(read-event) (read-event))
((memq (car-safe last-input-event) '(down-mouse-1 down-mouse-3))
(kill-region overlay-start overlay-end)
(deactivate-mark)
(read-event) (read-event)))))
;; Restore cursor
(modify-frame-parameters (selected-frame)
(list (cons 'cursor-type orig-cursor-type)))
;; Remove overlay
(or mouse-sel-retain-highlight
(delete-overlay mouse-drag-overlay)))))
(defun mouse-insert-selection (click)
"Insert the contents of the selection at mouse click."
(interactive "e")
(mouse-set-point click)
(deactivate-mark)
(if mouse-sel-get-selection-function
(insert (or (funcall mouse-sel-get-selection-function) ""))))
(defun mouse-sel-validate-selection ()
"Remove selection highlight if emacs no longer owns the primary selection."
(or (not mouse-sel-check-selection-function)
(funcall mouse-sel-check-selection-function)
(delete-overlay mouse-drag-overlay)))
(add-hook 'pre-command-hook 'mouse-sel-validate-selection)
;;=== Key bindings ========================================================
(if (not mouse-sel-default-bindings) nil
(global-unset-key [mouse-1])
(global-unset-key [drag-mouse-1])
(global-unset-key [mouse-3])
(global-set-key [down-mouse-1] 'mouse-select)
(global-set-key [down-mouse-3] 'mouse-extend)
(if (eq mouse-sel-default-bindings 'interprogram-cut-paste) nil
(global-set-key [mouse-2] 'mouse-insert-selection)
(setq interprogram-cut-function nil
interprogram-paste-function nil))
)
;; mouse-sel.el ends here.
This diff is collapsed.
;;; thingatpt.el --- Get the `thing' at point
;; Copyright (C) 1991,1992,1993 Free Software Foundation, Inc.
;; Author: Mike Williams <mikew@gopher.dosli.govt.nz>
;; Keywords: extensions
;; Created: Thu Mar 28 13:48:23 1991
;; Version: $Revision: 1.16 $
;; 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.
;;; Commentary:
;;
;; This file provides routines for getting the `thing' at the location of
;; point, whatever that `thing' happens to be. The `thing' is defined by
;; it's beginning and end positions in the buffer.
;;
;; The function bounds-of-thing-at-point finds the beginning and end
;; positions by moving first forward to the end of the `thing', and then
;; backwards to the beginning. By default, it uses the corresponding
;; forward-`thing' operator (eg. forward-word, forward-line).
;;
;; Special cases are allowed for using properties associated with the named
;; `thing':
;;
;; forward-op Function to call to skip forward over a `thing' (or
;; with a negative argument, backward).
;;
;; beginning-op Function to call to skip to the beginning of a `thing'.
;; end-op Function to call to skip to the end of a `thing'.
;;
;; Reliance on existing operators means that many `things' can be accessed
;; without further code: eg.
;; (thing-at-point 'line)
;; (thing-at-point 'page)
;;; Code:
(provide 'thingatpt)
;;=== Version =============================================================
(defconst thing@pt-version (substring "$Revision: 1.16 $" 11 -2)
"The revision number of thing@pt (as string). The complete RCS id is:
$Id: thing@pt.el,v 1.16 1993/09/30 23:54:56 mike Exp $")
;;=== Basic movement ======================================================
;;;###autoload
(defun forward-thing (THING &optional N)
"Move forward to the end of the next THING."
(let ((forward-op (or (get THING 'forward-op)
(intern-soft (format "forward-%s" THING)))))
(if (fboundp forward-op)
(funcall forward-op (or N 1))
(error "Can't determine how to move over %ss" THING))))
;;=== General routines ====================================================
;;;###autoload
(defun bounds-of-thing-at-point (THING)
"Determine the start and end buffer locations for the THING at point,
where THING is an entity for which there is a either a corresponding
forward-THING operation, or corresponding beginning-of-THING and
end-of-THING operations, eg. 'word, 'sentence, 'defun.
Return a cons cell '(start . end) giving the start and end positions."
(let ((orig (point)))
(condition-case nil
(save-excursion
(let ((end (progn
(funcall
(or (get THING 'end-op)
(function (lambda () (forward-thing THING 1)))))
(point)))
(beg (progn
(funcall
(or (get THING 'beginning-op)
(function (lambda () (forward-thing THING -1)))))
(point))))
(if (and beg end (<= beg orig) (< orig end))
(cons beg end))))
(error nil))))
;;;###autoload
(defun thing-at-point (THING)
"Return the THING at point, where THING is an entity defined by
bounds-of-thing-at-point."
(let ((bounds (bounds-of-thing-at-point THING)))
(if bounds
(buffer-substring (car bounds) (cdr bounds)))))
;;=== Go to beginning/end =================================================
(defun beginning-of-thing (THING)
(let ((bounds (bounds-of-thing-at-point THING)))
(or bounds (error "No %s here" THING))
(goto-char (car bounds))))
(defun end-of-thing (THING)
(let ((bounds (bounds-of-thing-at-point THING)))
(or bounds (error "No %s here" THING))
(goto-char (cdr bounds))))
;;=== Special cases =======================================================
;;--- Sexps ---
(defun in-string-p ()
(let ((orig (point)))
(save-excursion
(beginning-of-defun)
(nth 3 (parse-partial-sexp (point) orig)))))
(defun end-of-sexp ()
(let ((char-syntax (char-syntax (char-after (point)))))
(if (or (eq char-syntax ?\))
(and (eq char-syntax ?\") (in-string-p)))
(forward-char 1)
(forward-sexp 1))))
(put 'sexp 'end-op 'end-of-sexp)
;;--- Lists ---
(put 'list 'end-op (function (lambda () (up-list 1))))
(put 'list 'beginning-op 'backward-sexp)
;;--- Filenames ---
(defvar file-name-chars "~/A-Za-z0-9---_.${}#%,"
"Characters allowable in filenames.")
(put 'filename 'end-op
(function (lambda () (skip-chars-forward file-name-chars))))
(put 'filename 'beginning-op
(function (lambda () (skip-chars-backward file-name-chars (point-min)))))
;;--- Whitespace ---
(defun forward-whitespace (ARG)
(interactive "p")
(if (natnump ARG)
(re-search-forward "[ \t]+\\|\n" nil nil ARG)
(while (< ARG 0)
(if (re-search-backward "[ \t]+\\|\n" nil nil)
(or (eq (char-after (match-beginning 0)) 10)
(skip-chars-backward " \t")))
(setq ARG (1+ ARG)))))
;;--- Buffer ---
(put 'buffer 'end-op 'end-of-buffer)
(put 'buffer 'beginning-op 'beginning-of-buffer)
;;--- Symbols ---
(defun forward-symbol (ARG)
(interactive "p")
(if (natnump ARG)
(re-search-forward "\\(\\sw\\|\\s_\\)+" nil nil ARG)
(while (< ARG 0)
(if (re-search-backward "\\(\\sw\\|\\s_\\)+" nil nil)
(skip-syntax-backward "w_"))
(setq ARG (1+ ARG)))))
;;=== Aliases =============================================================
(defun word-at-point () (thing-at-point 'word))
(defun sentence-at-point () (thing-at-point 'sentence))
(defun read-from-whole-string (STR)
"Read a lisp expression from STR, signalling an error if the entire string
was not used."
(let* ((read-data (read-from-string STR))
(more-left
(condition-case nil
(progn (read-from-string (substring STR (cdr read-data)))
t)
(end-of-file nil))))
(if more-left
(error "Can't read whole string")
(car read-data))))
(defun form-at-point (&optional THING PRED)
(let ((sexp (condition-case nil
(read-from-whole-string (thing-at-point (or THING 'sexp)))
(error nil))))
(if (or (not PRED) (funcall PRED sexp)) sexp)))
(defun sexp-at-point () (form-at-point 'sexp))
(defun symbol-at-point () (form-at-point 'sexp 'symbolp))
(defun number-at-point () (form-at-point 'sexp 'numberp))
(defun list-at-point () (form-at-point 'list 'listp))
;; thingatpt.el ends here.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment