|
0
|
1 ;; Mouse support for X window system.
|
|
|
2 ;; Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc.
|
|
|
3 ;; Copyright (C) 1995, 1996 Ben Wing.
|
|
|
4
|
|
|
5 ;; This file is part of XEmacs.
|
|
|
6
|
|
|
7 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
8 ;; under the terms of the GNU General Public License as published by
|
|
|
9 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
10 ;; any later version.
|
|
|
11
|
|
|
12 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
15 ;; General Public License for more details.
|
|
|
16
|
|
|
17 ;; You should have received a copy of the GNU General Public License
|
|
70
|
18 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
20 ;; Boston, MA 02111-1307, USA.
|
|
0
|
21
|
|
|
22 ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
|
|
|
23 ;; This is reserved for use by Hyperbole.
|
|
|
24 ;;(define-key global-map '(shift button2) 'x-mouse-kill)
|
|
|
25 (define-key global-map '(control button2) 'x-set-point-and-move-selection)
|
|
|
26
|
|
|
27 (setq mouse-yank-function 'x-yank-function)
|
|
|
28
|
|
|
29 (defun x-mouse-kill (event)
|
|
|
30 "Kill the text between the point and mouse and copy it to the clipboard and
|
|
|
31 to the cut buffer"
|
|
|
32 (interactive "@e")
|
|
|
33 (let ((old-point (point)))
|
|
|
34 (mouse-set-point event)
|
|
|
35 (let ((s (buffer-substring old-point (point))))
|
|
|
36 (x-own-clipboard s)
|
|
|
37 (x-store-cutbuffer s))
|
|
|
38 (kill-region old-point (point))))
|
|
|
39
|
|
|
40 (defun x-yank-function ()
|
|
|
41 "Insert the current X selection or, if there is none, insert the X cutbuffer.
|
|
|
42 A mark is pushed, so that the inserted text lies between point and mark."
|
|
|
43 (push-mark)
|
|
|
44 (if (region-active-p)
|
|
|
45 (if (consp zmacs-region-extent)
|
|
|
46 ;; pirated code from insert-rectangle in rect.el
|
|
|
47 ;; perhaps that code should be modified to handle a list of extents
|
|
|
48 ;; as the rectangle to be inserted?
|
|
|
49 (let ((lines zmacs-region-extent)
|
|
|
50 (insertcolumn (current-column))
|
|
|
51 (first t))
|
|
|
52 (push-mark)
|
|
|
53 (while lines
|
|
|
54 (or first
|
|
|
55 (progn
|
|
|
56 (forward-line 1)
|
|
|
57 (or (bolp) (insert ?\n))
|
|
|
58 (move-to-column insertcolumn t)))
|
|
|
59 (setq first nil)
|
|
|
60 (insert (extent-string (car lines)))
|
|
|
61 (setq lines (cdr lines))))
|
|
|
62 (insert (extent-string zmacs-region-extent)))
|
|
|
63 (x-insert-selection t)))
|
|
|
64
|
|
|
65 (defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
|
|
|
66 "Insert the current selection into buffer at point."
|
|
|
67 (interactive "P")
|
|
|
68 (let ((text (if check-cutbuffer-p
|
|
|
69 (or (condition-case () (x-get-selection) (error ()))
|
|
|
70 (x-get-cutbuffer)
|
|
|
71 (error "No selection or cut buffer available"))
|
|
|
72 (x-get-selection))))
|
|
|
73 (cond (move-point-event
|
|
|
74 (mouse-set-point move-point-event)
|
|
|
75 (push-mark (point)))
|
|
|
76 ((interactive-p)
|
|
|
77 (push-mark (point))))
|
|
|
78 (insert text)
|
|
|
79 ))
|
|
|
80
|
|
|
81 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
|
|
|
82 (defun x-set-point-and-insert-selection (event)
|
|
|
83 "Set point where clicked and insert the primary selection or the cut buffer."
|
|
|
84 (interactive "e")
|
|
|
85 (let ((mouse-yank-at-point nil))
|
|
|
86 (mouse-yank event)))
|
|
|
87
|
|
|
88 (defun x-set-point-and-move-selection (event)
|
|
|
89 "Set point where clicked and move the selected text to that location."
|
|
|
90 (interactive "e")
|
|
|
91 ;; Don't try to move the selection if x-kill-primary-selection if going
|
|
|
92 ;; to fail; just let the appropriate error message get issued. (We need
|
|
|
93 ;; to insert the selection and set point first, or the selection may
|
|
|
94 ;; get inserted at the wrong place.)
|
|
|
95 (and (x-selection-owner-p)
|
|
|
96 primary-selection-extent
|
|
|
97 (x-insert-selection t event))
|
|
|
98 (x-kill-primary-selection))
|
|
|
99
|
|
|
100 (defun mouse-track-and-copy-to-cutbuffer (event)
|
|
|
101 "Make a selection like `mouse-track', but also copy it to the cutbuffer."
|
|
|
102 (interactive "e")
|
|
|
103 (mouse-track event)
|
|
|
104 (cond
|
|
|
105 ((null primary-selection-extent)
|
|
|
106 nil)
|
|
|
107 ((consp primary-selection-extent)
|
|
|
108 (save-excursion
|
|
|
109 (set-buffer (extent-object (car primary-selection-extent)))
|
|
|
110 (x-store-cutbuffer
|
|
|
111 (mapconcat
|
|
|
112 'identity
|
|
|
113 (extract-rectangle
|
|
|
114 (extent-start-position (car primary-selection-extent))
|
|
|
115 (extent-end-position (car (reverse primary-selection-extent))))
|
|
|
116 "\n"))))
|
|
|
117 (t
|
|
|
118 (save-excursion
|
|
|
119 (set-buffer (extent-object primary-selection-extent))
|
|
|
120 (x-store-cutbuffer
|
|
|
121 (buffer-substring (extent-start-position primary-selection-extent)
|
|
|
122 (extent-end-position primary-selection-extent)))))))
|
|
|
123
|
|
|
124
|
|
|
125 (defvar x-pointers-initialized nil)
|
|
|
126
|
|
|
127 (defun x-init-pointer-shape (device)
|
|
|
128 "Initializes the mouse-pointers of the given device from the resource
|
|
|
129 database."
|
|
|
130 (if x-pointers-initialized ; only do it when the first device is created
|
|
|
131 nil
|
|
|
132 (set-glyph-image text-pointer-glyph
|
|
|
133 (or (x-get-resource "textPointer" "Cursor" 'string device)
|
|
|
134 "xterm"))
|
|
|
135 (set-glyph-image selection-pointer-glyph
|
|
|
136 (or (x-get-resource "selectionPointer" "Cursor" 'string device)
|
|
|
137 "top_left_arrow"))
|
|
|
138 (set-glyph-image nontext-pointer-glyph
|
|
|
139 (or (x-get-resource "spacePointer" "Cursor" 'string device)
|
|
|
140 "xterm")) ; was "crosshair"
|
|
|
141 (set-glyph-image modeline-pointer-glyph
|
|
|
142 (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
|
|
|
143 "sb_v_double_arrow"))
|
|
|
144 (set-glyph-image gc-pointer-glyph
|
|
|
145 (or (x-get-resource "gcPointer" "Cursor" 'string device)
|
|
|
146 "watch"))
|
|
78
|
147 (when (featurep 'scrollbar)
|
|
|
148 (set-glyph-image
|
|
|
149 scrollbar-pointer-glyph
|
|
|
150 (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
|
|
|
151 "top_left_arrow")))
|
|
0
|
152 (set-glyph-image busy-pointer-glyph
|
|
|
153 (or (x-get-resource "busyPointer" "Cursor" 'string device)
|
|
|
154 "watch"))
|
|
|
155 (set-glyph-image toolbar-pointer-glyph
|
|
|
156 (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
|
|
|
157 "left_ptr"))
|
|
|
158 (let ((fg
|
|
|
159 (x-get-resource "pointerColor" "Foreground" 'string device)))
|
|
|
160 (and fg
|
|
|
161 (set-face-foreground 'pointer fg)))
|
|
|
162 (let ((bg
|
|
|
163 (x-get-resource "pointerBackground" "Background" 'string device)))
|
|
|
164 (and bg
|
|
|
165 (set-face-background 'pointer bg)))
|
|
|
166 (setq x-pointers-initialized t))
|
|
|
167 nil)
|
|
|
168
|
