Mercurial > hg > xemacs-beta

comparison lisp/x-mouse.el @ 209:41ff10fd062f r20-4b3

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