Mercurial > hg > xemacs-beta

comparison lisp/x-mouse.el @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children abe6d1db359e
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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 (define-obsolete-function-alias 'x-insert-selection 'insert-selection)
40
41 (defun x-mouse-kill (event)
42 "Kill the text between the point and mouse and copy it to the clipboard and
43 to the cut buffer"
44 (interactive "@e")
45 (let ((old-point (point)))
46 (mouse-set-point event)
47 (let ((s (buffer-substring old-point (point))))
48 (own-clipboard s)
49 (x-store-cutbuffer s))
50 (kill-region old-point (point))))
51
52 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
53 (defun x-set-point-and-insert-selection (event)
54 "Set point where clicked and insert the primary selection or the cut buffer."
55 (interactive "e")
56 (let ((mouse-yank-at-point nil))
57 (mouse-yank event)))
58
59 (defun x-set-point-and-move-selection (event)
60 "Set point where clicked and move the selected text to that location."
61 (interactive "e")
62 ;; Don't try to move the selection if x-kill-primary-selection if going
63 ;; to fail; just let the appropriate error message get issued. (We need
64 ;; to insert the selection and set point first, or the selection may
65 ;; get inserted at the wrong place.)
66 (and (selection-owner-p)
67 primary-selection-extent
68 (insert-selection t event))
69 (kill-primary-selection))
70
71 (defun mouse-track-and-copy-to-cutbuffer (event)
72 "Make a selection like `mouse-track', but also copy it to the cutbuffer."
73 (interactive "e")
74 (mouse-track event)
75 (cond
76 ((null primary-selection-extent)
77 nil)
78 ((consp primary-selection-extent)
79 (save-excursion
80 (set-buffer (extent-object (car primary-selection-extent)))
81 (x-store-cutbuffer
82 (mapconcat
83 #'identity
84 (extract-rectangle
85 (extent-start-position (car primary-selection-extent))
86 (extent-end-position (car (reverse primary-selection-extent))))
87 "\n"))))
88 (t
89 (save-excursion
90 (set-buffer (extent-object primary-selection-extent))
91 (x-store-cutbuffer
92 (buffer-substring (extent-start-position primary-selection-extent)
93 (extent-end-position primary-selection-extent)))))))
94
95
96 (defvar x-pointers-initialized nil)
97
98 (defun x-init-pointer-shape (device)
99 "Initialize the mouse-pointers of DEVICE from the X resource database."
100 (if x-pointers-initialized ; only do it when the first device is created
101 nil
102 (set-glyph-image text-pointer-glyph
103 (or (x-get-resource "textPointer" "Cursor" 'string device)
104 "xterm"))
105 (set-glyph-image selection-pointer-glyph
106 (or (x-get-resource "selectionPointer" "Cursor" 'string device)
107 "top_left_arrow"))
108 (set-glyph-image nontext-pointer-glyph
109 (or (x-get-resource "spacePointer" "Cursor" 'string device)
110 "xterm")) ; was "crosshair"
111 (set-glyph-image modeline-pointer-glyph
112 (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
113 ;; "fleur"))
114 "sb_v_double_arrow"))
115 (set-glyph-image gc-pointer-glyph
116 (or (x-get-resource "gcPointer" "Cursor" 'string device)
117 "watch"))
118 (when (featurep 'scrollbar)
119 (set-glyph-image
120 scrollbar-pointer-glyph
121 (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
122 "top_left_arrow")))
123 (set-glyph-image busy-pointer-glyph
124 (or (x-get-resource "busyPointer" "Cursor" 'string device)
125 "watch"))
126 (set-glyph-image toolbar-pointer-glyph
127 (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
128 "left_ptr"))
129 (set-glyph-image divider-pointer-glyph
130 (or (x-get-resource "dividerPointer" "Cursor" 'string device)
131 "sb_h_double_arrow"))
132 (let ((fg
133 (x-get-resource "pointerColor" "Foreground" 'string device)))
134 (and fg
135 (set-face-foreground 'pointer fg)))
136 (let ((bg
137 (x-get-resource "pointerBackground" "Background" 'string device)))
138 (and bg
139 (set-face-background 'pointer bg)))
140 (setq x-pointers-initialized t))
141 nil)
142
143 ;;; x-mouse.el ends here