lisp/mouse.el

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