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