lisp/mouse.el

   1 ;;; mouse.el --- window system-independent mouse support.
   2
   3 ;;; Copyright (C) 1988 Free Software Foundation, Inc.
   4
   5 ;;; This file is part of GNU Emacs.
   6
   7 ;;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;;; it under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 1, or (at your option)
  10 ;;; any later version.
  11
  12 ;;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \f
  22 ;;; Utility functions.
  23
  24 (defun mouse-movement-p (event)
  25   (and (consp event)
  26        (eq (car event) 'mouse-movement)))
  27
  28 (defun event-window (event)     (nth 1 event))
  29 (defun event-point (event)      (nth 2 event))
  30 (defun mouse-coords (event)     (nth 3 event))
  31 (defun mouse-timestamp (event)  (nth 4 event))
  32
  33 ;;; Indent track-mouse like progn.
  34 (put 'track-mouse 'lisp-indent-function 0)
  35
  36 \f
  37 (defun mouse-delete-window (click)
  38   "Delete the window clicked on.
  39 This must be bound to a mouse click."
  40   (interactive "K")
  41   (delete-window (event-window click)))
  42
  43 (defun mouse-delete-other-windows (click)
  44   "Select Emacs window clicked on, then kill all other Emacs windows.
  45 This must be bound to a mouse click."
  46   (interactive "K")
  47   (select-window (event-window click))
  48   (delete-other-windows))
  49
  50 (defun mouse-split-window-vertically (click)
  51   "Select Emacs window mouse is on, then split it vertically in half.
  52 The window is split at the line clicked on.
  53 This command must be bound to a mouse click."
  54   (interactive "K")
  55   (select-window (event-window click))
  56   (split-window-vertically (1+ (cdr (mouse-coords click)))))
  57
  58 (defun mouse-set-point (click)
  59   "Move point to the position clicked on with the mouse.
  60 This must be bound to a mouse click."
  61   (interactive "K")
  62   (select-window (event-window click))
  63   (goto-char (event-point click)))
  64
  65 (defun mouse-set-mark (click)
  66   "Set mark at the position clicked on with the mouse.
  67 Display cursor at that position for a second.
  68 This must be bound to a mouse click."
  69   (interactive "K")
  70   (let ((point-save (point)))
  71     (unwind-protect
  72         (progn (mouse-set-point click)
  73                (push-mark nil t)
  74                (sit-for 1))
  75       (goto-char point-save))))
  76
  77 (defun mouse-kill (click)
  78   "Kill the region between point and the mouse click.
  79 The text is saved in the kill ring, as with \\[kill-region]."
  80   (interactive "K")
  81   (mouse-set-mark click)
  82   (kill-region))
  83
  84 (defun mouse-kill-ring-save
  85   "Copy the region between point and the mouse click in the kill ring.
  86 This does not delete the region; it acts like \\[kill-ring-save]."
  87   (interactive "K")
  88   (mouse-set-mark click)
  89   (kill-ring-save))
  90
  91
  92 \f
  93 ;; Commands for the scroll bar.
  94
  95 (defun mouse-scroll-down (nlines)
  96   (interactive "@p")
  97   (scroll-down nlines))
  98
  99 (defun mouse-scroll-up (nlines)
 100   (interactive "@p")
 101   (scroll-up nlines))
 102
 103 (defun mouse-scroll-down-full ()
 104   (interactive "@")
 105   (scroll-down nil))
 106
 107 (defun mouse-scroll-up-full ()
 108   (interactive "@")
 109   (scroll-up nil))
 110
 111 (defun mouse-scroll-move-cursor (nlines)
 112   (interactive "@p")
 113   (move-to-window-line nlines))
 114
 115 (defun mouse-scroll-absolute (event)
 116   (interactive "@e")
 117   (let* ((pos (car event))
 118          (position (car pos))
 119          (length (car (cdr pos))))
 120     (if (<= length 0) (setq length 1))
 121     (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
 122            (newpos (* (/ (* (/ (buffer-size) scale-factor)
 123                             position)
 124                          length)
 125                       scale-factor)))
 126       (goto-char newpos)
 127       (recenter '(4)))))
 128
 129 (defun mouse-scroll-left (ncolumns)
 130   (interactive "@p")
 131   (scroll-left ncolumns))
 132
 133 (defun mouse-scroll-right (ncolumns)
 134   (interactive "@p")
 135   (scroll-right ncolumns))
 136
 137 (defun mouse-scroll-left-full ()
 138   (interactive "@")
 139   (scroll-left nil))
 140
 141 (defun mouse-scroll-right-full ()
 142   (interactive "@")
 143   (scroll-right nil))
 144
 145 (defun mouse-scroll-move-cursor-horizontally (ncolumns)
 146   (interactive "@p")
 147   (move-to-column ncolumns))
 148
 149 (defun mouse-scroll-absolute-horizontally (event)
 150   (interactive "@e")
 151   (let* ((pos (car event))
 152          (position (car pos))
 153          (length (car (cdr pos))))
 154   (set-window-hscroll (selected-window) 33)))
 155
 156 ;; Set up these commands, including the prefix keys for the scroll bar.
 157
 158 ;;; (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
 159 ;;; (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
 160 ;;;   'mouse-vertical-scroll-bar-prefix)
 161 ;;;
 162 ;;; (defun mouse-scroll-motion (event)
 163 ;;;   (interactive "e")
 164 ;;;   (let ((pos (car (car event)))
 165 ;;;     (length (car (cdr (car event)))))
 166 ;;;     (message "[%d %d]" pos length)))
 167 ;;;
 168 ;;; (let ((map (function mouse-vertical-scroll-bar-prefix)))
 169 ;;;   (define-key map mouse-button-right 'mouse-scroll-down)
 170 ;;;   (define-key map mouse-button-left 'mouse-scroll-up)
 171 ;;;   (define-key map mouse-button-middle 'mouse-scroll-absolute)
 172 ;;;   (define-key map mouse-motion 'x-horizontal-line))
 173 ;;;
 174 ;;; ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
 175 ;;; ;(define-key global-mouse-map mouse-vertical-slider-prefix
 176 ;;; ;  'mouse-vertical-slider-prefix)
 177 ;;;
 178 ;;; ;(let ((map (function mouse-vertical-slider-prefix)))
 179 ;;; ;  (define-key map mouse-button-right 'mouse-scroll-move-cursor)
 180 ;;; ;  (define-key map mouse-button-left 'mouse-scroll-move-cursor)
 181 ;;; ;  (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
 182 ;;;
 183 ;;; (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
 184 ;;; (define-key global-mouse-map mouse-vertical-thumbup-prefix
 185 ;;;   'mouse-vertical-thumbup-prefix)
 186 ;;;
 187 ;;; (let ((map (function mouse-vertical-thumbup-prefix)))
 188 ;;;   (define-key map mouse-button-right 'mouse-scroll-down-full)
 189 ;;;   (define-key map mouse-button-left 'mouse-scroll-down-full)
 190 ;;;   (define-key map mouse-button-middle 'mouse-scroll-down-full))
 191 ;;;
 192 ;;; (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
 193 ;;; (define-key global-mouse-map mouse-vertical-thumbdown-prefix
 194 ;;;   'mouse-vertical-thumbdown-prefix)
 195 ;;;
 196 ;;; (let ((map (function mouse-vertical-thumbdown-prefix)))
 197 ;;;   (define-key map mouse-button-right 'mouse-scroll-up-full)
 198 ;;;   (define-key map mouse-button-left 'mouse-scroll-up-full)
 199 ;;;   (define-key map mouse-button-middle 'mouse-scroll-up-full))
 200 ;;;
 201 ;;; ;; Horizontal bar
 202 ;;;
 203 ;;; (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
 204 ;;; (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
 205 ;;;   'mouse-horizontal-scroll-bar-prefix)
 206 ;;;
 207 ;;; (let ((map (function mouse-horizontal-scroll-bar-prefix)))
 208 ;;;   (define-key map mouse-button-right 'mouse-scroll-right)
 209 ;;;   (define-key map mouse-button-left 'mouse-scroll-left)
 210 ;;;   (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
 211 ;;;
 212 ;;; (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
 213 ;;; (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
 214 ;;;   'mouse-horizontal-thumbleft-prefix)
 215 ;;;
 216 ;;; (let ((map (function mouse-horizontal-thumbleft-prefix)))
 217 ;;;   (define-key map mouse-button-right 'mouse-scroll-left-full)
 218 ;;;   (define-key map mouse-button-left 'mouse-scroll-left-full)
 219 ;;;   (define-key map mouse-button-middle 'mouse-scroll-left-full))
 220 ;;;
 221 ;;; (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
 222 ;;; (define-key global-mouse-map mouse-horizontal-thumbright-prefix
 223 ;;;   'mouse-horizontal-thumbright-prefix)
 224 ;;;
 225 ;;; (let ((map (function mouse-horizontal-thumbright-prefix)))
 226 ;;;   (define-key map mouse-button-right 'mouse-scroll-right-full)
 227 ;;;   (define-key map mouse-button-left 'mouse-scroll-right-full)
 228 ;;;   (define-key map mouse-button-middle 'mouse-scroll-right-full))
 229
 230
 231 ;;;;
 232 ;;;; Here are experimental things being tested.  Mouse events
 233 ;;;; are of the form:
 234 ;;;;    ((x y) window screen-part key-sequence timestamp)
 235 ;;
 236 ;;;;
 237 ;;;; Dynamically track mouse coordinates
 238 ;;;;
 239 ;;
 240 ;;(defun track-mouse (event)
 241 ;;  "Track the coordinates, absolute and relative, of the mouse."
 242 ;;  (interactive "@e")
 243 ;;  (while mouse-grabbed
 244 ;;    (let* ((pos (read-mouse-position (selected-screen)))
 245 ;;         (abs-x (car pos))
 246 ;;         (abs-y (cdr pos))
 247 ;;         (relative-coordinate (coordinates-in-window-p
 248 ;;                               (list (car pos) (cdr pos))
 249 ;;                               (selected-window))))
 250 ;;      (if (consp relative-coordinate)
 251 ;;        (message "mouse: [%d %d], (%d %d)" abs-x abs-y
 252 ;;                 (car relative-coordinate)
 253 ;;                 (car (cdr relative-coordinate)))
 254 ;;      (message "mouse: [%d %d]" abs-x abs-y)))))
 255
 256 ;;
 257 ;; Dynamically put a box around the line indicated by point
 258 ;;
 259
 260 (require 'backquote)
 261
 262 (defun mouse-select-buffer-line (event)
 263   (interactive "@e")
 264   (let ((relative-coordinate
 265          (coordinates-in-window-p (car event) (selected-window)))
 266         (abs-y (car (cdr (car event)))))
 267     (if (consp relative-coordinate)
 268         (progn
 269           (save-excursion
 270             (move-to-window-line (car (cdr relative-coordinate)))
 271             (x-draw-rectangle
 272              (selected-screen)
 273              abs-y 0
 274              (save-excursion
 275                  (move-to-window-line (car (cdr relative-coordinate)))
 276                  (end-of-line)
 277                  (push-mark nil t)
 278                  (beginning-of-line)
 279                  (- (region-end) (region-beginning))) 1)
 280             (setq the-buffer (Buffer-menu-buffer t)))
 281           (sit-for 1)
 282           (x-erase-rectangle (selected-screen))))))
 283
 284 (defvar last-line-drawn nil)
 285 (defvar begin-delim "[^ \t]")
 286 (defvar end-delim   "[^ \t]")
 287
 288 (defun mouse-boxing (event)
 289   (interactive "@e")
 290   (save-excursion
 291     (let ((screen (selected-screen)))
 292       (while (= (x-mouse-events) 0)
 293         (let* ((pos (read-mouse-position screen))
 294                (abs-x (car pos))
 295                (abs-y (cdr pos))
 296                (relative-coordinate
 297                 (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
 298                                          (selected-window)))
 299                (begin-reg nil)
 300                (end-reg nil)
 301                (end-column nil)
 302                (begin-column nil))
 303           (if (and (consp relative-coordinate)
 304                    (or (not last-line-drawn)
 305                        (not (= last-line-drawn abs-y))))
 306               (progn
 307                 (move-to-window-line (car (cdr relative-coordinate)))
 308                 (if (= (following-char) 10)
 309                     ()
 310                   (progn
 311                     (setq begin-reg (1- (re-search-forward end-delim)))
 312                     (setq begin-column (1- (current-column)))
 313                     (end-of-line)
 314                     (setq end-reg (1+ (re-search-backward begin-delim)))
 315                     (setq end-column (1+ (current-column)))
 316                     (message "%s" (buffer-substring begin-reg end-reg))
 317                     (x-draw-rectangle screen
 318                                       (setq last-line-drawn abs-y)
 319                                       begin-column
 320                                       (- end-column begin-column) 1))))))))))
 321
 322 (defun mouse-erase-box ()
 323   (interactive)
 324   (if last-line-drawn
 325       (progn
 326         (x-erase-rectangle (selected-screen))
 327         (setq last-line-drawn nil))))
 328
 329 ;;; (defun test-x-rectangle ()
 330 ;;;   (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
 331 ;;;   (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
 332 ;;;   (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
 333
 334 ;;
 335 ;; Here is how to do double clicking in lisp.  About to change.
 336 ;;
 337
 338 (defvar double-start nil)
 339 (defconst double-click-interval 300
 340   "Max ticks between clicks")
 341
 342 (defun double-down (event)
 343   (interactive "@e")
 344   (if double-start
 345       (let ((interval (- (nth 4 event) double-start)))
 346         (if (< interval double-click-interval)
 347             (progn
 348               (backward-up-list 1)
 349               ;;      (message "Interval %d" interval)
 350               (sleep-for 1)))
 351         (setq double-start nil))
 352     (setq double-start (nth 4 event))))
 353
 354 (defun double-up (event)
 355   (interactive "@e")
 356   (and double-start
 357        (> (- (nth 4 event ) double-start) double-click-interval)
 358        (setq double-start nil)))
 359
 360 ;;; (defun x-test-doubleclick ()
 361 ;;;   (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
 362 ;;;   (define-key doubleclick-test-map mouse-button-left 'double-down)
 363 ;;;   (define-key doubleclick-test-map mouse-button-left-up 'double-up))
 364
 365 ;;
 366 ;; This scrolls while button is depressed.  Use preferable in scrollbar.
 367 ;;
 368
 369 (defvar scrolled-lines 0)
 370 (defconst scroll-speed 1)
 371
 372 (defun incr-scroll-down (event)
 373   (interactive "@e")
 374   (setq scrolled-lines 0)
 375   (incremental-scroll scroll-speed))
 376
 377 (defun incr-scroll-up (event)
 378   (interactive "@e")
 379   (setq scrolled-lines 0)
 380   (incremental-scroll (- scroll-speed)))
 381
 382 (defun incremental-scroll (n)
 383   (while (= (x-mouse-events) 0)
 384     (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
 385     (scroll-down n)
 386     (sit-for 300 t)))
 387
 388 (defun incr-scroll-stop (event)
 389   (interactive "@e")
 390   (message "Scrolled %d lines" scrolled-lines)
 391   (setq scrolled-lines 0)
 392   (sleep-for 1))
 393
 394 ;;; (defun x-testing-scroll ()
 395 ;;;   (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
 396 ;;;     (define-key scrolling-map mouse-button-left 'incr-scroll-down)
 397 ;;;     (define-key scrolling-map mouse-button-right 'incr-scroll-up)
 398 ;;;     (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
 399 ;;;     (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
 400
 401 ;;
 402 ;; Some playthings suitable for picture mode?  They need work.
 403 ;;
 404
 405 (defun mouse-kill-rectangle (event)
 406   "Kill the rectangle between point and the mouse cursor."
 407   (interactive "@e")
 408   (let ((point-save (point)))
 409     (save-excursion
 410       (mouse-set-point event)
 411       (push-mark nil t)
 412       (if (> point-save (point))
 413           (kill-rectangle (point) point-save)
 414         (kill-rectangle point-save (point))))))
 415
 416 (defun mouse-open-rectangle (event)
 417   "Kill the rectangle between point and the mouse cursor."
 418   (interactive "@e")
 419   (let ((point-save (point)))
 420     (save-excursion
 421       (mouse-set-point event)
 422       (push-mark nil t)
 423       (if (> point-save (point))
 424           (open-rectangle (point) point-save)
 425         (open-rectangle point-save (point))))))
 426
 427 ;; Must be a better way to do this.
 428
 429 (defun mouse-multiple-insert (n char)
 430   (while (> n 0)
 431     (insert char)
 432     (setq n (1- n))))
 433
 434 ;; What this could do is not finalize until button was released.
 435
 436 (defun mouse-move-text (event)
 437   "Move text from point to cursor position, inserting spaces."
 438   (interactive "@e")
 439   (let* ((relative-coordinate
 440           (coordinates-in-window-p (car event) (selected-window))))
 441     (if (consp relative-coordinate)
 442         (cond ((> (current-column) (car relative-coordinate))
 443                (delete-char
 444                 (- (car relative-coordinate) (current-column))))
 445               ((< (current-column) (car relative-coordinate))
 446                (mouse-multiple-insert
 447                 (- (car relative-coordinate) (current-column)) " "))
 448               ((= (current-column) (car relative-coordinate)) (ding))))))
 449
 450 \f
 451 ;;; Bindings for mouse commands.
 452
 453 (global-set-key   [mouse-1]     'mouse-set-point)
 454 (global-set-key [S-mouse-1]     'mouse-set-mark)
 455 (global-set-key   [mouse-3]     'mouse-delete-other-windows)
 456
 457 (provide 'mouse)
 458
 459 ;;; mouse.el ends here