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