Mercurial > hg > xemacs-beta

comparison lisp/x11/x-mouse.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children bcdc7deadc19
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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
18 ;; along with XEmacs; see the file COPYING. If not, write to the Free
19 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
22 ;; This is reserved for use by Hyperbole.
23 ;;(define-key global-map '(shift button2) 'x-mouse-kill)
24 (define-key global-map '(control button2) 'x-set-point-and-move-selection)
25
26 (setq mouse-yank-function 'x-yank-function)
27
28 (defun x-mouse-kill (event)
29 "Kill the text between the point and mouse and copy it to the clipboard and
30 to the cut buffer"
31 (interactive "@e")
32 (let ((old-point (point)))
33 (mouse-set-point event)
34 (let ((s (buffer-substring old-point (point))))
35 (x-own-clipboard s)
36 (x-store-cutbuffer s))
37 (kill-region old-point (point))))
38
39 (defun x-yank-function ()
40 "Insert the current X selection or, if there is none, insert the X cutbuffer.
41 A mark is pushed, so that the inserted text lies between point and mark."
42 (push-mark)
43 (if (region-active-p)
44 (if (consp zmacs-region-extent)
45 ;; pirated code from insert-rectangle in rect.el
46 ;; perhaps that code should be modified to handle a list of extents
47 ;; as the rectangle to be inserted?
48 (let ((lines zmacs-region-extent)
49 (insertcolumn (current-column))
50 (first t))
51 (push-mark)
52 (while lines
53 (or first
54 (progn
55 (forward-line 1)
56 (or (bolp) (insert ?\n))
57 (move-to-column insertcolumn t)))
58 (setq first nil)
59 (insert (extent-string (car lines)))
60 (setq lines (cdr lines))))
61 (insert (extent-string zmacs-region-extent)))
62 (x-insert-selection t)))
63
64 (defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
65 "Insert the current selection into buffer at point."
66 (interactive "P")
67 (let ((text (if check-cutbuffer-p
68 (or (condition-case () (x-get-selection) (error ()))
69 (x-get-cutbuffer)
70 (error "No selection or cut buffer available"))
71 (x-get-selection))))
72 (cond (move-point-event
73 (mouse-set-point move-point-event)
74 (push-mark (point)))
75 ((interactive-p)
76 (push-mark (point))))
77 (insert text)
78 ))
79
80 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
81 (defun x-set-point-and-insert-selection (event)
82 "Set point where clicked and insert the primary selection or the cut buffer."
83 (interactive "e")
84 (let ((mouse-yank-at-point nil))
85 (mouse-yank event)))
86
87 (defun x-set-point-and-move-selection (event)
88 "Set point where clicked and move the selected text to that location."
89 (interactive "e")
90 ;; Don't try to move the selection if x-kill-primary-selection if going
91 ;; to fail; just let the appropriate error message get issued. (We need
92 ;; to insert the selection and set point first, or the selection may
93 ;; get inserted at the wrong place.)
94 (and (x-selection-owner-p)
95 primary-selection-extent
96 (x-insert-selection t event))
97 (x-kill-primary-selection))
98
99 (defun mouse-track-and-copy-to-cutbuffer (event)
100 "Make a selection like `mouse-track', but also copy it to the cutbuffer."
101 (interactive "e")
102 (mouse-track event)
103 (cond
104 ((null primary-selection-extent)
105 nil)
106 ((consp primary-selection-extent)
107 (save-excursion
108 (set-buffer (extent-object (car primary-selection-extent)))
109 (x-store-cutbuffer
110 (mapconcat
111 'identity
112 (extract-rectangle
113 (extent-start-position (car primary-selection-extent))
114 (extent-end-position (car (reverse primary-selection-extent))))
115 "\n"))))
116 (t
117 (save-excursion
118 (set-buffer (extent-object primary-selection-extent))
119 (x-store-cutbuffer
120 (buffer-substring (extent-start-position primary-selection-extent)
121 (extent-end-position primary-selection-extent)))))))
122
123
124 (defvar x-pointers-initialized nil)
125
126 (defun x-init-pointer-shape (device)
127 "Initializes the mouse-pointers of the given device from the resource
128 database."
129 (if x-pointers-initialized ; only do it when the first device is created
130 nil
131 (set-glyph-image text-pointer-glyph
132 (or (x-get-resource "textPointer" "Cursor" 'string device)
133 "xterm"))
134 (set-glyph-image selection-pointer-glyph
135 (or (x-get-resource "selectionPointer" "Cursor" 'string device)
136 "top_left_arrow"))
137 (set-glyph-image nontext-pointer-glyph
138 (or (x-get-resource "spacePointer" "Cursor" 'string device)
139 "xterm")) ; was "crosshair"
140 (set-glyph-image modeline-pointer-glyph
141 (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
142 "sb_v_double_arrow"))
143 (set-glyph-image gc-pointer-glyph
144 (or (x-get-resource "gcPointer" "Cursor" 'string device)
145 "watch"))
146 (set-glyph-image scrollbar-pointer-glyph
147 (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
148 "top_left_arrow"))
149 (set-glyph-image busy-pointer-glyph
150 (or (x-get-resource "busyPointer" "Cursor" 'string device)
151 "watch"))
152 (set-glyph-image toolbar-pointer-glyph
153 (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
154 "left_ptr"))
155 (let ((fg
156 (x-get-resource "pointerColor" "Foreground" 'string device)))
157 (and fg
158 (set-face-foreground 'pointer fg)))
159 (let ((bg
160 (x-get-resource "pointerBackground" "Background" 'string device)))
161 (and bg
162 (set-face-background 'pointer bg)))
163 (setq x-pointers-initialized t))
164 nil)
165