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