|
2234
|
1 ;;; lselect.el --- Lucid interface to X Selections
|
|
|
2
|
|
14169
|
3 ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
|
|
|
4
|
|
2234
|
5 ;; Keywords: emulations
|
|
|
6
|
|
|
7 ;; This won't completely work until we support or emulate Lucid-style extents.
|
|
|
8 ;; Based on Lucid's selection code.
|
|
|
9
|
|
|
10 ;; This file is part of GNU Emacs.
|
|
|
11
|
|
|
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
13 ;; it under the terms of the GNU General Public License as published by
|
|
|
14 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
15 ;; any later version.
|
|
|
16
|
|
|
17 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
20 ;; GNU General Public License for more details.
|
|
|
21
|
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
14169
|
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
25 ;; Boston, MA 02111-1307, USA.
|
|
2234
|
26
|
|
|
27 ;;; Code:
|
|
|
28
|
|
|
29 ;;; The selection code requires us to use certain symbols whose names are
|
|
|
30 ;;; all upper-case; this may seem tasteless, but it makes there be a 1:1
|
|
|
31 ;;; correspondence between these symbols and X Atoms (which are upcased.)
|
|
|
32
|
|
2571
|
33 (defalias 'x-get-cutbuffer 'x-get-cut-buffer)
|
|
|
34 (defalias 'x-store-cutbuffer 'x-set-cut-buffer)
|
|
2234
|
35
|
|
|
36 (or (find-face 'primary-selection)
|
|
|
37 (make-face 'primary-selection))
|
|
|
38
|
|
|
39 (or (find-face 'secondary-selection)
|
|
|
40 (make-face 'secondary-selection))
|
|
|
41
|
|
|
42 (defun x-get-secondary-selection ()
|
|
|
43 "Return text selected from some X window."
|
|
|
44 (x-get-selection-internal 'SECONDARY 'STRING))
|
|
|
45
|
|
|
46 (defvar primary-selection-extent nil
|
|
|
47 "The extent of the primary selection; don't use this.")
|
|
|
48
|
|
|
49 (defvar secondary-selection-extent nil
|
|
|
50 "The extent of the secondary selection; don't use this.")
|
|
|
51
|
|
|
52
|
|
|
53 (defun x-select-make-extent-for-selection (selection previous-extent face)
|
|
|
54 ;; Given a selection, this makes an extent in the buffer which holds that
|
|
|
55 ;; selection, for highlighting purposes. If the selection isn't associated
|
|
|
56 ;; with a buffer, this does nothing.
|
|
|
57 (let ((buffer nil)
|
|
|
58 (valid (and (extentp previous-extent)
|
|
|
59 (extent-buffer previous-extent)
|
|
|
60 (buffer-name (extent-buffer previous-extent))))
|
|
|
61 start end)
|
|
|
62 (cond ((stringp selection)
|
|
|
63 ;; if we're selecting a string, lose the previous extent used
|
|
|
64 ;; to highlight the selection.
|
|
|
65 (setq valid nil))
|
|
|
66 ((consp selection)
|
|
|
67 (setq start (min (car selection) (cdr selection))
|
|
|
68 end (max (car selection) (cdr selection))
|
|
|
69 valid (and valid
|
|
|
70 (eq (marker-buffer (car selection))
|
|
|
71 (extent-buffer previous-extent)))
|
|
|
72 buffer (marker-buffer (car selection))))
|
|
|
73 ((extentp selection)
|
|
|
74 (setq start (extent-start-position selection)
|
|
|
75 end (extent-end-position selection)
|
|
|
76 valid (and valid
|
|
|
77 (eq (extent-buffer selection)
|
|
|
78 (extent-buffer previous-extent)))
|
|
|
79 buffer (extent-buffer selection)))
|
|
|
80 )
|
|
|
81 (if (and (not valid)
|
|
|
82 (extentp previous-extent)
|
|
|
83 (extent-buffer previous-extent)
|
|
|
84 (buffer-name (extent-buffer previous-extent)))
|
|
|
85 (delete-extent previous-extent))
|
|
|
86 (if (not buffer)
|
|
|
87 ;; string case
|
|
|
88 nil
|
|
|
89 ;; normal case
|
|
|
90 (if valid
|
|
|
91 (set-extent-endpoints previous-extent start end)
|
|
|
92 (setq previous-extent (make-extent start end buffer))
|
|
|
93 ;; use same priority as mouse-highlighting so that conflicts between
|
|
|
94 ;; the selection extent and a mouse-highlighted extent are resolved
|
|
|
95 ;; by the usual size-and-endpoint-comparison method.
|
|
|
96 (set-extent-priority previous-extent mouse-highlight-priority)
|
|
|
97 (set-extent-face previous-extent face)))))
|
|
|
98
|
|
|
99
|
|
|
100 (defun x-own-selection (selection &optional type)
|
|
|
101 "Make a primary X Selection of the given argument.
|
|
|
102 The argument may be a string, a cons of two markers, or an extent.
|
|
|
103 In the latter cases the selection is considered to be the text
|
|
|
104 between the markers, or the between extents endpoints."
|
|
|
105 (interactive (if (not current-prefix-arg)
|
|
|
106 (list (read-string "Store text for pasting: "))
|
|
|
107 (list (cons ;; these need not be ordered.
|
|
|
108 (copy-marker (point-marker))
|
|
|
109 (copy-marker (mark-marker))))))
|
|
|
110 (or type (setq type 'PRIMARY))
|
|
|
111 (x-set-selection selection type)
|
|
|
112 (cond ((eq type 'PRIMARY)
|
|
|
113 (setq primary-selection-extent
|
|
|
114 (x-select-make-extent-for-selection
|
|
|
115 selection primary-selection-extent 'primary-selection)))
|
|
|
116 ((eq type 'SECONDARY)
|
|
|
117 (setq secondary-selection-extent
|
|
|
118 (x-select-make-extent-for-selection
|
|
|
119 selection secondary-selection-extent 'secondary-selection))))
|
|
|
120 selection)
|
|
|
121
|
|
|
122
|
|
|
123 (defun x-own-secondary-selection (selection &optional type)
|
|
|
124 "Make a secondary X Selection of the given argument. The argument may be a
|
|
|
125 string or a cons of two markers (in which case the selection is considered to
|
|
|
126 be the text between those markers.)"
|
|
|
127 (interactive (if (not current-prefix-arg)
|
|
|
128 (list (read-string "Store text for pasting: "))
|
|
|
129 (list (cons ;; these need not be ordered.
|
|
|
130 (copy-marker (point-marker))
|
|
|
131 (copy-marker (mark-marker))))))
|
|
|
132 (x-own-selection selection 'SECONDARY))
|
|
|
133
|
|
|
134
|
|
|
135 (defun x-own-clipboard (string)
|
|
|
136 "Paste the given string to the X Clipboard."
|
|
|
137 (x-own-selection string 'CLIPBOARD))
|
|
|
138
|
|
|
139
|
|
|
140 (defun x-disown-selection (&optional secondary-p)
|
|
|
141 "Assuming we own the selection, disown it. With an argument, discard the
|
|
|
142 secondary selection instead of the primary selection."
|
|
|
143 (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
|
|
|
144
|
|
|
145 (defun x-dehilight-selection (selection)
|
|
|
146 "for use as a value of x-lost-selection-hooks."
|
|
|
147 (cond ((eq selection 'PRIMARY)
|
|
|
148 (if primary-selection-extent
|
|
|
149 (let ((inhibit-quit t))
|
|
|
150 (delete-extent primary-selection-extent)
|
|
|
151 (setq primary-selection-extent nil)))
|
|
|
152 (if zmacs-regions (zmacs-deactivate-region)))
|
|
|
153 ((eq selection 'SECONDARY)
|
|
|
154 (if secondary-selection-extent
|
|
|
155 (let ((inhibit-quit t))
|
|
|
156 (delete-extent secondary-selection-extent)
|
|
|
157 (setq secondary-selection-extent nil)))))
|
|
|
158 nil)
|
|
|
159
|
|
|
160 (setq x-lost-selection-hooks 'x-dehilight-selection)
|
|
|
161
|
|
|
162 (defun x-notice-selection-requests (selection type successful)
|
|
|
163 "for possible use as the value of x-sent-selection-hooks."
|
|
|
164 (if (not successful)
|
|
|
165 (message "Selection request failed to convert %s to %s"
|
|
|
166 selection type)
|
|
|
167 (message "Sent selection %s as %s" selection type)))
|
|
|
168
|
|
|
169 (defun x-notice-selection-failures (selection type successful)
|
|
|
170 "for possible use as the value of x-sent-selection-hooks."
|
|
|
171 (or successful
|
|
|
172 (message "Selection request failed to convert %s to %s"
|
|
|
173 selection type)))
|
|
|
174
|
|
|
175 ;(setq x-sent-selection-hooks 'x-notice-selection-requests)
|
|
|
176 ;(setq x-sent-selection-hooks 'x-notice-selection-failures)
|
|
|
177
|
|
|
178
|
|
|
179 ;;; Random utility functions
|
|
|
180
|
|
|
181 (defun x-kill-primary-selection ()
|
|
|
182 "If there is a selection, delete the text it covers, and copy it to
|
|
|
183 both the kill ring and the Clipboard."
|
|
|
184 (interactive)
|
|
|
185 (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
|
|
|
186 (setq last-command nil)
|
|
|
187 (or primary-selection-extent
|
|
|
188 (error "the primary selection is not an extent?"))
|
|
|
189 (save-excursion
|
|
|
190 (set-buffer (extent-buffer primary-selection-extent))
|
|
|
191 (kill-region (extent-start-position primary-selection-extent)
|
|
|
192 (extent-end-position primary-selection-extent)))
|
|
|
193 (x-disown-selection nil))
|
|
|
194
|
|
|
195 (defun x-delete-primary-selection ()
|
|
|
196 "If there is a selection, delete the text it covers *without* copying it to
|
|
|
197 the kill ring or the Clipboard."
|
|
|
198 (interactive)
|
|
|
199 (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
|
|
|
200 (setq last-command nil)
|
|
|
201 (or primary-selection-extent
|
|
|
202 (error "the primary selection is not an extent?"))
|
|
|
203 (save-excursion
|
|
|
204 (set-buffer (extent-buffer primary-selection-extent))
|
|
|
205 (delete-region (extent-start-position primary-selection-extent)
|
|
|
206 (extent-end-position primary-selection-extent)))
|
|
|
207 (x-disown-selection nil))
|
|
|
208
|
|
|
209 (defun x-copy-primary-selection ()
|
|
|
210 "If there is a selection, copy it to both the kill ring and the Clipboard."
|
|
|
211 (interactive)
|
|
|
212 (setq last-command nil)
|
|
|
213 (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
|
|
|
214 (or primary-selection-extent
|
|
|
215 (error "the primary selection is not an extent?"))
|
|
|
216 (save-excursion
|
|
|
217 (set-buffer (extent-buffer primary-selection-extent))
|
|
|
218 (copy-region-as-kill (extent-start-position primary-selection-extent)
|
|
|
219 (extent-end-position primary-selection-extent))))
|
|
|
220
|
|
|
221 (defun x-yank-clipboard-selection ()
|
|
|
222 "If someone owns a Clipboard selection, insert it at point."
|
|
|
223 (interactive)
|
|
|
224 (setq last-command nil)
|
|
|
225 (let ((clip (x-get-clipboard)))
|
|
|
226 (or clip (error "there is no clipboard selection"))
|
|
|
227 (push-mark)
|
|
|
228 (insert clip)))
|
|
|
229
|
|
18383
|
230 (provide 'lselect)
|
|
|
231
|
|
2234
|
232 ;;; lselect.el ends here.
|
