home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / prim / mouse.el < prev    next >
Encoding:
Text File  |  1993-03-24  |  17.5 KB  |  553 lines
  1. ;; Mouse support that is independent of window systems.
  2. ;; Copyright (C) 1988-1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'mouse)
  21.  
  22. (require 'mode-motion)
  23.  
  24. (global-set-key 'button1 'mouse-track)
  25. (global-set-key '(shift button1) 'mouse-track-adjust)
  26. (global-set-key '(control button1) 'mouse-track-insert)
  27. (global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
  28.  
  29.  
  30. (defun mouse-select ()
  31.   "Select Emacs window the mouse is on."
  32.   (interactive "@"))
  33.  
  34. (defun mouse-delete-window ()
  35.   "Delete the Emacs window the mouse is on."
  36.   (interactive "@")
  37.   (delete-window))
  38.  
  39. (defun mouse-keep-one-window ()
  40.   "Select Emacs window mouse is on, then kill all other Emacs windows."
  41.   (interactive "@")
  42.   (delete-other-windows))
  43.  
  44. (defun mouse-select-and-split ()
  45.   "Select Emacs window mouse is on, then split it vertically in half."
  46.   (interactive "@")
  47.   (split-window-vertically nil))
  48.  
  49. (defun mouse-set-point (event)
  50.   "Select Emacs window mouse is on, and move point to mouse position."
  51.   (interactive "@e")
  52.   (let ((window (event-window event))
  53.     (pos (event-point event)))
  54.     (or window (error "not in a window"))
  55.     (select-window window)
  56.     (if (and pos (> pos 0))
  57.     (goto-char pos)
  58.       (if (> (move-to-window-line
  59.           (- (event-y event) (nth 1 (window-edges window))))
  60.          0)
  61.       ;; if target line was past end of buffer, go to eol of last line.
  62.       (end-of-line)
  63.     (move-to-column (- (event-x event) (nth 0 (window-edges window))))
  64.     ))))
  65.  
  66. (defun mouse-eval-last-sexpr (event)
  67.   (interactive "@e")
  68.   (save-excursion
  69.     (mouse-set-point event)
  70.     (eval-last-sexp nil)))
  71.  
  72. (defun mouse-line-length (event)
  73.   "Print the length of the line indicated by the pointer."
  74.   (interactive "@e")
  75.   (save-excursion
  76.     (mouse-set-point event)
  77.     (message "Line length: %d"
  78.          (- (progn (end-of-line) (point))
  79.         (progn (beginning-of-line) (point)))))
  80.   (sleep-for 1))
  81.  
  82. (defun mouse-set-mark (event)
  83.   "Select Emacs window mouse is on, and set mark at mouse position.
  84. Display cursor at that position for a second."
  85.   (interactive "@e")
  86.   (let ((point-save (point)))
  87.     (unwind-protect
  88.     (progn (mouse-set-point event)
  89.            (push-mark nil t)
  90.            (sit-for 1))
  91.       (goto-char point-save))))
  92.  
  93. (defun mouse-scroll (event)
  94.   "Scroll point to the mouse position."
  95.   (interactive "@e")
  96.   (save-excursion
  97.     (mouse-set-point event)
  98.     (recenter 0)
  99.     (scroll-right (event-x event))))
  100.  
  101. (defun mouse-del-char (event)
  102.   "Delete the char pointed to by the mouse."
  103.   (interactive "@e")
  104.   (save-excursion
  105.     (mouse-set-point event)
  106.     (delete-char 1 nil)))
  107.  
  108. (defun mouse-kill-line (event)
  109.   "Kill the line pointed to by the mouse."
  110.   (interactive "@e")
  111.   (save-excursion
  112.     (mouse-set-point event)
  113.     (kill-line nil)))
  114.  
  115.  
  116. (defun narrow-window-to-region (m n)
  117.   "Narrow window to region between point and last mark"
  118.   (interactive "r")
  119.   (save-excursion
  120.     (save-restriction
  121.       (if (eq (selected-window) (next-window))
  122.       (split-window))
  123.       (goto-char m)
  124.       (recenter 0)
  125.       (if (eq (selected-window)
  126.           (if (zerop (minibuffer-depth))
  127.           (next-window)))
  128.       ()
  129.     (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
  130.  
  131. (defun mouse-window-to-region (event)
  132.   "Narrow window to region between cursor and mouse pointer."
  133.   (interactive "@e")
  134.   (let ((point-save (point)))
  135.     (unwind-protect
  136.     (progn (mouse-set-point event)
  137.            (push-mark nil t)
  138.            (sit-for 1))
  139.       (goto-char point-save)
  140.       (narrow-window-to-region (region-beginning) (region-end)))))
  141.  
  142. (defun mouse-ignore ()
  143.   "Don't do anything."
  144.   (interactive))
  145.  
  146.  
  147. ;;
  148. ;; Commands for the scroll bar.
  149. ;;
  150.  
  151. ;; Vertical bar
  152.  
  153. (defun mouse-scroll-down (nlines)
  154.   (interactive "@p")
  155.   (scroll-down nlines))
  156.  
  157. (defun mouse-scroll-up (nlines)
  158.   (interactive "@p")
  159.   (scroll-up nlines))
  160.  
  161. (defun mouse-scroll-down-full ()
  162.   (interactive "@")
  163.   (scroll-down nil))
  164.  
  165. (defun mouse-scroll-up-full ()
  166.   (interactive "@")
  167.   (scroll-up nil))
  168.  
  169. (defun mouse-scroll-move-cursor (nlines)
  170.   (interactive "@p")
  171.   (move-to-window-line nlines))
  172.  
  173. (defun mouse-scroll-absolute (event)
  174.   (interactive "@e")
  175.   (let* ((position (event-x event))
  176.      (length (event-y event))
  177.      (size (buffer-size))
  178.      (scale-factor (max 1 (/ 8000000 size)))
  179.      (newpos (* (/ (* (/ size scale-factor) position) length)
  180.             scale-factor)))
  181.     (goto-char newpos)
  182.     (recenter '(4))))
  183.  
  184. ;; These scroll while the invoking button is depressed.
  185.  
  186. (defvar scrolled-lines 0)
  187. (defvar scroll-speed 1)
  188.  
  189. (defun incr-scroll-down (event)
  190.   (interactive "@e")
  191.   (setq scrolled-lines 0)
  192.   (incremental-scroll scroll-speed))
  193.  
  194. (defun incr-scroll-up (event)
  195.   (interactive "@e")
  196.   (setq scrolled-lines 0)
  197.   (incremental-scroll (- scroll-speed)))
  198.  
  199. (defun incremental-scroll (n)
  200.   (let ((event (allocate-event))
  201.     (down t))
  202.     (while down
  203.       (sit-for mouse-track-scroll-delay)
  204.       (cond ((input-pending-p)
  205.          (next-event event)
  206.          (if (or (button-press-event-p event)
  207.              (button-release-event-p event))
  208.          (setq down nil))
  209.          (dispatch-event event)))
  210.       (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
  211.       (scroll-down n))))
  212.  
  213. (defun incr-scroll-stop (event)
  214.   (interactive "@e")
  215.   (setq scrolled-lines 0)
  216.   (sleep-for 1))
  217.  
  218.  
  219. (defun mouse-scroll-left (ncolumns)
  220.   (interactive "@p")
  221.   (scroll-left ncolumns))
  222.  
  223. (defun mouse-scroll-right (ncolumns)
  224.   (interactive "@p")
  225.   (scroll-right ncolumns))
  226.  
  227. (defun mouse-scroll-left-full ()
  228.   (interactive "@")
  229.   (scroll-left nil))
  230.  
  231. (defun mouse-scroll-right-full ()
  232.   (interactive "@")
  233.   (scroll-right nil))
  234.  
  235. (defun mouse-scroll-move-cursor-horizontally (ncolumns)
  236.   (interactive "@p")
  237.   (move-to-column ncolumns))
  238.  
  239. (defun mouse-scroll-absolute-horizontally (event)
  240.   (interactive "@e")
  241.   (let* ((position (event-x event))
  242.      (length (event-y event)))
  243.   (set-window-hscroll (selected-window) 33)))
  244.  
  245.  
  246.  
  247. ;;; mouse/selection tracking
  248.  
  249. (defvar mouse-track-up-time 0)
  250. (defvar mouse-track-up-x 0)
  251. (defvar mouse-track-up-y 0)
  252. (defvar mouse-track-type nil)
  253. (defvar mouse-track-multiclick-time 400)
  254. (defvar mouse-track-timeout-id nil)
  255. (defvar mouse-track-scroll-delay
  256.   (if (featurep 'lisp-float-type) 
  257.       ;; so that the .elc file can load in an emacs without LISP_FLOAT_TYPE
  258.       (car (read-from-string "0.3"))
  259.     1))
  260.  
  261. (defun mouse-track-set-point-in-window (event window)
  262.   (if (eq (event-window event) window)
  263.       (let ((point (event-point event)))
  264.     (if point
  265.         (goto-char point)
  266.       (move-to-window-line (- (event-y event)
  267.                   (nth 1 (window-edges window))))
  268.       (if (> (event-x-pixel event)
  269.          (or (cdr (assoc 'internal-border-width x-screen-defaults)) 5))
  270.           (end-of-line)))
  271.     t)))
  272.  
  273. (defun mouse-track-scroll-and-set-point (event window)
  274.   (let ((edges (window-edges window))
  275.     (row (/ (event-y-pixel event)
  276.         (/ (x-pixel-height (selected-screen)) (screen-height)))))
  277.     (cond ((<= row (nth 1 edges))
  278.        (let ((delta (- (nth 1 edges) row)))
  279.          (condition-case () (scroll-down delta) (error))
  280.          (goto-char (window-start))))
  281.       ((>= (point) (point-max)))
  282.       ((>= row (1- (nth 3 edges)))
  283.        (let ((delta  (- (+ row 2) (nth 3 edges))))
  284.          (condition-case () (scroll-up delta) (error))
  285.          (goto-char (window-end))
  286.          (vertical-motion delta)
  287.          (backward-char 1))))))
  288.  
  289. (defun mouse-track-set-point-and-timeout (event window)
  290.   (if (mouse-track-set-point-in-window event window)
  291.       nil
  292.     (or mouse-track-timeout-id ; no more than one timeout at a time
  293.     (setq mouse-track-timeout-id
  294.           (add-timeout mouse-track-scroll-delay
  295.                'mouse-track-scroll-undefined
  296.                (copy-event event))))
  297.     (mouse-track-scroll-and-set-point event window)))
  298.  
  299. (defun mouse-track-cleanup-timeout ()
  300.   (if mouse-track-timeout-id
  301.       (progn
  302.     (disable-timeout mouse-track-timeout-id)
  303.     (setq mouse-track-timeout-id nil))))
  304.  
  305. (defsubst mouse-track-beginning-of-word (symbolp)
  306.   (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
  307.                 ((null symbolp) "\\w")
  308.                 (t "[^ \t\n]")))
  309.     (white-space "[ \t]"))
  310.     (cond ((bobp) nil)
  311.       ((looking-at word-constituent)
  312.        (backward-char)
  313.        (while (and (not (bobp)) (looking-at word-constituent))
  314.          (backward-char))
  315.        (if (or (not (bobp)) (not (looking-at word-constituent)))
  316.            (forward-char)))
  317.       ((looking-at white-space)
  318.        (backward-char)
  319.        (while (looking-at white-space)
  320.          (backward-char))
  321.        (forward-char)))))
  322.  
  323. (defun mouse-track-end-of-word (symbolp)
  324.   (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
  325.                 ((null symbolp) "\\w")
  326.                 (t "[^ \t\n]")))
  327.     (white-space "[ \t]"))
  328.     (cond ((looking-at word-constituent) ; word or symbol constituent
  329.        (while (looking-at word-constituent)
  330.          (forward-char)))
  331.       ((looking-at white-space) ; word or symbol constituent
  332.        (while (looking-at white-space)
  333.          (forward-char))))))
  334.  
  335. (defun mouse-track-normalize-point (type forwardp)
  336.   (cond ((eq type 'word)
  337.      ;; trap the beginning and end of buffer errors
  338.      (condition-case ()
  339.          (if forwardp
  340.          (mouse-track-end-of-word t)
  341.            (mouse-track-beginning-of-word t))
  342.        (error ())))
  343.     ((eq type 'line)
  344.      (if forwardp (end-of-line) (beginning-of-line)))))
  345.  
  346. (defun mouse-track-next-move (min-anchor max-anchor extent)
  347.   (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor)))
  348.     (mouse-track-normalize-point mouse-track-type (> (point) anchor))
  349.     (if (<= anchor (point))
  350.     (set-extent-endpoints extent anchor (point))
  351.       (set-extent-endpoints extent (point) anchor))))
  352.  
  353. (defun mouse-track-has-selection-p (buffer)
  354.   (and (or (not (eq window-system 'x))
  355.        (x-selection-owner-p))
  356.        (extentp primary-selection-extent)
  357.        (eq buffer (extent-buffer primary-selection-extent))))
  358.  
  359. (defun mouse-track-anchor (adjust previous-point)
  360.   (if adjust
  361.       (if (mouse-track-has-selection-p (current-buffer))
  362.       (let ((start (extent-start-position primary-selection-extent))
  363.         (end (extent-end-position primary-selection-extent)))
  364.         (cond ((< (point) start) end)
  365.           ((> (point) end) start)
  366.           ((> (- (point) start) (- end (point))) start)
  367.           (t end)))
  368.     previous-point)
  369.     (point)))
  370.  
  371. (defun mouse-track-next-type (type)
  372.   (cond ((null type) 'char)
  373.     ((eq type 'char) 'word)
  374.     ((eq type 'word) 'line)
  375.     ((eq type 'line) 'char)))
  376.  
  377. (defun mouse-track-select (event adjust face)
  378.   (or (button-press-event-p event)
  379.       (error "%s must be invoked by a mouse-press" this-command))
  380.   (let* ((window (event-window event))
  381.      (extent (make-extent 1 1 (window-buffer window)))
  382.      (mouse-down t)
  383.      min-anchor max-anchor result previous-point)
  384.     (set-extent-face extent face)
  385.     ;; While the selection is being dragged out, give the selection extent
  386.     ;; slightly higher priority than any mouse-highlighted extent, so that
  387.     ;; the exact endpoints of the selection will be visible while the mouse
  388.     ;; is down.  Normally, the selection and mouse highlighting have the same
  389.     ;; priority, so that conflicts between the two of them are resolved by
  390.     ;; the usual size-and-endpoint-comparison method.
  391.     (set-extent-priority extent (1+ mouse-highlight-priority))
  392.     ;;
  393.     ;; process double and triple clicks
  394.     (cond ((and (< (- (event-timestamp event) mouse-track-up-time)
  395.            mouse-track-multiclick-time)
  396.         (= (event-x event) mouse-track-up-x)
  397.         (= (event-y event) mouse-track-up-y))
  398.        (setq mouse-track-type (mouse-track-next-type mouse-track-type)))
  399.       ((not adjust)
  400.        (setq mouse-track-type 'char)))
  401.     (select-window window)
  402.     (setq previous-point (point))
  403.  
  404.     (mouse-track-set-point-and-timeout event window)
  405.     ;;
  406.     ;; adjust point to a word or line boundary if appropriate
  407.     (let ((anchor (mouse-track-anchor adjust previous-point)))
  408.       (setq min-anchor
  409.         (save-excursion (goto-char anchor)
  410.                 (mouse-track-normalize-point mouse-track-type nil)
  411.                 (point)))
  412.       (setq max-anchor
  413.         (save-excursion (goto-char anchor)
  414.                 (mouse-track-normalize-point mouse-track-type t)
  415.                 (point))))
  416.     ;;
  417.     ;; remove the existing selection to unclutter the display
  418.     (cond (zmacs-regions
  419.        (zmacs-deactivate-region))
  420.       ((eq window-system 'x)
  421.        (x-disown-selection)))
  422.  
  423.     (unwind-protect
  424.     (progn
  425.       (while mouse-down
  426.         (mouse-track-next-move min-anchor max-anchor extent)
  427.         (next-event event)
  428.         (mouse-track-cleanup-timeout)
  429.         (cond ((motion-event-p event)
  430.            (mouse-track-set-point-and-timeout event window))
  431.           ((and (timeout-event-p event)
  432.             (eq (event-function event)
  433.                 'mouse-track-scroll-undefined))
  434.            (mouse-track-set-point-and-timeout (event-object event)
  435.                               window))
  436.           ((button-release-event-p event)
  437.            (setq mouse-track-up-time (event-timestamp event))
  438.            (setq mouse-track-up-x (event-x event))
  439.            (setq mouse-track-up-y (event-y event))
  440.            (mouse-track-set-point-in-window event window)
  441.            (mouse-track-next-move min-anchor max-anchor extent)
  442.            (setq mouse-down nil))
  443.           ((key-press-event-p event)
  444.            (error "Selection aborted"))
  445.           (t
  446.            (dispatch-event event))))
  447.       (setq result (cons (extent-start-position extent)
  448.                  (extent-end-position extent)))
  449.       ;; Minor kludge: if we're selecting in line-mode, include the
  450.       ;; final newline.  It's hard to do this in *-normalize-point.
  451.       (if (eq mouse-track-type 'line)
  452.           (let ((end-p (= (point) (cdr result))))
  453.         (goto-char (cdr result))
  454.         (if (not (eobp))
  455.             (setcdr result (1+ (cdr result))))
  456.         (goto-char (if end-p (cdr result) (car result)))))
  457.       )
  458.       ;; protected
  459.       (delete-extent extent)
  460.       (mouse-track-cleanup-timeout))
  461.     result))
  462.  
  463. (defun mouse-track-maybe-own-selection (pair type)
  464.   (let ((start (car pair))
  465.     (end (cdr pair)))
  466.     (or (= start end) (push-mark (if (= (point) start) end start)))
  467.     (cond (zmacs-regions
  468.        (if (= start end)
  469.            nil
  470.          (zmacs-activate-region)
  471.          (setq zmacs-region-stays t)))
  472.       ((eq window-system 'x)
  473.        (if (= start end)
  474.            (x-disown-selection type)
  475.          (x-own-selection (cons (set-marker (make-marker) start)
  476.                     (set-marker (make-marker) end))
  477.                   type))))
  478.     (if (and (eq window-system 'x)
  479.          (not (= start end)))
  480.     (x-store-cutbuffer (buffer-substring start end)))))
  481.  
  482.  
  483. ;;; interactive commands
  484.  
  485. (defun mouse-track (event)
  486.   "Make a selection with the mouse.  This should be bound to a mouse button.
  487. If you click-and-drag, the selection will be set to the region between the
  488. point of the initial click and the point at which you release the button.
  489. These positions need not be ordered.
  490.  
  491. If you click-and-release without moving the mouse, then the point is moved,
  492. and the selection is disowned (there will be no selection owner.)  The mark
  493. will be set to the previous position of point.
  494.  
  495. If you double-click, the selection will extend by symbols instead of by
  496. characters.  If you triple-click, the selection will extend by lines.
  497.  
  498. If you drag the mouse off the top or bottom of the window, you can select
  499. pieces of text which are larger than the visible part of the buffer; the 
  500. buffer will scroll as necessary.
  501.  
  502. The selected text becomes the current X Selection, and is also copied to the
  503. top of the kill ring.  The point will be left at the position at which you
  504. released the button, and the mark will be left at the initial click position.
  505.  
  506. See also the `mouse-track-adjust' command, on \\[mouse-track-adjust]."
  507.   (interactive "e")
  508.   (select-screen (window-screen (event-window event)))
  509.   (let ((p (point))
  510.     (b (current-buffer))
  511.     (pair (mouse-track-select event nil 'primary-selection)))
  512.     ;; if no region was selected, but point has changed, but current
  513.     ;; buffer has not, push a mark at the previous point.
  514.     (if (and (equal (car pair) (cdr pair))
  515.          (eq b (current-buffer))
  516.          (not (equal p (car pair))))
  517.     (push-mark p))
  518.     (mouse-track-maybe-own-selection pair 'PRIMARY)))
  519.  
  520. (defun mouse-track-adjust (event)
  521.   "Extend the existing selection.  This should be bound to a mouse button.
  522. The selection will be enlarged or shrunk so that the point of the mouse
  523. click is one of its endpoints.  This is only really meaningful after the
  524. `mouse-track' command (\\[mouse-track]) has been executed."
  525.   (interactive "e")
  526.   (select-screen (window-screen (event-window event)))
  527.   (mouse-track-maybe-own-selection
  528.    (mouse-track-select event t 'primary-selection)
  529.    'PRIMARY))
  530.   
  531. (defun mouse-track-insert (event &optional delete)
  532.   "Make a selection with the mouse and insert it at point.
  533. This is exactly the same as the `mouse-track' command on \\[mouse-track], 
  534. except that point is not moved; the selected text is immediately inserted
  535. after being selected\; and the selection is immediately disowned afterwards."
  536.   (interactive "*e")
  537.   (let ((s (save-excursion
  538.          (save-window-excursion
  539.            (let ((pair (mouse-track-select event nil 'primary-selection)))
  540.          (prog1
  541.              (buffer-substring (car pair) (cdr pair))
  542.            (if delete
  543.                (kill-region (car pair) (cdr pair)))))))))
  544.     (or (equal s "") (insert s))))
  545.  
  546. (defun mouse-track-delete-and-insert (event)
  547.   "Make a selection with the mouse and insert it at point.
  548. This is exactly the same as the `mouse-track' command on \\[mouse-track], 
  549. except that point is not moved; the selected text is immediately inserted
  550. after being selected\; and the text of the selection is deleted."
  551.   (interactive "*e")
  552.   (mouse-track-insert event t))
  553.