1 ;;; lselect.el --- Lucid interface to X Selections
3 ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
5 ;; Keywords: emulations
7 ;; This won't completely work until we support or emulate Lucid-style extents.
8 ;; Based on Lucid's selection code.
10 ;; This file is part of GNU Emacs.
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)
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.
22 ;; You should have received a copy of the GNU General Public License
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.
31 ;;; The selection code requires us to use certain symbols whose names are
32 ;;; all upper-case; this may seem tasteless, but it makes there be a 1:1
33 ;;; correspondence between these symbols and X Atoms (which are upcased.)
35 (defalias 'x-get-cutbuffer
'x-get-cut-buffer
)
36 (defalias 'x-store-cutbuffer
'x-set-cut-buffer
)
38 (or (find-face 'primary-selection
)
39 (make-face 'primary-selection
))
41 (or (find-face 'secondary-selection
)
42 (make-face 'secondary-selection
))
44 (defun x-get-secondary-selection ()
45 "Return text selected from some X window."
46 (x-get-selection-internal 'SECONDARY
'STRING
))
48 (defvar primary-selection-extent nil
49 "The extent of the primary selection; don't use this.")
51 (defvar secondary-selection-extent nil
52 "The extent of the secondary selection; don't use this.")
55 (defun x-select-make-extent-for-selection (selection previous-extent face
)
56 ;; Given a selection, this makes an extent in the buffer which holds that
57 ;; selection, for highlighting purposes. If the selection isn't associated
58 ;; with a buffer, this does nothing.
60 (valid (and (extentp previous-extent
)
61 (extent-buffer previous-extent
)
62 (buffer-name (extent-buffer previous-extent
))))
64 (cond ((stringp selection
)
65 ;; if we're selecting a string, lose the previous extent used
66 ;; to highlight the selection.
69 (setq start
(min (car selection
) (cdr selection
))
70 end
(max (car selection
) (cdr selection
))
72 (eq (marker-buffer (car selection
))
73 (extent-buffer previous-extent
)))
74 buffer
(marker-buffer (car selection
))))
76 (setq start
(extent-start-position selection
)
77 end
(extent-end-position selection
)
79 (eq (extent-buffer selection
)
80 (extent-buffer previous-extent
)))
81 buffer
(extent-buffer selection
)))
84 (extentp previous-extent
)
85 (extent-buffer previous-extent
)
86 (buffer-name (extent-buffer previous-extent
)))
87 (delete-extent previous-extent
))
93 (set-extent-endpoints previous-extent start end
)
94 (setq previous-extent
(make-extent start end buffer
))
95 ;; use same priority as mouse-highlighting so that conflicts between
96 ;; the selection extent and a mouse-highlighted extent are resolved
97 ;; by the usual size-and-endpoint-comparison method.
98 (set-extent-priority previous-extent mouse-highlight-priority
)
99 (set-extent-face previous-extent face
)))))
102 (defun x-own-selection (selection &optional type
)
103 "Make a primary X Selection of the given argument.
104 The argument may be a string, a cons of two markers, or an extent.
105 In the latter cases the selection is considered to be the text
106 between the markers, or the between extents endpoints."
107 (interactive (if (not current-prefix-arg
)
108 (list (read-string "Store text for pasting: "))
109 (list (cons ;; these need not be ordered.
110 (copy-marker (point-marker))
111 (copy-marker (mark-marker))))))
112 (or type
(setq type
'PRIMARY
))
113 (x-set-selection selection type
)
114 (cond ((eq type
'PRIMARY
)
115 (setq primary-selection-extent
116 (x-select-make-extent-for-selection
117 selection primary-selection-extent
'primary-selection
)))
118 ((eq type
'SECONDARY
)
119 (setq secondary-selection-extent
120 (x-select-make-extent-for-selection
121 selection secondary-selection-extent
'secondary-selection
))))
125 (defun x-own-secondary-selection (selection &optional type
)
126 "Make a secondary X Selection of the given argument. The argument may be a
127 string or a cons of two markers (in which case the selection is considered to
128 be the text between those markers.)"
129 (interactive (if (not current-prefix-arg
)
130 (list (read-string "Store text for pasting: "))
131 (list (cons ;; these need not be ordered.
132 (copy-marker (point-marker))
133 (copy-marker (mark-marker))))))
134 (x-own-selection selection
'SECONDARY
))
137 (defun x-own-clipboard (string)
138 "Paste the given string to the X Clipboard."
139 (x-own-selection string
'CLIPBOARD
))
142 (defun x-disown-selection (&optional secondary-p
)
143 "Assuming we own the selection, disown it. With an argument, discard the
144 secondary selection instead of the primary selection."
145 (x-disown-selection-internal (if secondary-p
'SECONDARY
'PRIMARY
)))
147 (defun x-dehilight-selection (selection)
148 "for use as a value of x-lost-selection-hooks."
149 (cond ((eq selection
'PRIMARY
)
150 (if primary-selection-extent
151 (let ((inhibit-quit t
))
152 (delete-extent primary-selection-extent
)
153 (setq primary-selection-extent nil
)))
154 (if zmacs-regions
(zmacs-deactivate-region)))
155 ((eq selection
'SECONDARY
)
156 (if secondary-selection-extent
157 (let ((inhibit-quit t
))
158 (delete-extent secondary-selection-extent
)
159 (setq secondary-selection-extent nil
)))))
162 (setq x-lost-selection-hooks
'x-dehilight-selection
)
164 (defun x-notice-selection-requests (selection type successful
)
165 "for possible use as the value of x-sent-selection-hooks."
167 (message "Selection request failed to convert %s to %s"
169 (message "Sent selection %s as %s" selection type
)))
171 (defun x-notice-selection-failures (selection type successful
)
172 "for possible use as the value of x-sent-selection-hooks."
174 (message "Selection request failed to convert %s to %s"
177 ;(setq x-sent-selection-hooks 'x-notice-selection-requests)
178 ;(setq x-sent-selection-hooks 'x-notice-selection-failures)
181 ;;; Random utility functions
183 (defun x-kill-primary-selection ()
184 "If there is a selection, delete the text it covers, and copy it to
185 both the kill ring and the Clipboard."
187 (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
188 (setq last-command nil
)
189 (or primary-selection-extent
190 (error "the primary selection is not an extent?"))
192 (set-buffer (extent-buffer primary-selection-extent
))
193 (kill-region (extent-start-position primary-selection-extent
)
194 (extent-end-position primary-selection-extent
)))
195 (x-disown-selection nil
))
197 (defun x-delete-primary-selection ()
198 "If there is a selection, delete the text it covers *without* copying it to
199 the kill ring or the Clipboard."
201 (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
202 (setq last-command nil
)
203 (or primary-selection-extent
204 (error "the primary selection is not an extent?"))
206 (set-buffer (extent-buffer primary-selection-extent
))
207 (delete-region (extent-start-position primary-selection-extent
)
208 (extent-end-position primary-selection-extent
)))
209 (x-disown-selection nil
))
211 (defun x-copy-primary-selection ()
212 "If there is a selection, copy it to both the kill ring and the Clipboard."
214 (setq last-command nil
)
215 (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
216 (or primary-selection-extent
217 (error "the primary selection is not an extent?"))
219 (set-buffer (extent-buffer primary-selection-extent
))
220 (copy-region-as-kill (extent-start-position primary-selection-extent
)
221 (extent-end-position primary-selection-extent
))))
223 (defun x-yank-clipboard-selection ()
224 "If someone owns a Clipboard selection, insert it at point."
226 (setq last-command nil
)
227 (let ((clip (x-get-clipboard)))
228 (or clip
(error "there is no clipboard selection"))
234 ;;; lselect.el ends here