;; Mouse support for X window system.
;; Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs 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.
;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(eval-when-compile
;; these used to be defsubsts, now they're subrs. Avoid losing if we're
;; being compiled with an emacs that has the old interpretation.
;; (Warning, proclaim-notinline was broken prior to 19.10.)
(remprop 'facep 'byte-optimizer)
(remprop 'face-name 'byte-optimizer)
(remprop 'face-id 'byte-optimizer)
(remprop 'face-font 'byte-optimizer)
(remprop 'face-foreground 'byte-optimizer)
(remprop 'face-background 'byte-optimizer)
(remprop 'face-background-pixmap 'byte-optimizer)
(remprop 'face-underline-p 'byte-optimizer)
(remprop 'face-font-name 'byte-optimizer)
(remprop 'set-face-font 'byte-optimizer)
(remprop 'set-face-foreground 'byte-optimizer)
(remprop 'set-face-background 'byte-optimizer)
(remprop 'set-face-background-pixmap 'byte-optimizer)
(remprop 'set-face-underline-p 'byte-optimizer)
)
(require 'mouse)
(define-key global-map 'button2 'x-set-point-and-insert-selection)
(define-key global-map '(control button2) 'x-mouse-kill)
(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-insert-selection (&optional check-cutbuffer-p move-point-event)
"Insert the current selection into buffer at point."
(interactive)
(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))))
(if move-point-event (mouse-set-point move-point-event))
(push-mark (point))
(insert text)
;; (if zmacs-regions (zmacs-activate-region))
))
(defun x-set-point-and-insert-selection (event)
"Sets point where clicked and insert the primary selection or the cut buffer"
(interactive "e")
(x-insert-selection t event))
(defun mouse-track-and-copy-to-cutbuffer (event)
"Makes a selection like `mouse-track', but also copies 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-screen,
;;; but that wouldn't be hard to do.
(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-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 screen)
;; both must be specified, or neither
(or (eq (null fg) (null bg))
(setq fg (or fg (pixel-name (face-foreground 'default screen)))
bg (or bg (pixel-name (face-background 'default screen)))))
(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 screen)
(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 screen))
x-pointer-cache))
(setq pointer (cdr (car x-pointer-cache)))
(if (setq tail (nthcdr 10 x-pointer-cache))
(setcdr tail nil))))
pointer))
(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* ((window (event-window event))
(screen (if window
(window-screen window)
(or (event-screen event)
(selected-screen))))
(buffer (and window (window-buffer window)))
(point (and buffer (event-point event)))
(extent (and point (extent-at point buffer 'highlight)))
(glyph (event-glyph event))
(var (cond ((and extent x-selection-pointer-shape)
'x-selection-pointer-shape)
(glyph 'x-selection-pointer-shape)
(point 'x-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
screen))
(x-set-screen-pointer screen pointer))
(error
(x-track-pointer-damage-control c var)))
(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
screen)
pointer))
(x-set-scrollbar-pointer screen scrollbar-pointer))
(error
(x-track-pointer-damage-control c 'x-scrollbar-pointer-shape)))
(if extent
(highlight-extent extent t)
(highlight-extent nil nil))
(if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
(if buffer
(save-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
(window-buffer window) ; not buffer
'highlight)))
(highlight-extent extent t)))))
nil)
(defun x-track-pointer-damage-control (c var)
;; When x-set-screen-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 (x-valid-color-name-p x-pointer-foreground-color))
(setq var 'x-pointer-foreground-color)
(if (not (x-valid-color-name-p x-pointer-background-color))
(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 window-system 'x))
(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-screen)))
(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)
(setq gc-message (buffer-string)))
(kill-buffer b))))))
(add-hook 'pre-gc-hook 'x-set-pointer-for-gc)
(defvar x-pointers-initialized nil)
(defun x-initialize-pointer-shape (screen)
"Initializes the mouse-pointers of the given screen from the resource
database."
(if x-pointers-initialized ; only do it when the first screen is created
nil
(setq x-pointer-shape
(or (x-get-resource "textPointer" "Cursor" 'string screen)
"xterm"))
(setq x-selection-pointer-shape
(or (x-get-resource "selectionPointer" "Cursor" 'string screen)
"top_left_arrow"))
(setq x-nontext-pointer-shape
(or (x-get-resource "spacePointer" "Cursor" 'string screen)
"crosshair"))
(setq x-mode-pointer-shape
(or (x-get-resource "modeLinePointer" "Cursor" 'string screen)
"sb_v_double_arrow"))
(setq x-gc-pointer-shape
(or (x-get-resource "gcPointer" "Cursor" 'string screen)
"watch"))
(setq x-scrollbar-pointer-shape
(or (x-get-resource "scrollbarPointer" "Cursor" 'string screen)
"top_left_arrow"))
(setq x-pointer-foreground-color
(x-get-resource "pointerColor" "Foreground" 'string screen))
(setq x-pointer-background-color
(x-get-resource "pointerBackground" "Background" 'string screen))
(setq x-pointers-initialized t))
nil)
(provide 'x-mouse)