Mercurial > hg > xemacs-beta

comparison lisp/x-mouse.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children da8ed4261e83
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
34 ;;(define-key global-map 'button2 'x-set-point-and-insert-selection) 34 ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
35 ;; This is reserved for use by Hyperbole. 35 ;; This is reserved for use by Hyperbole.
36 ;;(define-key global-map '(shift button2) 'x-mouse-kill) 36 ;;(define-key global-map '(shift button2) 'x-mouse-kill)
37 (define-key global-map '(control button2) 'x-set-point-and-move-selection) 37 (define-key global-map '(control button2) 'x-set-point-and-move-selection)
38 38
39 (define-obsolete-function-alias 'x-insert-selection 'insert-selection)
40
41 (defun x-mouse-kill (event) 39 (defun x-mouse-kill (event)
42 "Kill the text between the point and mouse and copy it to the clipboard and 40 "Kill the text between the point and mouse and copy it to the clipboard and
43 to the cut buffer" 41 to the cut buffer"
44 (interactive "@e") 42 (interactive "@e")
45 (let ((old-point (point))) 43 (let ((old-point (point)))
46 (mouse-set-point event) 44 (mouse-set-point event)
47 (let ((s (buffer-substring old-point (point)))) 45 (let ((s (buffer-substring old-point (point))))
48 (own-clipboard s) 46 (x-own-clipboard s)
49 (x-store-cutbuffer s)) 47 (x-store-cutbuffer s))
50 (kill-region old-point (point)))) 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 ))
51 90
52 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank) 91 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
53 (defun x-set-point-and-insert-selection (event) 92 (defun x-set-point-and-insert-selection (event)
54 "Set point where clicked and insert the primary selection or the cut buffer." 93 "Set point where clicked and insert the primary selection or the cut buffer."
55 (interactive "e") 94 (interactive "e")
61 (interactive "e") 100 (interactive "e")
62 ;; Don't try to move the selection if x-kill-primary-selection if going 101 ;; 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 102 ;; 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 103 ;; to insert the selection and set point first, or the selection may
65 ;; get inserted at the wrong place.) 104 ;; get inserted at the wrong place.)
66 (and (selection-owner-p) 105 (and (x-selection-owner-p)
67 primary-selection-extent 106 primary-selection-extent
68 (insert-selection t event)) 107 (x-insert-selection t event))
69 (kill-primary-selection)) 108 (kill-primary-selection))
70 109
71 (defun mouse-track-and-copy-to-cutbuffer (event) 110 (defun mouse-track-and-copy-to-cutbuffer (event)
72 "Make a selection like `mouse-track', but also copy it to the cutbuffer." 111 "Make a selection like `mouse-track', but also copy it to the cutbuffer."
73 (interactive "e") 112 (interactive "e")
98 (defun x-init-pointer-shape (device) 137 (defun x-init-pointer-shape (device)
99 "Initialize the mouse-pointers of DEVICE from the X resource database." 138 "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 139 (if x-pointers-initialized ; only do it when the first device is created
101 nil 140 nil
102 (set-glyph-image text-pointer-glyph 141 (set-glyph-image text-pointer-glyph
103 (or (x-get-resource "textPointer" "Cursor" 'string device nil 'warn) 142 (or (x-get-resource "textPointer" "Cursor" 'string device)
104 "xterm")) 143 "xterm"))
105 (set-glyph-image selection-pointer-glyph 144 (set-glyph-image selection-pointer-glyph
106 (or (x-get-resource "selectionPointer" "Cursor" 'string device 145 (or (x-get-resource "selectionPointer" "Cursor" 'string device)
107 nil 'warn)
108 "top_left_arrow")) 146 "top_left_arrow"))
109 (set-glyph-image nontext-pointer-glyph 147 (set-glyph-image nontext-pointer-glyph
110 (or (x-get-resource "spacePointer" "Cursor" 'string device nil 'warn) 148 (or (x-get-resource "spacePointer" "Cursor" 'string device)
111 "xterm")) ; was "crosshair" 149 "xterm")) ; was "crosshair"
112 (set-glyph-image modeline-pointer-glyph 150 (set-glyph-image modeline-pointer-glyph
113 (or (x-get-resource "modeLinePointer" "Cursor" 'string device 151 (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
114 nil 'warn)
115 ;; "fleur")) 152 ;; "fleur"))
116 "sb_v_double_arrow")) 153 "sb_v_double_arrow"))
117 (set-glyph-image gc-pointer-glyph 154 (set-glyph-image gc-pointer-glyph
118 (or (x-get-resource "gcPointer" "Cursor" 'string device nil 'warn) 155 (or (x-get-resource "gcPointer" "Cursor" 'string device)
119 "watch")) 156 "watch"))
120 (when (featurep 'scrollbar) 157 (when (featurep 'scrollbar)
121 (set-glyph-image 158 (set-glyph-image
122 scrollbar-pointer-glyph 159 scrollbar-pointer-glyph
123 (or (x-get-resource "scrollbarPointer" "Cursor" 'string device 160 (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
124 nil 'warn)
125 "top_left_arrow"))) 161 "top_left_arrow")))
126 (set-glyph-image busy-pointer-glyph 162 (set-glyph-image busy-pointer-glyph
127 (or (x-get-resource "busyPointer" "Cursor" 'string device nil 'warn) 163 (or (x-get-resource "busyPointer" "Cursor" 'string device)
128 "watch")) 164 "watch"))
129 (set-glyph-image toolbar-pointer-glyph 165 (set-glyph-image toolbar-pointer-glyph
130 (or (x-get-resource "toolBarPointer" "Cursor" 'string device 166 (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
131 nil 'warn)
132 "left_ptr")) 167 "left_ptr"))
133 (set-glyph-image divider-pointer-glyph 168 (set-glyph-image divider-pointer-glyph
134 (or (x-get-resource "dividerPointer" "Cursor" 'string device 169 (or (x-get-resource "dividerPointer" "Cursor" 'string device)
135 nil 'warn)
136 "sb_h_double_arrow")) 170 "sb_h_double_arrow"))
137 (let ((fg 171 (let ((fg
138 (x-get-resource "pointerColor" "Foreground" 'string device 172 (x-get-resource "pointerColor" "Foreground" 'string device)))
139 nil 'warn)))
140 (and fg 173 (and fg
141 (set-face-foreground 'pointer fg))) 174 (set-face-foreground 'pointer fg)))
142 (let ((bg 175 (let ((bg
143 (x-get-resource "pointerBackground" "Background" 'string device 176 (x-get-resource "pointerBackground" "Background" 'string device)))
144 nil 'warn)))
145 (and bg 177 (and bg
146 (set-face-background 'pointer bg))) 178 (set-face-background 'pointer bg)))
147 (setq x-pointers-initialized t)) 179 (setq x-pointers-initialized t))
148 nil) 180 nil)
149 181