Mercurial > emacs
annotate lisp/emacs-lisp/lselect.el @ 69420:337a846a85de
(Creating Strings): Fix Texinfo usage.
author | Luc Teirlinck <teirllm@auburn.edu> |
---|---|
date | Sat, 11 Mar 2006 22:42:14 +0000 |
parents | 067115a6e738 |
children | 0ed577e1fa46 c5406394f567 |
rev | line source |
---|---|
2234 | 1 ;;; lselect.el --- Lucid interface to X Selections |
2 | |
64751
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
3 ;; Copyright (C) 1990, 1993, 2002, 2003, 2004, |
68648
067115a6e738
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
65192
diff
changeset
|
4 ;; 2005, 2006 Free Software Foundation, Inc. |
14169 | 5 |
38961
5b23575286e6
Add the Maintainer keyword. From Pavel Janik.
Eli Zaretskii <eliz@gnu.org>
parents:
38414
diff
changeset
|
6 ;; Maintainer: FSF |
2234 | 7 ;; Keywords: emulations |
8 | |
9 ;; This won't completely work until we support or emulate Lucid-style extents. | |
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 | |
16 ;; the Free Software Foundation; either version 2, or (at your option) | |
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 | |
14169 | 25 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
64085 | 26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
27 ;; Boston, MA 02110-1301, USA. | |
2234 | 28 |
38414
67b464da13ec
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
18383
diff
changeset
|
29 ;;; Commentary: |
67b464da13ec
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
18383
diff
changeset
|
30 |
2234 | 31 ;;; Code: |
32 | |
39565 | 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.) | |
2234 | 36 |
65192
5d442c673b6b
(mouse-highlight-priority, x-lost-selection-functions, zmacs-regions):
Juanma Barranquero <lekktu@gmail.com>
parents:
64751
diff
changeset
|
37 ;; This is Lucid/XEmacs stuff |
5d442c673b6b
(mouse-highlight-priority, x-lost-selection-functions, zmacs-regions):
Juanma Barranquero <lekktu@gmail.com>
parents:
64751
diff
changeset
|
38 (defvar mouse-highlight-priority) |
5d442c673b6b
(mouse-highlight-priority, x-lost-selection-functions, zmacs-regions):
Juanma Barranquero <lekktu@gmail.com>
parents:
64751
diff
changeset
|
39 (defvar x-lost-selection-functions) |
5d442c673b6b
(mouse-highlight-priority, x-lost-selection-functions, zmacs-regions):
Juanma Barranquero <lekktu@gmail.com>
parents:
64751
diff
changeset
|
40 (defvar zmacs-regions) |
5d442c673b6b
(mouse-highlight-priority, x-lost-selection-functions, zmacs-regions):
Juanma Barranquero <lekktu@gmail.com>
parents:
64751
diff
changeset
|
41 |
2571
b65cf676a09b
All fsets changed to defaliases.
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2234
diff
changeset
|
42 (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
|
43 (defalias 'x-store-cutbuffer 'x-set-cut-buffer) |
2234 | 44 |
39565 | 45 (or (facep 'primary-selection) |
2234 | 46 (make-face 'primary-selection)) |
47 | |
39565 | 48 (or (facep 'secondary-selection) |
2234 | 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) | |
64751
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
110 "Make a primary X Selection of the given argument. |
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
111 The argument may be a string, a cons of two markers, or an extent. |
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
112 In the latter cases the selection is considered to be the text |
2234 | 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) | |
64751
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
133 "Make a secondary X Selection of the given argument. The argument may be a |
2234 | 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) | |
57779
d1c1c0fc40aa
Adjust to new names for x-(lost|sent)-selection-functions.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
155 "for use as a value of `x-lost-selection-functions'." |
2234 | 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 | |
57779
d1c1c0fc40aa
Adjust to new names for x-(lost|sent)-selection-functions.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
169 (setq x-lost-selection-functions 'x-dehilight-selection) |
2234 | 170 |
171 (defun x-notice-selection-requests (selection type successful) | |
57779
d1c1c0fc40aa
Adjust to new names for x-(lost|sent)-selection-functions.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
172 "for possible use as the value of `x-sent-selection-functions'." |
2234 | 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) | |
57779
d1c1c0fc40aa
Adjust to new names for x-(lost|sent)-selection-functions.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
179 "for possible use as the value of `x-sent-selection-functions'." |
2234 | 180 (or successful |
181 (message "Selection request failed to convert %s to %s" | |
182 selection type))) | |
183 | |
57779
d1c1c0fc40aa
Adjust to new names for x-(lost|sent)-selection-functions.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
184 ;(setq x-sent-selection-functions 'x-notice-selection-requests) |
d1c1c0fc40aa
Adjust to new names for x-(lost|sent)-selection-functions.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
185 ;(setq x-sent-selection-functions 'x-notice-selection-failures) |
2234 | 186 |
187 | |
39565 | 188 ;; Random utility functions |
2234 | 189 |
190 (defun x-kill-primary-selection () | |
64751
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
191 "If there is a selection, delete the text it covers, and copy it to |
2234 | 192 both the kill ring and the Clipboard." |
193 (interactive) | |
194 (or (x-selection-owner-p) (error "emacs does not own the primary selection")) | |
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) | |
208 (or (x-selection-owner-p) (error "emacs does not own the primary selection")) | |
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) | |
222 (or (x-selection-owner-p) (error "emacs does not own the primary selection")) | |
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 | |
18383 | 239 (provide 'lselect) |
240 | |
57779
d1c1c0fc40aa
Adjust to new names for x-(lost|sent)-selection-functions.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
241 ;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556 |
38414
67b464da13ec
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
18383
diff
changeset
|
242 ;;; lselect.el ends here |