home *** CD-ROM | disk | FTP | other *** search
- ;; Mouse support for X window system.
- ;; Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc.
-
- ;; This file is part of XEmacs.
-
- ;; XEmacs is free software; you can redistribute it and/or modify it
- ;; under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation; either version 2, or (at your option)
- ;; any later version.
-
- ;; XEmacs is distributed in the hope that it will be useful, but
- ;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;; General Public License for more details.
-
- ;; You should have received a copy of the GNU General Public License
- ;; along with XEmacs; see the file COPYING. If not, write to the Free
- ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
- (require 'mouse)
-
- ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
- ;; This is reserved for use by Hyperbole.
- ;;(define-key global-map '(shift button2) 'x-mouse-kill)
- (define-key global-map '(control button2) 'x-set-point-and-move-selection)
-
- (setq mouse-yank-function 'x-yank-function)
-
- (defvar inhibit-help-echo nil
- "Inhibits display of `help-echo' extent properties in the minibuffer.")
-
- (defun x-mouse-kill (event)
- "Kill the text between the point and mouse and copy it to the clipboard and
- to the cut buffer"
- (interactive "@e")
- (let ((old-point (point)))
- (mouse-set-point event)
- (let ((s (buffer-substring old-point (point))))
- (x-own-clipboard s)
- (x-store-cutbuffer s))
- (kill-region old-point (point))))
-
- (defun x-yank-function ()
- "Insert the current X selection or, if there is none, insert the X cutbuffer.
- A mark is pushed, so that the inserted text lies between point and mark."
- (push-mark)
- (if (region-active-p)
- (insert (extent-string zmacs-region-extent))
- (x-insert-selection t)))
-
- (defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
- "Insert the current selection into buffer at point."
- (interactive "P")
- (let ((text (if check-cutbuffer-p
- (or (condition-case () (x-get-selection) (error ()))
- (x-get-cutbuffer)
- (error "No selection or cut buffer available"))
- (x-get-selection))))
- (cond (move-point-event
- (mouse-set-point move-point-event)
- (push-mark (point)))
- ((interactive-p)
- (push-mark (point))))
- (insert text)
- ))
-
- (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
- (defun x-set-point-and-insert-selection (event)
- "Set point where clicked and insert the primary selection or the cut buffer."
- (interactive "e")
- (let ((mouse-yank-at-point nil))
- (mouse-yank event)))
-
- (defun x-set-point-and-move-selection (event)
- "Set point where clicked and move the selected text to that location."
- (interactive "e")
- ;; Don't try to move the selection if x-kill-primary-selection if going
- ;; to fail; just let the appropriate error message get issued. (We need
- ;; to insert the selection and set point first, or the selection may
- ;; get inserted at the wrong place.)
- (and (x-selection-owner-p)
- primary-selection-extent
- (x-insert-selection t event))
- (x-kill-primary-selection))
-
- (defun mouse-track-and-copy-to-cutbuffer (event)
- "Make a selection like `mouse-track', but also copy it to the cutbuffer."
- (interactive "e")
- (mouse-track event)
- (cond
- ((null primary-selection-extent)
- nil)
- ((consp primary-selection-extent)
- (save-excursion
- (set-buffer (extent-buffer (car primary-selection-extent)))
- (x-store-cutbuffer
- (mapconcat
- 'identity
- (extract-rectangle
- (extent-start-position (car primary-selection-extent))
- (extent-end-position (car (reverse primary-selection-extent))))
- "\n"))))
- (t
- (save-excursion
- (set-buffer (extent-buffer primary-selection-extent))
- (x-store-cutbuffer
- (buffer-substring (extent-start-position primary-selection-extent)
- (extent-end-position primary-selection-extent)))))))
-
-
- ;;; Pointer shape.
- ;;; This code doesn't allow the mouse cursor and mouse color to be per-frame,
- ;;; but that wouldn't be hard to do.
-
- ;;; #### Should also allow for a cursor object here.
-
- (defvar x-pointer-shape nil
- "*The shape of the mouse-pointer when over text.
-
- This string may be any of the standard cursor names from appendix B
- of the Xlib manual (also known as the file <X11/cursorfont.h>) minus
- the XC_ prefix, or it may be a font name and glyph index of the form
- \"FONT fontname index [[font] index]\", or it may be the name of a
- bitmap file acceptable to XmuLocateBitmapFile(). If it is a bitmap
- file, and if a bitmap file whose name is the name of the cursor with
- \"msk\" exists, then it is used as the mask. For example, a pair of
- files may be named \"cursor.xbm\" and \"cursor.xbmmsk\".")
-
- (defvar x-nontext-pointer-shape nil
- "*The shape of the mouse-pointer when over a buffer, but not over text.
- If this is nil, then `x-pointer-shape' is used.")
-
- (defvar x-mode-pointer-shape nil
- "*The shape of the mouse-pointer when over the modeline.
- If this is nil, then either `x-nontext-pointer-shape' or `x-pointer-shape'
- will be used.")
-
- (defvar x-selection-pointer-shape nil
- "*The shape of the mouse-pointer when over a selectable text region.")
-
- (defvar x-busy-pointer-shape nil
- "*The shape of the mouse-pointer when Emacs is busy.")
-
- (defvar x-toolbar-pointer-shape nil
- "*The shape of the mouse-pointer when over a toolbar.")
-
- (defvar x-pointer-foreground-color nil
- "*The foreground color of the mouse pointer.")
-
- (defvar x-pointer-background-color nil
- "*The background color of the mouse pointer.")
-
- (defvar x-pointer-cache nil)
- (defvar x-pointer-cache-key (make-vector 4 nil))
-
- (defun x-pointer-cache (name fg bg device)
- ;; both must be specified, or neither
- (or (eq (null fg) (null bg))
- (setq fg (or fg
- (color-instance-name (face-foreground 'default device)))
- bg (or bg
- (color-instance-name (face-background 'default device)))))
- (aset x-pointer-cache-key 0 name)
- (aset x-pointer-cache-key 1 fg)
- (aset x-pointer-cache-key 2 bg)
- (aset x-pointer-cache-key 3 device)
- (let (pointer)
- (or (setq pointer (cdr (assoc x-pointer-cache-key x-pointer-cache)))
- (let (tail)
- (setq x-pointer-cache
- (cons (cons (copy-sequence x-pointer-cache-key)
- (make-cursor name fg bg device))
- x-pointer-cache))
- (setq pointer (cdr (car x-pointer-cache)))
- (if (setq tail (nthcdr 10 x-pointer-cache))
- (setcdr tail nil))))
- pointer))
-
- (defvar last-help-echo-object nil)
- (defvar help-echo-owns-message nil)
-
- (defun clear-help-echo (&optional ignored-frame)
- (if help-echo-owns-message
- (progn
- (setq help-echo-owns-message nil
- last-help-echo-object nil)
- (clear-message 'help-echo))))
-
- (defun show-help-echo (mess)
- ;; (clear-help-echo)
- (setq help-echo-owns-message t)
- (display-message 'help-echo mess))
-
- (add-hook 'mouse-leave-frame-hook 'clear-help-echo)
-
- (defun x-track-pointer (event)
- "For use as the value of `mouse-motion-handler'.
- This implements `x-pointer-shape' and related variables,
- as well as extent highlighting, and `mode-motion-hook'."
- (let* ((frame (or (event-frame event) (selected-frame)))
- (device (frame-device frame))
- (buffer (event-buffer event))
- (point (and buffer (event-point event)))
- (extent (and point (extent-at point buffer 'highlight)))
- (glyph (event-glyph-extent event))
- (button (event-toolbar-button event))
- (help (or (and glyph (extent-property glyph 'help-echo) glyph)
- (and button (not (null (toolbar-button-help-string button)))
- button)
- (and point
- (condition-case nil
- (extent-at point buffer 'help-echo)
- (error nil)))))
- (var (cond ((and extent x-selection-pointer-shape)
- 'x-selection-pointer-shape)
- ;; Checking if button is non-nil is not sufficent
- ;; since the pointer could be over a blank portion
- ;; of the toolbar.
- ((event-over-toolbar-p event) 'x-toolbar-pointer-shape)
- (glyph 'x-selection-pointer-shape)
- (point 'x-pointer-shape)
- ((event-over-modeline-p event) 'x-mode-pointer-shape)
- (buffer
- (cond (x-nontext-pointer-shape 'x-nontext-pointer-shape)
- (x-pointer-shape 'x-pointer-shape)))
- (t (cond (x-mode-pointer-shape 'x-mode-pointer-shape)
- (x-nontext-pointer-shape 'x-nontext-pointer-shape)
- (x-pointer-shape 'x-pointer-shape)))))
- pointer scrollbar-pointer)
- (condition-case c
- (progn
- (setq pointer (x-pointer-cache (symbol-value var)
- x-pointer-foreground-color
- x-pointer-background-color
- device))
- (x-set-frame-pointer frame pointer))
- (error
- (x-track-pointer-damage-control c var device)))
- (condition-case c
- (progn
- (setq scrollbar-pointer
- (if x-scrollbar-pointer-shape
- (x-pointer-cache x-scrollbar-pointer-shape
- x-pointer-foreground-color
- x-pointer-background-color
- device)
- pointer))
- (x-set-scrollbar-pointer frame scrollbar-pointer))
- (error
- (x-track-pointer-damage-control c 'x-scrollbar-pointer-shape device)))
-
- ;; If last-pressed-toolbar-button is not nil, then check and see
- ;; if we have moved to a new button and adjust the down flags
- ;; accordingly.
- (if toolbar-active
- (if (not (eq last-pressed-toolbar-button button))
- (progn
- (release-previous-toolbar-button event)
- (and button (press-toolbar-button event)))))
-
- (cond (extent (highlight-extent extent t))
- (glyph (highlight-extent glyph t))
- (t (highlight-extent nil nil)))
- (cond ((extentp help)
- (or inhibit-help-echo
- (eq help last-help-echo-object) ;save some time
- (let ((hprop (extent-property help 'help-echo)))
- (setq last-help-echo-object help)
- (or (stringp hprop)
- (setq hprop (funcall hprop help)))
- (and hprop (show-help-echo hprop)))))
- ((and (toolbar-button-p help) (toolbar-button-enabled-p help))
- (or (not toolbar-help-enabled)
- (eq help last-help-echo-object) ;save some time
- (let ((hstring (toolbar-button-help-string button)))
- (setq last-help-echo-object help)
- (or (stringp hstring)
- (setq hstring (funcall hstring help)))
- (show-help-echo hstring))))
- (last-help-echo-object
- (clear-help-echo)))
- (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
- (if buffer
- (save-window-excursion
- (set-buffer buffer)
- (run-hook-with-args 'mode-motion-hook event)
-
- ;; If the mode-motion-hook created a highlightable extent around
- ;; the mouse-point, highlight it right away. Otherwise it wouldn't
- ;; be highlighted until the *next* motion event came in.
- (if (and point
- (null extent)
- (setq extent (extent-at point
- (event-buffer event) ; not buffer
- 'highlight)))
- (highlight-extent extent t)))))
- nil)
-
- (defun x-track-pointer-damage-control (c var device)
- ;; When x-set-frame-pointer signals an error, this function tries to figure
- ;; out why, and undo the damage so that an error isn't signalled every time
- ;; the mouse moves.
- (cond ((and (stringp (nth 1 c))
- (or (string= (nth 1 c) "unknown cursor")
- (string-match "xpm\\|XPM\\|pixmap\\|bitmap" (nth 1 c))))
- (set var nil)
- (error "%S was %S, which is an invalid X cursor name. Reset."
- var (nth 2 c)))
- ((string= (nth 1 c) "unrecognised color")
- (if (not (valid-color-name-p x-pointer-foreground-color device))
- (setq var 'x-pointer-foreground-color)
- (if (not (valid-color-name-p x-pointer-background-color device))
- (setq var 'x-pointer-background-color)
- (error "got %S and I don't know why!" c)))
- (set var nil)
- (error "%S was %S, which was an invalid color name. Reset."
- var (nth 2 c)))
- ((string= (nth 1 c) "couldn't allocate color")
- (cond ((string= (nth 2 c) x-pointer-foreground-color)
- (setq var 'x-pointer-foreground-color))
- ((string= (nth 2 c) x-pointer-background-color)
- (setq var 'x-pointer-background-color))
- (t (error "got %S and I don't know why!" c)))
- (set var nil)
- (error "%S was %S, which cannot be allocated. Reset."
- var (nth 2 c)))
- ((eq (car c) 'wrong-type-argument)
- (let ((rest '(x-pointer-foreground-color x-pointer-background-color
- x-pointer-shape x-nontext-pointer-shape
- x-mode-pointer-shape x-scrollbar-pointer-shape)))
- (while rest
- (if (and (symbol-value (car rest))
- (not (stringp (symbol-value (car rest)))))
- (progn
- (set (car rest) nil)
- (error "%S was %S, not a string. Reset." (car rest)
- (nth 2 c))))
- (setq rest (cdr rest)))
- (error "got %S and I don't know why!" c)))
- (t (signal (car c) (cdr c)))))
-
-
- ;;; GC pointer shape
-
- ;; For the mystified out there, the GC pointer is stored in the variable
- ;; `gc-message', which is defined in alloc.c. If the value of this is
- ;; a cursor, the function x_show_gc_cursor(), defined in xfns.c, is called
- ;; at the beginning of garbage collection.
-
- (defun x-set-pointer-for-gc ()
- (if (or (not (eq 'x (device-type (selected-device))))
- (null x-gc-pointer-shape))
- (setq gc-message nil)
- ;; else
- (condition-case error
- (setq gc-message (x-pointer-cache x-gc-pointer-shape
- x-pointer-foreground-color
- x-pointer-background-color
- (selected-device)))
- (error
- ;; This conses a little bit but not much. Should be ok.
- (setq gc-message nil)
- (let ((b (get-buffer-create " *gc-pointer-error*")))
- (save-excursion
- (set-buffer b)
- (erase-buffer)
- (insert "Garbage collecting... ERROR setting GC pointer: ")
- (display-error error b)
- (display-warning 'pointer (buffer-string)))
- (kill-buffer b))))))
-
- (add-hook 'pre-gc-hook 'x-set-pointer-for-gc)
-
-
- (defvar x-pointers-initialized nil)
-
- (defun x-init-pointer-shape (device)
- "Initializes the mouse-pointers of the given device from the resource
- database."
- ;; #### nyet nyet nyet! Need to extend cursors and x-pointer-shape
- ;; to be device-specific.
- (if x-pointers-initialized ; only do it when the first device is created
- nil
- (setq x-pointer-shape
- (or (x-get-resource "textPointer" "Cursor" 'string device)
- "xterm"))
- (setq x-selection-pointer-shape
- (or (x-get-resource "selectionPointer" "Cursor" 'string device)
- "top_left_arrow"))
- (setq x-nontext-pointer-shape
- (or (x-get-resource "spacePointer" "Cursor" 'string device)
- "xterm")) ; was "crosshair"
- (setq x-mode-pointer-shape
- (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
- "sb_v_double_arrow"))
- (setq x-gc-pointer-shape
- (or (x-get-resource "gcPointer" "Cursor" 'string device)
- "watch"))
- (setq x-scrollbar-pointer-shape
- (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
- "top_left_arrow"))
- (setq x-busy-pointer-shape
- (or (x-get-resource "busyPointer" "Cursor" 'string device)
- "watch"))
- (setq x-toolbar-pointer-shape
- (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
- "left_ptr"))
- (setq x-pointer-foreground-color
- (x-get-resource "pointerColor" "Foreground" 'string device))
- (setq x-pointer-background-color
- (x-get-resource "pointerBackground" "Background" 'string device))
- (setq x-pointers-initialized t))
- nil)
-