home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-18.59-bin.lha / lib / emacs / 18.59 / lisp / x-mouse.el < prev    next >
Lisp/Scheme  |  1992-03-14  |  11KB  |  296 lines
  1. ;; Mouse support for X window system.
  2. ;; Copyright (C) 1985, 1987 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.  
  21. (provide 'x-mouse)
  22.  
  23. (defconst x-button-right (char-to-string 0))
  24. (defconst x-button-middle (char-to-string 1))
  25. (defconst x-button-left (char-to-string 2))
  26.  
  27. (defconst x-button-right-up (char-to-string 4))
  28. (defconst x-button-middle-up (char-to-string 5))
  29. (defconst x-button-left-up (char-to-string 6))
  30.  
  31. (defconst x-button-s-right (char-to-string 16))
  32. (defconst x-button-s-middle (char-to-string 17))
  33. (defconst x-button-s-left (char-to-string 18))
  34.  
  35. (defconst x-button-s-right-up (char-to-string 20))
  36. (defconst x-button-s-middle-up (char-to-string 21))
  37. (defconst x-button-s-left-up (char-to-string 22))
  38.  
  39. (defconst x-button-m-right (char-to-string 32))
  40. (defconst x-button-m-middle (char-to-string 33))
  41. (defconst x-button-m-left (char-to-string 34))
  42.  
  43. (defconst x-button-m-right-up (char-to-string 36))
  44. (defconst x-button-m-middle-up (char-to-string 37))
  45. (defconst x-button-m-left-up (char-to-string 38))
  46.  
  47. (defconst x-button-c-right (char-to-string 64))
  48. (defconst x-button-c-middle (char-to-string 65))
  49. (defconst x-button-c-left (char-to-string 66))
  50.  
  51. (defconst x-button-c-right-up (char-to-string 68))
  52. (defconst x-button-c-middle-up (char-to-string 69))
  53. (defconst x-button-c-left-up (char-to-string 70))
  54.  
  55. (defconst x-button-m-s-right (char-to-string 48))
  56. (defconst x-button-m-s-middle (char-to-string 49))
  57. (defconst x-button-m-s-left (char-to-string 50))
  58.  
  59. (defconst x-button-m-s-right-up (char-to-string 52))
  60. (defconst x-button-m-s-middle-up (char-to-string 53))
  61. (defconst x-button-m-s-left-up (char-to-string 54))
  62.  
  63. (defconst x-button-c-s-right (char-to-string 80))
  64. (defconst x-button-c-s-middle (char-to-string 81))
  65. (defconst x-button-c-s-left (char-to-string 82))
  66.  
  67. (defconst x-button-c-s-right-up (char-to-string 84))
  68. (defconst x-button-c-s-middle-up (char-to-string 85))
  69. (defconst x-button-c-s-left-up (char-to-string 86))
  70.  
  71. (defconst x-button-c-m-right (char-to-string 96))
  72. (defconst x-button-c-m-middle (char-to-string 97))
  73. (defconst x-button-c-m-left (char-to-string 98))
  74.  
  75. (defconst x-button-c-m-right-up (char-to-string 100))
  76. (defconst x-button-c-m-middle-up (char-to-string 101))
  77. (defconst x-button-c-m-left-up (char-to-string 102))
  78.  
  79. (defconst x-button-c-m-s-right (char-to-string 112))
  80. (defconst x-button-c-m-s-middle (char-to-string 113))
  81. (defconst x-button-c-m-s-left (char-to-string 114))
  82.  
  83. (defconst x-button-c-m-s-right-up (char-to-string 116))
  84. (defconst x-button-c-m-s-middle-up (char-to-string 117))
  85. (defconst x-button-c-m-s-left-up (char-to-string 118))
  86.  
  87. (defvar x-process-mouse-hook nil
  88.   "Hook to run after each mouse event is processed.  Should take two
  89. arguments; the first being a list (XPOS YPOS) corresponding to character
  90. offset from top left of screen and the second being a specifier for the
  91. buttons/keys.
  92.  
  93. This will normally be set on a per-buffer basis.")
  94.  
  95. (defun x-flush-mouse-queue () 
  96.   "Process all queued mouse events."
  97.   ;; A mouse event causes a special character sequence to be given
  98.   ;; as keyboard input.  That runs this function, which process all
  99.   ;; queued mouse events and returns.
  100.   (interactive)
  101.   (while (> (x-mouse-events) 0)
  102.     (x-proc-mouse-event)
  103.     (and (boundp 'x-process-mouse-hook)
  104.      (symbol-value 'x-process-mouse-hook)
  105.      (funcall x-process-mouse-hook x-mouse-pos x-mouse-item))))
  106.  
  107. (define-key global-map "\C-c\C-m" 'x-flush-mouse-queue)
  108. (define-key global-map "\C-x\C-@" 'x-flush-mouse-queue)
  109.  
  110. (defun x-mouse-select (arg)
  111.   "Select Emacs window the mouse is on."
  112.   (let ((start-w (selected-window))
  113.     (done nil)
  114.     (w (selected-window))
  115.     (rel-coordinate nil))
  116.     (while (and (not done)
  117.         (null (setq rel-coordinate
  118.                 (coordinates-in-window-p arg w))))
  119.       (setq w (next-window w))
  120.       (if (eq w start-w)
  121.       (setq done t)))
  122.     (select-window w)
  123.     rel-coordinate))
  124.  
  125. (defun x-mouse-keep-one-window (arg)
  126.   "Select Emacs window mouse is on, then kill all other Emacs windows."
  127.   (if (x-mouse-select arg)
  128.       (delete-other-windows)))
  129.  
  130. (defun x-mouse-select-and-split (arg)
  131.   "Select Emacs window mouse is on, then split it vertically in half."
  132.   (if (x-mouse-select arg)
  133.       (split-window-vertically nil)))
  134.  
  135. (defun x-mouse-set-point (arg)
  136.   "Select Emacs window mouse is on, and move point to mouse position."
  137.   (let* ((relative-coordinate (x-mouse-select arg))
  138.      margin-column
  139.      (rel-x (car relative-coordinate))
  140.      (rel-y (car (cdr relative-coordinate))))
  141.     (if relative-coordinate
  142.     (let ((prompt-width (if (eq (selected-window) (minibuffer-window))
  143.                 minibuffer-prompt-width 0)))
  144.       (move-to-window-line rel-y)
  145.       (if (eobp)
  146.           ;; If text ends before the desired line,
  147.           ;; always position at end of that line.
  148.           nil
  149.         (setq margin-column
  150.           (if (or truncate-lines (> (window-hscroll) 0))
  151.               (current-column)
  152.             ;; If we are using line continuation,
  153.             ;; compensate if first character on a continuation line
  154.             ;; does not start precisely at the margin.
  155.             (- (current-column)
  156.                (% (current-column) (1- (window-width))))))
  157.         (move-to-column (+ rel-x (1- (max 1 (window-hscroll)))
  158.                    (if (= (point) 1)
  159.                    (- prompt-width) 0)
  160.                    margin-column)))))))
  161.  
  162. (defun x-mouse-set-mark (arg)
  163.   "Select Emacs window mouse is on, and set mark at mouse position.
  164. Display cursor at that position for a second."
  165.   (if (x-mouse-select arg)
  166.       (let ((point-save (point)))
  167.     (unwind-protect
  168.         (progn (x-mouse-set-point arg)
  169.            (push-mark nil t)
  170.            (sit-for 1))
  171.       (goto-char point-save)))))
  172.  
  173. (defun x-cut-text (arg &optional kill)
  174.   "Copy text between point and mouse position into window system cut buffer.
  175. Save in Emacs kill ring also."
  176.   (if (coordinates-in-window-p arg (selected-window))
  177.       (save-excursion
  178.     (let ((opoint (point))
  179.           beg end)
  180.       (x-mouse-set-point arg)
  181.       (setq beg (min opoint (point))
  182.         end (max opoint (point)))
  183.       (x-store-cut-buffer (buffer-substring beg end))
  184.       (copy-region-as-kill beg end)
  185.       (if kill (delete-region beg end))))
  186.     (message "Mouse not in selected window")))
  187.  
  188. (defun x-paste-text (arg)
  189.   "Move point to mouse position and insert window system cut buffer contents."
  190.   (x-mouse-set-point arg)
  191.   (insert (x-get-cut-buffer)))
  192.  
  193. (defun x-cut-and-wipe-text (arg)
  194.   "Kill text between point and mouse; also copy to window system cut buffer."
  195.   (x-cut-text arg t))
  196.  
  197. (defun x-mouse-ignore (arg)
  198.   "Don't do anything.")
  199.  
  200. (defun x-buffer-menu (arg)
  201.   "Pop up a menu of buffers for selection with the mouse."
  202.   (let ((menu
  203.      (list "Buffer Menu"
  204.            (cons "Select Buffer"
  205.              (let ((tail (buffer-list))
  206.                head)
  207.                (while tail
  208.              (let ((elt (car tail)))
  209.                (if (not (string-match "^ "
  210.                           (buffer-name elt)))
  211.                    (setq head (cons
  212.                        (cons
  213.                         (format
  214.                          "%14s   %s"
  215.                          (buffer-name elt)
  216.                          (or (buffer-file-name elt) ""))
  217.                         elt)
  218.                        head))))
  219.              (setq tail (cdr tail)))
  220.                (reverse head))))))
  221.     (switch-to-buffer (or (x-popup-menu arg menu) (current-buffer)))))
  222.  
  223. (defun x-help (arg)
  224.   "Enter a menu-based help system."
  225.   (let ((selection
  226.      (x-popup-menu
  227.       arg
  228.       '("Help" ("Is there a command that..."
  229.             ("Command apropos" . command-apropos)
  230.             ("Apropos" . apropos))
  231.            ("Key Commands <==> Functions"
  232.             ("List all keystroke commands" . describe-bindings)
  233.             ("Describe key briefly" . describe-key-briefly)
  234.             ("Describe key verbose" . describe-key)
  235.             ("Describe Lisp function" . describe-function)
  236.             ("Where is this command" . where-is))
  237.            ("Manual and tutorial"
  238.             ("Info system" . info)
  239.             ("Invoke Emacs tutorial" . help-with-tutorial))
  240.            ("Odds and ends"
  241.             ("Last 100 Keystrokes" . view-lossage)
  242.             ("Describe syntax table" . describe-syntax))
  243.            ("Modes"
  244.             ("Describe current major mode" . describe-mode)
  245.             ("List all keystroke commands" . describe-bindings))
  246.            ("Administrivia"
  247.             ("View Emacs news" . view-emacs-news)
  248.             ("View the GNU Emacs license" . describe-copying)
  249.             ("Describe distribution" . describe-distribution)
  250.             ("Describe (non)warranty" . describe-no-warranty))))))
  251.     (and selection (call-interactively selection))))
  252.  
  253. ; Prevent beeps on button-up.  If the button isn't bound to anything, it
  254. ; will beep on button-down.
  255. (define-key mouse-map x-button-right-up 'x-mouse-ignore)
  256. (define-key mouse-map x-button-middle-up 'x-mouse-ignore)
  257. (define-key mouse-map x-button-left-up 'x-mouse-ignore)
  258. (define-key mouse-map x-button-s-right-up 'x-mouse-ignore)
  259. (define-key mouse-map x-button-s-middle-up 'x-mouse-ignore)
  260. (define-key mouse-map x-button-s-left-up 'x-mouse-ignore)
  261. (define-key mouse-map x-button-m-right-up 'x-mouse-ignore)
  262. (define-key mouse-map x-button-m-middle-up 'x-mouse-ignore)
  263. (define-key mouse-map x-button-m-left-up 'x-mouse-ignore)
  264. (define-key mouse-map x-button-c-right-up 'x-mouse-ignore)
  265. (define-key mouse-map x-button-c-middle-up 'x-mouse-ignore)
  266. (define-key mouse-map x-button-c-left-up 'x-mouse-ignore)
  267. (define-key mouse-map x-button-m-s-right-up 'x-mouse-ignore)
  268. (define-key mouse-map x-button-m-s-middle-up 'x-mouse-ignore)
  269. (define-key mouse-map x-button-m-s-left-up 'x-mouse-ignore)
  270. (define-key mouse-map x-button-c-s-right-up 'x-mouse-ignore)
  271. (define-key mouse-map x-button-c-s-middle-up 'x-mouse-ignore)
  272. (define-key mouse-map x-button-c-s-left-up 'x-mouse-ignore)
  273. (define-key mouse-map x-button-c-m-right-up 'x-mouse-ignore)
  274. (define-key mouse-map x-button-c-m-middle-up 'x-mouse-ignore)
  275. (define-key mouse-map x-button-c-m-left-up 'x-mouse-ignore)
  276. (define-key mouse-map x-button-c-m-s-right-up 'x-mouse-ignore)
  277. (define-key mouse-map x-button-c-m-s-middle-up 'x-mouse-ignore)
  278. (define-key mouse-map x-button-c-m-s-left-up 'x-mouse-ignore)
  279.  
  280. (define-key mouse-map x-button-c-s-left 'x-buffer-menu)
  281. (define-key mouse-map x-button-c-s-middle 'x-help)
  282. (define-key mouse-map x-button-c-s-right 'x-mouse-keep-one-window)
  283. (define-key mouse-map x-button-s-middle 'x-cut-text)
  284. (define-key mouse-map x-button-s-right 'x-paste-text)
  285. (define-key mouse-map x-button-c-middle 'x-cut-and-wipe-text)
  286. (define-key mouse-map x-button-c-right 'x-mouse-select-and-split)
  287.  
  288. (if (= window-system-version 10)
  289.     (progn
  290.       (define-key mouse-map x-button-right 'x-mouse-select)
  291.       (define-key mouse-map x-button-left 'x-mouse-set-mark)
  292.       (define-key mouse-map x-button-middle 'x-mouse-set-point))
  293.   (define-key mouse-map x-button-right 'x-cut-text)
  294.   (define-key mouse-map x-button-left 'x-mouse-set-point)
  295.   (define-key mouse-map x-button-middle 'x-paste-text))
  296.