code.delx.au - gnu-emacs/blob - lisp/mouse.el

   1 ;; Mouse support that is independent of window systems.
   2 ;; Copyright (C) 1988 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 1, 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 \f
  23 (defun mouse-select ()
  24   "Select Emacs window the mouse is on."
  25   (interactive "@"))
  26
  27 (defun mouse-delete-window ()
  28   "Delete the Emacs window the mouse is on."
  29   (interactive "@")
  30   (delete-window))
  31
  32 (defun mouse-keep-one-window ()
  33   "Select Emacs window mouse is on, then kill all other Emacs windows."
  34   (interactive "@")
  35   (delete-other-windows))
  36
  37 (defun mouse-select-and-split ()
  38   "Select Emacs window mouse is on, then split it vertically in half."
  39   (interactive "@")
  40   (split-window-vertically nil))
  41
  42 (defun mouse-set-point (event)
  43   "Select Emacs window mouse is on, and move point to mouse position."
  44   (interactive "@e")
  45   (let ((relative-coordinate
  46          (coordinates-in-window-p (car event) (selected-window))))
  47     (if (consp relative-coordinate)
  48         (progn
  49           (move-to-window-line (car (cdr relative-coordinate)))
  50           ;; Note that hscroll must get above 1
  51           ;; before the text actually starts to move.
  52           (move-to-column (+ (car relative-coordinate) (current-column)
  53                              (1- (max 1 (window-hscroll (selected-window))))))
  54           (what-line)))))
  55
  56 (defun mouse-eval-last-sexpr (event)
  57   (interactive "@e")
  58   (save-excursion
  59     (mouse-set-point event)
  60     (eval-last-sexp nil)))
  61
  62 (defun mouse-line-length (event)
  63   "Print the length of the line indicated by the pointer."
  64   (interactive "@e")
  65   (let ((relative-coordinate
  66           (coordinates-in-window-p (car event) (selected-window))))
  67     (if (consp relative-coordinate)
  68         (save-excursion
  69           (move-to-window-line (car (cdr relative-coordinate)))
  70           (end-of-line)
  71           (push-mark nil t)
  72           (beginning-of-line)
  73           (message "Line length: %d"
  74                            (- (region-end) (region-beginning)))
  75           (sleep-for 1)))))
  76
  77 (defun mouse-set-mark (event)
  78   "Select Emacs window mouse is on, and set mark at mouse position.
  79 Display cursor at that position for a second."
  80   (interactive "@e")
  81   (let ((point-save (point)))
  82     (unwind-protect
  83         (progn (mouse-set-point event)
  84                (push-mark nil t)
  85                (sleep-for 1))
  86       (goto-char point-save))))
  87
  88 (defun mouse-scroll (event)
  89   "Scroll point to the mouse position."
  90   (interactive "@e")
  91   (let ((relative-coordinate
  92          (coordinates-in-window-p (car event) (selected-window))))
  93     (if (consp relative-coordinate)
  94         (progn
  95           (recenter (car (cdr relative-coordinate)))
  96           (scroll-right (+ (car relative-coordinate) (current-column)))))))
  97
  98 (defun mouse-del-char (event)
  99   "Delete the char pointed to by the mouse."
 100   (interactive "@e")
 101   (let ((relative-coordinate
 102           (coordinates-in-window-p (car event) (selected-window))))
 103     (if (consp relative-coordinate)
 104         (progn
 105           (move-to-window-line (car (cdr relative-coordinate)))
 106           (move-to-column (+ (car relative-coordinate) (current-column)))
 107           (delete-char 1 nil)))))
 108
 109 (defun mouse-kill-line (event)
 110   "Kill the line pointed to by the mouse."
 111   (interactive "@e")
 112   (let ((relative-coordinate
 113          (coordinates-in-window-p (car event) (selected-window))))
 114     (if (consp relative-coordinate)
 115         (progn
 116           (move-to-window-line (car (cdr relative-coordinate)))
 117           (move-to-column (+ (car relative-coordinate) (current-column)))
 118           (kill-line nil)))))
 119
 120 (defun narrow-window-to-region (m n)
 121   "Narrow window to region between point and last mark"
 122   (interactive "r")
 123   (save-excursion
 124     (save-restriction
 125       (if (eq (selected-window) (next-window))
 126           (split-window))
 127       (goto-char m)
 128       (recenter 0)
 129       (if (eq (selected-window)
 130               (if (zerop (minibuffer-depth))
 131                   (next-window)))
 132           ()
 133         (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
 134
 135 (defun mouse-window-to-region (event)
 136   "Narrow window to region between cursor and mouse pointer."
 137   (interactive "@e")
 138   (let ((point-save (point)))
 139     (unwind-protect
 140         (progn (mouse-set-point event)
 141                (push-mark nil t)
 142                (sit-for 1))
 143       (goto-char point-save)
 144       (narrow-window-to-region (region-beginning) (region-end)))))
 145
 146 (defun mouse-ignore ()
 147   "Don't do anything."
 148   (interactive))
 149 \f
 150 ;; Commands for the scroll bar.
 151
 152 (defun mouse-scroll-down (nlines)
 153   (interactive "@p")
 154   (scroll-down nlines))
 155
 156 (defun mouse-scroll-up (nlines)
 157   (interactive "@p")
 158   (scroll-up nlines))
 159
 160 (defun mouse-scroll-down-full ()
 161   (interactive "@")
 162   (scroll-down nil))
 163
 164 (defun mouse-scroll-up-full ()
 165   (interactive "@")
 166   (scroll-up nil))
 167
 168 (defun mouse-scroll-move-cursor (nlines)
 169   (interactive "@p")
 170   (move-to-window-line nlines))
 171
 172 (defun mouse-scroll-absolute (event)
 173   (interactive "@e")
 174   (let* ((pos (car event))
 175          (position (car pos))
 176          (length (car (cdr pos))))
 177     (if (<= length 0) (setq length 1))
 178     (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
 179            (newpos (* (/ (* (/ (buffer-size) scale-factor)
 180                             position)
 181                          length)
 182                       scale-factor)))
 183       (goto-char newpos)
 184       (recenter '(4)))))
 185
 186 (defun mouse-scroll-left (ncolumns)
 187   (interactive "@p")
 188   (scroll-left ncolumns))
 189
 190 (defun mouse-scroll-right (ncolumns)
 191   (interactive "@p")
 192   (scroll-right ncolumns))
 193
 194 (defun mouse-scroll-left-full ()
 195   (interactive "@")
 196   (scroll-left nil))
 197
 198 (defun mouse-scroll-right-full ()
 199   (interactive "@")
 200   (scroll-right nil))
 201
 202 (defun mouse-scroll-move-cursor-horizontally (ncolumns)
 203   (interactive "@p")
 204   (move-to-column ncolumns))
 205
 206 (defun mouse-scroll-absolute-horizontally (event)
 207   (interactive "@e")
 208   (let* ((pos (car event))
 209          (position (car pos))
 210          (length (car (cdr pos))))
 211   (set-window-hscroll (selected-window) 33)))
 212
 213 ;; Set up these commands, including the prefix keys for the scroll bar.
 214
 215 (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
 216 (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
 217   'mouse-vertical-scroll-bar-prefix)
 218
 219 (defun mouse-scroll-motion (event)
 220   (interactive "e")
 221   (let ((pos (car (car event)))
 222         (length (car (cdr (car event)))))
 223     (message "[%d %d]" pos length)))
 224
 225 (let ((map (function mouse-vertical-scroll-bar-prefix)))
 226   (define-key map mouse-button-right 'mouse-scroll-down)
 227   (define-key map mouse-button-left 'mouse-scroll-up)
 228   (define-key map mouse-button-middle 'mouse-scroll-absolute)
 229   (define-key map mouse-motion 'x-horizontal-line))
 230
 231 ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
 232 ;(define-key global-mouse-map mouse-vertical-slider-prefix
 233 ;  'mouse-vertical-slider-prefix)
 234
 235 ;(let ((map (function mouse-vertical-slider-prefix)))
 236 ;  (define-key map mouse-button-right 'mouse-scroll-move-cursor)
 237 ;  (define-key map mouse-button-left 'mouse-scroll-move-cursor)
 238 ;  (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
 239
 240 (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
 241 (define-key global-mouse-map mouse-vertical-thumbup-prefix
 242   'mouse-vertical-thumbup-prefix)
 243
 244 (let ((map (function mouse-vertical-thumbup-prefix)))
 245   (define-key map mouse-button-right 'mouse-scroll-down-full)
 246   (define-key map mouse-button-left 'mouse-scroll-down-full)
 247   (define-key map mouse-button-middle 'mouse-scroll-down-full))
 248
 249 (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
 250 (define-key global-mouse-map mouse-vertical-thumbdown-prefix
 251   'mouse-vertical-thumbdown-prefix)
 252
 253 (let ((map (function mouse-vertical-thumbdown-prefix)))
 254   (define-key map mouse-button-right 'mouse-scroll-up-full)
 255   (define-key map mouse-button-left 'mouse-scroll-up-full)
 256   (define-key map mouse-button-middle 'mouse-scroll-up-full))
 257
 258 ;; Horizontal bar
 259
 260 (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
 261 (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
 262   'mouse-horizontal-scroll-bar-prefix)
 263
 264 (let ((map (function mouse-horizontal-scroll-bar-prefix)))
 265   (define-key map mouse-button-right 'mouse-scroll-right)
 266   (define-key map mouse-button-left 'mouse-scroll-left)
 267   (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
 268
 269 (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
 270 (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
 271   'mouse-horizontal-thumbleft-prefix)
 272
 273 (let ((map (function mouse-horizontal-thumbleft-prefix)))
 274   (define-key map mouse-button-right 'mouse-scroll-left-full)
 275   (define-key map mouse-button-left 'mouse-scroll-left-full)
 276   (define-key map mouse-button-middle 'mouse-scroll-left-full))
 277
 278 (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
 279 (define-key global-mouse-map mouse-horizontal-thumbright-prefix
 280   'mouse-horizontal-thumbright-prefix)
 281
 282 (let ((map (function mouse-horizontal-thumbright-prefix)))
 283   (define-key map mouse-button-right 'mouse-scroll-right-full)
 284   (define-key map mouse-button-left 'mouse-scroll-right-full)
 285   (define-key map mouse-button-middle 'mouse-scroll-right-full))
 286
 287
 288 ;;
 289 ;; Here are experimental things being tested.  Mouse events
 290 ;; are of the form:
 291 ;;      ((x y) window screen-part key-sequence timestamp)
 292
 293 ;;
 294 ;; Dynamically track mouse coordinates
 295 ;;
 296
 297 (defun track-mouse (event)
 298   "Track the coordinates, absolute and relative, of the mouse."
 299   (interactive "@e")
 300   (while mouse-grabbed
 301     (let* ((pos (read-mouse-position (selected-screen)))
 302            (abs-x (car pos))
 303            (abs-y (cdr pos))
 304            (relative-coordinate (coordinates-in-window-p
 305                                  (list (car pos) (cdr pos))
 306                                  (selected-window))))
 307       (if (consp relative-coordinate)
 308           (message "mouse: [%d %d], (%d %d)" abs-x abs-y
 309                    (car relative-coordinate)
 310                    (car (cdr relative-coordinate)))
 311         (message "mouse: [%d %d]" abs-x abs-y)))))
 312
 313 ;;
 314 ;; Dynamically put a box around the line indicated by point
 315 ;;
 316
 317 (require 'backquote)
 318
 319 (defun mouse-select-buffer-line (event)
 320   (interactive "@e")
 321   (let ((relative-coordinate
 322          (coordinates-in-window-p (car event) (selected-window)))
 323         (abs-y (car (cdr (car event)))))
 324     (if (consp relative-coordinate)
 325         (progn
 326           (save-excursion
 327             (move-to-window-line (car (cdr relative-coordinate)))
 328             (x-draw-rectangle
 329              (selected-screen)
 330              abs-y 0
 331              (save-excursion
 332                  (move-to-window-line (car (cdr relative-coordinate)))
 333                  (end-of-line)
 334                  (push-mark nil t)
 335                  (beginning-of-line)
 336                  (- (region-end) (region-beginning))) 1)
 337             (setq the-buffer (Buffer-menu-buffer t)))
 338           (sit-for 1)
 339           (x-erase-rectangle (selected-screen))))))
 340
 341 (defvar last-line-drawn nil)
 342 (defvar begin-delim "[^ \t]")
 343 (defvar end-delim   "[^ \t]")
 344
 345 (defun mouse-boxing (event)
 346   (interactive "@e")
 347   (save-excursion
 348     (let ((screen (selected-screen)))
 349       (while (= (x-mouse-events) 0)
 350         (let* ((pos (read-mouse-position screen))
 351                (abs-x (car pos))
 352                (abs-y (cdr pos))
 353                (relative-coordinate
 354                 (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
 355                                          (selected-window)))
 356                (begin-reg nil)
 357                (end-reg nil)
 358                (end-column nil)
 359                (begin-column nil))
 360           (if (and (consp relative-coordinate)
 361                    (or (not last-line-drawn)
 362                        (not (= last-line-drawn abs-y))))
 363               (progn
 364                 (move-to-window-line (car (cdr relative-coordinate)))
 365                 (if (= (following-char) 10)
 366                     ()
 367                   (progn
 368                     (setq begin-reg (1- (re-search-forward end-delim)))
 369                     (setq begin-column (1- (current-column)))
 370                     (end-of-line)
 371                     (setq end-reg (1+ (re-search-backward begin-delim)))
 372                     (setq end-column (1+ (current-column)))
 373                     (message "%s" (buffer-substring begin-reg end-reg))
 374                     (x-draw-rectangle screen
 375                                       (setq last-line-drawn abs-y)
 376                                       begin-column
 377                                       (- end-column begin-column) 1))))))))))
 378
 379 (defun mouse-erase-box ()
 380   (interactive)
 381   (if last-line-drawn
 382       (progn
 383         (x-erase-rectangle (selected-screen))
 384         (setq last-line-drawn nil))))
 385
 386 (defun test-x-rectangle ()
 387   (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
 388   (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
 389   (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
 390
 391 ;;
 392 ;; Here is how to do double clicking in lisp.  About to change.
 393 ;;
 394
 395 (defvar double-start nil)
 396 (defconst double-click-interval 300
 397   "Max ticks between clicks")
 398
 399 (defun double-down (event)
 400   (interactive "@e")
 401   (if double-start
 402       (let ((interval (- (nth 4 event) double-start)))
 403         (if (< interval double-click-interval)
 404             (progn
 405               (backward-up-list 1)
 406               ;;      (message "Interval %d" interval)
 407               (sleep-for 1)))
 408         (setq double-start nil))
 409     (setq double-start (nth 4 event))))
 410
 411 (defun double-up (event)
 412   (interactive "@e")
 413   (and double-start
 414        (> (- (nth 4 event ) double-start) double-click-interval)
 415        (setq double-start nil)))
 416
 417 (defun x-test-doubleclick ()
 418   (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
 419   (define-key doubleclick-test-map mouse-button-left 'double-down)
 420   (define-key doubleclick-test-map mouse-button-left-up 'double-up))
 421
 422 ;;
 423 ;; This scrolls while button is depressed.  Use preferable in scrollbar.
 424 ;;
 425
 426 (defvar scrolled-lines 0)
 427 (defconst scroll-speed 1)
 428
 429 (defun incr-scroll-down (event)
 430   (interactive "@e")
 431   (setq scrolled-lines 0)
 432   (incremental-scroll scroll-speed))
 433
 434 (defun incr-scroll-up (event)
 435   (interactive "@e")
 436   (setq scrolled-lines 0)
 437   (incremental-scroll (- scroll-speed)))
 438
 439 (defun incremental-scroll (n)
 440   (while (= (x-mouse-events) 0)
 441     (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
 442     (scroll-down n)
 443     (sit-for 300 t)))
 444
 445 (defun incr-scroll-stop (event)
 446   (interactive "@e")
 447   (message "Scrolled %d lines" scrolled-lines)
 448   (setq scrolled-lines 0)
 449   (sleep-for 1))
 450
 451 (defun x-testing-scroll ()
 452   (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
 453     (define-key scrolling-map mouse-button-left 'incr-scroll-down)
 454     (define-key scrolling-map mouse-button-right 'incr-scroll-up)
 455     (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
 456     (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
 457
 458 ;;
 459 ;; Some playthings suitable for picture mode?  They need work.
 460 ;;
 461
 462 (defun mouse-kill-rectangle (event)
 463   "Kill the rectangle between point and the mouse cursor."
 464   (interactive "@e")
 465   (let ((point-save (point)))
 466     (save-excursion
 467       (mouse-set-point event)
 468       (push-mark nil t)
 469       (if (> point-save (point))
 470           (kill-rectangle (point) point-save)
 471         (kill-rectangle point-save (point))))))
 472
 473 (defun mouse-open-rectangle (event)
 474   "Kill the rectangle between point and the mouse cursor."
 475   (interactive "@e")
 476   (let ((point-save (point)))
 477     (save-excursion
 478       (mouse-set-point event)
 479       (push-mark nil t)
 480       (if (> point-save (point))
 481           (open-rectangle (point) point-save)
 482         (open-rectangle point-save (point))))))
 483
 484 ;; Must be a better way to do this.
 485
 486 (defun mouse-multiple-insert (n char)
 487   (while (> n 0)
 488     (insert char)
 489     (setq n (1- n))))
 490
 491 ;; What this could do is not finalize until button was released.
 492
 493 (defun mouse-move-text (event)
 494   "Move text from point to cursor position, inserting spaces."
 495   (interactive "@e")
 496   (let* ((relative-coordinate
 497           (coordinates-in-window-p (car event) (selected-window))))
 498     (if (consp relative-coordinate)
 499         (cond ((> (current-column) (car relative-coordinate))
 500                (delete-char
 501                 (- (car relative-coordinate) (current-column))))
 502               ((< (current-column) (car relative-coordinate))
 503                (mouse-multiple-insert
 504                 (- (car relative-coordinate) (current-column)) " "))
 505               ((= (current-column) (car relative-coordinate)) (ding))))))