home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / x11 / x-mouse.el < prev    next >
Encoding:
Text File  |  1993-02-14  |  7.4 KB  |  201 lines
  1. ;; Mouse support for X window system.
  2. ;; Copyright (C) 1985-1993 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. (provide 'x-mouse)
  21. (require 'mouse)
  22.  
  23. (define-key global-map 'button2 'x-set-point-and-insert-selection)
  24. (define-key global-map '(control button2) 'x-mouse-kill)
  25.  
  26. (defun x-mouse-kill (event)
  27.   "Kill the text between the point and mouse and copy it to the clipboard and
  28. to the cut buffer"
  29.   (interactive "@e")
  30.   (let ((old-point (point)))
  31.     (mouse-set-point event)
  32.     (let ((s (buffer-substring old-point (point))))
  33.       (x-own-clipboard s)
  34.       (x-store-cutbuffer s))
  35.     (kill-region old-point (point))))
  36.  
  37. (defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
  38.   "Insert the current selection into buffer at point."
  39.   (interactive)
  40.   (let ((text (if check-cutbuffer-p
  41.           (or (condition-case () (x-get-selection) (error ()))
  42.               (x-get-cutbuffer)
  43.               (error "No selection or cut buffer available"))
  44.         (x-get-selection))))
  45.     (if move-point-event (mouse-set-point move-point-event))
  46.     (push-mark (point))
  47.     (insert text)
  48. ;;    (if zmacs-regions (zmacs-activate-region))
  49.     ))
  50.  
  51. (defun x-set-point-and-insert-selection (event)
  52.   "Sets point where clicked and insert the primary selection or the cut buffer"
  53.   (interactive "e")
  54.   (x-insert-selection t event))
  55.  
  56. (defun mouse-track-and-copy-to-cutbuffer (event)
  57.   "Makes a selection like `mouse-track', but also copies it to the cutbuffer."
  58.   (interactive "e")
  59.   (mouse-track event)
  60.   (and primary-selection-extent
  61.        (save-excursion
  62.      (set-buffer (extent-buffer primary-selection-extent))
  63.      (x-store-cutbuffer
  64.       (buffer-substring (extent-start-position primary-selection-extent)
  65.                 (extent-end-position primary-selection-extent))))))
  66.  
  67.  
  68. ;;; Pointer shape.
  69. ;;; This code doesn't allow the mouse cursor and mouse color to be per-screen,
  70. ;;; but that wouldn't be hard to do.
  71.  
  72. (defvar x-pointer-shape nil
  73.   "*The shape of the mouse-pointer when over text.
  74.  
  75. This string may be any of the standard cursor names from appendix B 
  76. of the Xlib manual (also known as the file <X11/cursorfont.h>) minus 
  77. the XC_ prefix, or it may be a font name and glyph index of the form 
  78. \"FONT fontname index [[font] index]\", or it may be the name of a
  79. bitmap file acceptable to XmuLocateBitmapFile().  If it is a bitmap
  80. file, and if a bitmap file whose name is the name of the cursor with
  81. \"msk\" exists, then it is used as the mask.  For example, a pair of
  82. files may be named \"cursor.xbm\" and \"cursor.xbmmsk\".")
  83.  
  84. (defvar x-nontext-pointer-shape nil
  85.   "*The shape of the mouse-pointer when over a buffer, but not over text.  
  86. If this is nil, then `x-pointer-shape' is used.")
  87.  
  88. (defvar x-mode-pointer-shape nil
  89.   "*The shape of the mouse-pointer when over the modeline.
  90. If this is nil, then either `x-nontext-pointer-shape' or `x-pointer-shape'
  91. will be used.")
  92.  
  93. (defvar x-selection-pointer-shape nil
  94.   "*The shape of the mouse-pointer when over a selectable text region.")
  95.  
  96. (defvar x-pointer-foreground-color nil
  97.   "*The foreground color of the mouse pointer.")
  98.  
  99. (defvar x-pointer-background-color nil
  100.   "*The background color of the mouse pointer.")
  101.  
  102. (defun x-track-pointer (event)
  103.   (let* ((window (event-window event))
  104.      (screen (if window (window-screen window) (selected-screen)))
  105.      (buffer (and window (window-buffer window)))
  106.      (point (and buffer (event-point event)))
  107.      (extent (and point (extent-at point buffer 'highlight)))
  108.      (var (cond ((and extent x-selection-pointer-shape)
  109.              'x-selection-pointer-shape)
  110.             (point 'x-pointer-shape)
  111.             (buffer
  112.              (cond (x-nontext-pointer-shape 'x-nontext-pointer-shape)
  113.                (x-pointer-shape 'x-pointer-shape)))
  114.             (t (cond (x-mode-pointer-shape 'x-mode-pointer-shape)
  115.                  (x-nontext-pointer-shape 'x-nontext-pointer-shape)
  116.                  (x-pointer-shape 'x-pointer-shape))))))
  117.     (condition-case c
  118.     (if (symbol-value var)
  119.         (x-set-screen-pointer screen (symbol-value var)
  120.                   x-pointer-foreground-color
  121.                   x-pointer-background-color))
  122.       (error
  123.        (x-track-pointer-damage-control c var)))
  124.     (if extent
  125.     (highlight-extent extent t)
  126.       (highlight-extent nil nil))
  127.     (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
  128.     (if buffer
  129.     (save-excursion
  130.       (set-buffer buffer)
  131.       (let ((rest (and (boundp 'mode-motion-hook)
  132.                (symbol-value 'mode-motion-hook))))
  133.         (if (or (not (listp rest))
  134.             (eq (car-safe rest) 'lambda))
  135.         (funcall rest event)
  136.           (while rest
  137.         (funcall rest event)
  138.         (setq rest (cdr rest)))))))
  139.     ))
  140.  
  141. (defun x-track-pointer-damage-control (c var)
  142.   ;; When x-set-screen-pointer signals an error, this function tries to figure
  143.   ;; out why, and undo the damage so that an error isn't signalled every time
  144.   ;; the mouse moves.
  145.   (cond ((string= (nth 1 c) "unknown cursor")
  146.      (set var nil)
  147.      (error "%S was %S, which is an invalid X cursor name.  Reset."
  148.         var (nth 2 c)))
  149.     ((string= (nth 1 c) "unrecognised color")
  150.      (if (not (x-valid-color-name-p x-pointer-foreground-color))
  151.          (setq var 'x-pointer-foreground-color)
  152.        (if (not (x-valid-color-name-p x-pointer-background-color))
  153.            (setq var 'x-pointer-background-color)
  154.          (error "got %S and I don't know why!" c)))
  155.      (set var nil)
  156.      (error "%S was %S, which is an invalid color name.  Reset."
  157.         var (nth 2 c)))
  158.     ((eq (car c) 'wrong-type-argument)
  159.      (let ((rest '(x-pointer-foreground-color x-pointer-background-color
  160.                x-pointer-shape x-nontext-pointer-shape
  161.                x-mode-pointer-shape)))
  162.        (while rest
  163.          (if (and (symbol-value (car rest))
  164.               (not (stringp (symbol-value (car rest)))))
  165.          (progn
  166.            (set (car rest) nil)
  167.            (error "%S was %S, not a string.  Reset." (car rest)
  168.               (nth 2 c))))
  169.          (setq rest (cdr rest)))
  170.        (error "got %S and I don't know why!" c)))
  171.     (t (signal (car c) (cdr c)))))
  172.  
  173.  
  174. (defvar x-pointers-initialized nil)
  175.  
  176. (defun x-initialize-pointer-shape (screen)
  177.   "Initializes the mouse-pointers of the given screen from the resource
  178. database."
  179.   (if x-pointers-initialized  ; only do it when the first screen is created
  180.       nil
  181.     (setq x-pointer-shape
  182.       (or (x-get-resource "textPointer" "Cursor" 'string screen)
  183.           "xterm"))
  184.     (setq x-selection-pointer-shape
  185.       (or (x-get-resource "selectionPointer" "Cursor" 'string screen)
  186.           "top_left_arrow"))
  187.     (setq x-nontext-pointer-shape
  188.       (or (x-get-resource "spacePointer" "Cursor" 'string screen)
  189.           "crosshair"))
  190.     (setq x-mode-pointer-shape
  191.       (or (x-get-resource "modeLinePointer" "Cursor" 'string screen)
  192.           "sb_v_double_arrow"))
  193.     (setq x-gc-pointer-shape
  194.       (or (x-get-resource "gcPointer" "Cursor" 'string screen)
  195.           "watch"))
  196.     (setq x-pointer-foreground-color
  197.       (x-get-resource "pointerColor" "Foreground" 'string screen))
  198.     (setq x-pointer-background-color
  199.       (x-get-resource "pointerBackground" "Background" 'string screen))
  200.     (setq x-pointers-initialized t)))
  201.