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

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