Mercurial > hg > xemacs-beta

comparison lisp/x11/x-select.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 131b0175ea99
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;; x-select.el --- Elisp interface to X Selections.
2 ;; Copyright (C) 1990 Free Software Foundation, Inc.
3 ;; Copyright (C) 1995 Sun Microsystems.
4
5 ;; This file is part of XEmacs.
6
7 ;; XEmacs is free software; you can redistribute it and/or modify it
8 ;; under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 2, or (at your option)
10 ;; any later version.
11
12 ;; XEmacs is distributed in the hope that it will be useful, but
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;; General Public License for more details.
16
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with XEmacs; see the file COPYING. If not, write to the Free
19 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 ;;; The selection code requires us to use certain symbols whose names are
22 ;;; all upper-case; this may seem tasteless, but it makes there be a 1:1
23 ;;; correspondence between these symbols and X Atoms (which are upcased).
24
25 ;;; Synched up with: FSF 19.30 (select.el).
26
27 ;;; Code:
28
29 (defvar x-selected-text-type 'STRING
30 "The type atom used to obtain selections from the X server.")
31
32 (defun x-get-selection (&optional type data-type)
33 "Return the value of an X Windows selection.
34 The argument TYPE (default `PRIMARY') says which selection,
35 and the argument DATA-TYPE (default `STRING') says how to convert the data."
36 (or type (setq type 'PRIMARY))
37 (or data-type (setq data-type x-selected-text-type))
38 (let ((text (x-get-selection-internal type data-type)))
39 (if (and (consp text) (symbolp (car text)))
40 (setq text (cdr text)))
41 (if (not (stringp text))
42 (error "Selection is not a string: %S" text)
43 text)))
44
45 (defun x-get-secondary-selection ()
46 "Return text selected from some X window."
47 (x-get-selection 'SECONDARY))
48
49 (defun x-get-clipboard ()
50 "Return text pasted to the clipboard."
51 (x-get-selection 'CLIPBOARD))
52
53
54 (defvar primary-selection-extent nil
55 "The extent of the primary selection; don't use this.")
56
57 (defvar secondary-selection-extent nil
58 "The extent of the secondary selection; don't use this.")
59
60
61 (defun x-select-make-extent-for-selection (selection previous-extent)
62 ;; Given a selection, this makes an extent in the buffer which holds that
63 ;; selection, for highlighting purposes. If the selection isn't associated
64 ;; with a buffer, this does nothing.
65 (let ((buffer nil)
66 (valid (and (extentp previous-extent)
67 (extent-object previous-extent)
68 (buffer-live-p (extent-object previous-extent))))
69 start end)
70 (cond ((stringp selection)
71 ;; if we're selecting a string, lose the previous extent used
72 ;; to highlight the selection.
73 (setq valid nil))
74 ((consp selection)
75 (setq start (min (car selection) (cdr selection))
76 end (max (car selection) (cdr selection))
77 valid (and valid
78 (eq (marker-buffer (car selection))
79 (extent-object previous-extent)))
80 buffer (marker-buffer (car selection))))
81 ((extentp selection)
82 (setq start (extent-start-position selection)
83 end (extent-end-position selection)
84 valid (and valid
85 (eq (extent-object selection)
86 (extent-object previous-extent)))
87 buffer (extent-object selection)))
88 (t
89 (signal 'error (list "invalid selection" selection))))
90
91 (if valid
92 nil
93 (condition-case ()
94 (if (listp previous-extent)
95 (mapcar 'delete-extent previous-extent)
96 (delete-extent previous-extent))
97 (error nil)))
98
99 (if (not buffer)
100 ;; string case
101 nil
102 ;; normal case
103 (if valid
104 (set-extent-endpoints previous-extent start end)
105 (setq previous-extent (make-extent start end buffer))
106
107 ;; Make the extent be closed on the right, which means that if
108 ;; characters are inserted exactly at the end of the extent, the
109 ;; extent will grow to cover them. This is important for shell
110 ;; buffers - suppose one makes a selection, and one end is at
111 ;; point-max. If the shell produces output, that marker will remain
112 ;; at point-max (its position will increase). So it's important that
113 ;; the extent exhibit the same behavior, lest the region covered by
114 ;; the extent (the visual indication), and the region between point
115 ;; and mark (the actual selection value) become different!
116 (set-extent-property previous-extent 'end-open nil)
117
118 (cond
119 (mouse-track-rectangle-p
120 (setq previous-extent (list previous-extent))
121 (default-mouse-track-next-move-rect start end previous-extent)
122 ))
123 previous-extent))))
124
125 ;; FSFmacs calls this `x-set-selection', and reverses the
126 ;; arguments (duh ...). This order is more logical.
127 (defun x-own-selection (data &optional type)
128 "Make an X Windows selection of type TYPE and value DATA.
129 The argument TYPE (default `PRIMARY') says which selection,
130 and DATA specifies the contents. DATA may be a string,
131 a symbol, an integer (or a cons of two integers or list of two integers).
132
133 The selection may also be a cons of two markers pointing to the same buffer,
134 or an overlay. In these cases, the selection is considered to be the text
135 between the markers *at whatever time the selection is examined*.
136 Thus, editing done in the buffer after you specify the selection
137 can alter the effective value of the selection.
138
139 The data may also be a vector of valid non-vector selection values.
140
141 Interactively, the text of the region is used as the selection value."
142 (interactive (if (not current-prefix-arg)
143 (list (read-string "Store text for pasting: "))
144 (list (substring (region-beginning) (region-end)))))
145 ;FSFmacs huh?? It says:
146 ;; "This is for temporary compatibility with pre-release Emacs 19."
147 ;(if (stringp type)
148 ; (setq type (intern type)))
149 (or (x-valid-simple-selection-p data)
150 (and (vectorp data)
151 (let ((valid t)
152 (i (1- (length data))))
153 (while (>= i 0)
154 (or (x-valid-simple-selection-p (aref data i))
155 (setq valid nil))
156 (setq i (1- i)))
157 valid))
158 (signal 'error (list "invalid selection" data)))
159 (or type (setq type 'PRIMARY))
160 (if data
161 (x-own-selection-internal type data)
162 (x-disown-selection-internal type))
163 (cond ((eq type 'PRIMARY)
164 (setq primary-selection-extent
165 (x-select-make-extent-for-selection
166 data primary-selection-extent)))
167 ((eq type 'SECONDARY)
168 (setq secondary-selection-extent
169 (x-select-make-extent-for-selection
170 data secondary-selection-extent))))
171 (setq zmacs-region-stays t)
172 data)
173
174 (defun x-valid-simple-selection-p (data)
175 (or (stringp data)
176 ;FSFmacs huh?? (symbolp data)
177 (integerp data)
178 (and (consp data)
179 (integerp (car data))
180 (or (integerp (cdr data))
181 (and (consp (cdr data))
182 (integerp (car (cdr data))))))
183 (extentp data)
184 (and (consp data)
185 (markerp (car data))
186 (markerp (cdr data))
187 (marker-buffer (car data))
188 (marker-buffer (cdr data))
189 (eq (marker-buffer (car data))
190 (marker-buffer (cdr data)))
191 (buffer-live-p (marker-buffer (car data)))
192 (buffer-live-p (marker-buffer (cdr data))))))
193
194 (defun x-own-secondary-selection (selection &optional type)
195 "Make a secondary X Selection of the given argument. The argument may be a
196 string or a cons of two markers (in which case the selection is considered to
197 be the text between those markers)."
198 (interactive (if (not current-prefix-arg)
199 (list (read-string "Store text for pasting: "))
200 (list (cons ;; these need not be ordered.
201 (copy-marker (point-marker))
202 (copy-marker (mark-marker))))))
203 (x-own-selection selection 'SECONDARY))
204
205
206 (defun x-own-clipboard (string)
207 "Paste the given string to the X Clipboard."
208 (x-own-selection string 'CLIPBOARD))
209
210
211 (defun x-disown-selection (&optional secondary-p)
212 "Assuming we own the selection, disown it. With an argument, discard the
213 secondary selection instead of the primary selection."
214 (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
215
216 (defun x-dehilight-selection (selection)
217 "for use as a value of `x-lost-selection-hooks'."
218 (cond ((eq selection 'PRIMARY)
219 (if primary-selection-extent
220 (let ((inhibit-quit t))
221 (if (consp primary-selection-extent)
222 (mapcar 'delete-extent primary-selection-extent)
223 (delete-extent primary-selection-extent))
224 (setq primary-selection-extent nil)))
225 (if zmacs-regions (zmacs-deactivate-region)))
226 ((eq selection 'SECONDARY)
227 (if secondary-selection-extent
228 (let ((inhibit-quit t))
229 (if (consp secondary-selection-extent)
230 (mapcar 'delete-extent secondary-selection-extent)
231 (delete-extent secondary-selection-extent))
232 (setq secondary-selection-extent nil)))))
233 nil)
234
235 (setq x-lost-selection-hooks 'x-dehilight-selection)
236
237 (defun x-notice-selection-requests (selection type successful)
238 "for possible use as the value of x-sent-selection-hooks."
239 (if (not successful)
240 (message "Selection request failed to convert %s to %s"
241 selection type)
242 (message "Sent selection %s as %s" selection type)))
243
244 (defun x-notice-selection-failures (selection type successful)
245 "for possible use as the value of x-sent-selection-hooks."
246 (or successful
247 (message "Selection request failed to convert %s to %s"
248 selection type)))
249
250 ;(setq x-sent-selection-hooks 'x-notice-selection-requests)
251 ;(setq x-sent-selection-hooks 'x-notice-selection-failures)
252
253
254 ;;; Selections in killed buffers
255 ;;; this function is called by kill-buffer as if it were on the
256 ;;; kill-buffer-hook (though it isn't really).
257
258 (defun xselect-kill-buffer-hook ()
259 ;; Probably the right thing is to write a C function to return a list
260 ;; of the selections which emacs owns, since it could concievably own
261 ;; a user-defined selection type that we've never heard of.
262 (xselect-kill-buffer-hook-1 'PRIMARY)
263 (xselect-kill-buffer-hook-1 'SECONDARY)
264 (xselect-kill-buffer-hook-1 'CLIPBOARD))
265
266 (defun xselect-kill-buffer-hook-1 (selection)
267 (let (value)
268 (if (and (x-selection-owner-p selection)
269 (setq value (x-get-selection-internal selection '_EMACS_INTERNAL))
270 ;; The _EMACS_INTERNAL selection type has a converter registered
271 ;; for it that does no translation. This only works if emacs is
272 ;; requesting the selection from itself. We could have done this
273 ;; by writing a C function to return the raw selection data, and
274 ;; that might be the right way to do this, but this was easy.
275 (or (and (consp value)
276 (markerp (car value))
277 (eq (current-buffer) (marker-buffer (car value))))
278 (and (extent-live-p value)
279 (eq (current-buffer) (extent-object value)))
280 (and (extentp value) (not (extent-live-p value)))))
281 (x-disown-selection-internal selection))))
282
283
284 ;;; Cut Buffer support
285
286 ;;; FSF name x-get-cut-buffer
287 (defun x-get-cutbuffer (&optional which-one)
288 "Returns the value of one of the 8 X server cut buffers. Optional arg
289 WHICH-ONE should be a number from 0 to 7, defaulting to 0.
290 Cut buffers are considered obsolete\; you should use selections instead.
291 This function does nothing if support for cut buffers was not compiled
292 into Emacs."
293 (and (fboundp 'x-get-cutbuffer-internal)
294 (x-get-cutbuffer-internal
295 (if which-one
296 (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
297 CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
298 which-one)
299 'CUT_BUFFER0))))
300
301 ;;; FSF name x-set-cut-buffer
302 (defun x-store-cutbuffer (string &optional push)
303 "Store STRING into the X server's primary cut buffer.
304 If PUSH is non-nil, also rotate the cut buffers:
305 this means the previous value of the primary cut buffer moves the second
306 cut buffer, and the second to the third, and so on (there are 8 buffers.)
307 Cut buffers are considered obsolete; you should use selections instead.
308 This function does nothing if support for cut buffers was not compiled
309 into Emacs."
310 (and (fboundp 'x-store-cutbuffer-internal)
311 (progn
312 ;; Check the data type of STRING.
313 (substring string 0 0)
314 (if push
315 (x-rotate-cutbuffers-internal 1))
316 (x-store-cutbuffer-internal 'CUT_BUFFER0 string))))
317
318
319 ;;; Random utility functions
320
321 (defun x-cut-copy-clear-internal (mode)
322 (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
323 (or (x-selection-owner-p)
324 (error "emacs does not own the primary selection"))
325 (setq last-command nil)
326 (or primary-selection-extent
327 (error "the primary selection is not an extent?"))
328 (save-excursion
329 (let (rect-p b s e)
330 (cond
331 ((consp primary-selection-extent)
332 (setq rect-p t
333 b (extent-object (car primary-selection-extent))
334 s (extent-start-position (car primary-selection-extent))
335 e (extent-end-position (car (reverse primary-selection-extent)))))
336 (t
337 (setq rect-p nil
338 b (extent-object primary-selection-extent)
339 s (extent-start-position primary-selection-extent)
340 e (extent-end-position primary-selection-extent))))
341 (set-buffer b)
342 (cond ((memq mode '(cut copy))
343 (if rect-p
344 (progn
345 ;; why is killed-rectangle free? Is it used somewhere?
346 ;; should it be defvarred?
347 (setq killed-rectangle (extract-rectangle s e))
348 (kill-new (mapconcat 'identity killed-rectangle "\n")))
349 (copy-region-as-kill s e))
350 ;; Maybe killing doesn't own clipboard. Make sure it happens.
351 ;; This memq is kind of grody, because they might have done it
352 ;; some other way, but owning the clipboard twice in that case
353 ;; wouldn't actually hurt anything.
354 (or (and (consp kill-hooks) (memq 'x-own-clipboard kill-hooks))
355 (x-own-clipboard (car kill-ring)))))
356 (cond ((memq mode '(cut clear))
357 (if rect-p
358 (delete-rectangle s e)
359 (delete-region s e))))
360 (x-disown-selection nil)
361 )))
362
363 (defun x-copy-primary-selection ()
364 "Copy the selection to the Clipboard and the kill ring."
365 (interactive)
366 (x-cut-copy-clear-internal 'copy))
367
368 (defun x-kill-primary-selection ()
369 "Copy the selection to the Clipboard and the kill ring, then delete it."
370 (interactive "*")
371 (x-cut-copy-clear-internal 'cut))
372
373 (defun x-delete-primary-selection ()
374 "Delete the selection without copying it to the Clipboard or the kill ring."
375 (interactive "*")
376 (x-cut-copy-clear-internal 'clear))
377
378 (defun x-yank-clipboard-selection ()
379 "Insert the current Clipboard selection at point."
380 (interactive "*")
381 (setq last-command nil)
382 (setq this-command 'yank) ; so that yank-pop works.
383 (let ((clip (x-get-clipboard)))
384 (or clip (error "there is no clipboard selection"))
385 (push-mark)
386 (insert clip)))
387
388 ;;; Functions to convert the selection into various other selection types.
389 ;;; Every selection type that emacs handles is implemented this way, except
390 ;;; for TIMESTAMP, which is a special case.
391
392 (defun xselect-convert-to-text (selection type value)
393 (cond ((stringp value)
394 value)
395 ((extentp value)
396 (save-excursion
397 (set-buffer (extent-object value))
398 (save-restriction
399 (widen)
400 (buffer-substring (extent-start-position value)
401 (extent-end-position value)))))
402 ((and (consp value)
403 (markerp (car value))
404 (markerp (cdr value)))
405 (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
406 (signal 'error
407 (list "markers must be in the same buffer"
408 (car value) (cdr value))))
409 (save-excursion
410 (set-buffer (or (marker-buffer (car value))
411 (error "selection is in a killed buffer")))
412 (save-restriction
413 (widen)
414 (buffer-substring (car value) (cdr value)))))
415 (t nil)))
416
417 (defun xselect-convert-to-string (selection type value)
418 (let ((outval (xselect-convert-to-text selection type value)))
419 ;; force the string to be not in Compound Text format.
420 (if (stringp outval)
421 (cons 'STRING outval)
422 outval)))
423
424 (defun xselect-convert-to-length (selection type value)
425 (let ((value
426 (cond ((stringp value)
427 (length value))
428 ((extentp value)
429 (extent-length value))
430 ((and (consp value)
431 (markerp (car value))
432 (markerp (cdr value)))
433 (or (eq (marker-buffer (car value))
434 (marker-buffer (cdr value)))
435 (signal 'error
436 (list "markers must be in the same buffer"
437 (car value) (cdr value))))
438 (abs (- (car value) (cdr value)))))))
439 (if value ; force it to be in 32-bit format.
440 (cons (ash value -16) (logand value 65535))
441 nil)))
442
443 (defun xselect-convert-to-targets (selection type value)
444 ;; return a vector of atoms, but remove duplicates first.
445 (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
446 (rest all))
447 (while rest
448 (cond ((memq (car rest) (cdr rest))
449 (setcdr rest (delq (car rest) (cdr rest))))
450 ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
451 (setcdr rest (cdr (cdr rest))))
452 (t
453 (setq rest (cdr rest)))))
454 (apply 'vector all)))
455
456 (defun xselect-convert-to-delete (selection type value)
457 (x-disown-selection-internal selection)
458 ;; A return value of nil means that we do not know how to do this conversion,
459 ;; and replies with an "error". A return value of NULL means that we have
460 ;; done the conversion (and any side-effects) but have no value to return.
461 'NULL)
462
463 (defun xselect-convert-to-filename (selection type value)
464 (cond ((extentp value)
465 (buffer-file-name (or (extent-object value)
466 (error "selection is in a killed buffer"))))
467 ((and (consp value)
468 (markerp (car value))
469 (markerp (cdr value)))
470 (buffer-file-name (or (marker-buffer (car value))
471 (error "selection is in a killed buffer"))))
472 (t nil)))
473
474 (defun xselect-convert-to-charpos (selection type value)
475 (let (a b tmp)
476 (cond ((cond ((extentp value)
477 (setq a (extent-start-position value)
478 b (extent-end-position value)))
479 ((and (consp value)
480 (markerp (car value))
481 (markerp (cdr value)))
482 (setq a (car value)
483 b (cdr value))))
484 (setq a (1- a) b (1- b)) ; zero-based
485 (if (< b a) (setq tmp a a b b tmp))
486 (cons 'SPAN
487 (vector (cons (ash a -16) (logand a 65535))
488 (cons (ash b -16) (logand b 65535))))))))
489
490 (defun xselect-convert-to-lineno (selection type value)
491 (let (a b buf tmp)
492 (cond ((cond ((extentp value)
493 (setq buf (extent-object value)
494 a (extent-start-position value)
495 b (extent-end-position value)))
496 ((and (consp value)
497 (markerp (car value))
498 (markerp (cdr value)))
499 (setq a (marker-position (car value))
500 b (marker-position (cdr value))
501 buf (marker-buffer (car value)))))
502 (save-excursion
503 (set-buffer buf)
504 (save-restriction
505 (widen)
506 (goto-char a)
507 (beginning-of-line)
508 (setq a (1+ (count-lines 1 (point))))
509 (goto-char b)
510 (beginning-of-line)
511 (setq b (1+ (count-lines 1 (point))))))
512 (if (< b a) (setq tmp a a b b tmp))
513 (cons 'SPAN
514 (vector (cons (ash a -16) (logand a 65535))
515 (cons (ash b -16) (logand b 65535))))))))
516
517 (defun xselect-convert-to-colno (selection type value)
518 (let (a b buf tmp)
519 (cond ((cond ((extentp value)
520 (setq buf (extent-object value)
521 a (extent-start-position value)
522 b (extent-end-position value)))
523 ((and (consp value)
524 (markerp (car value))
525 (markerp (cdr value)))
526 (setq a (car value)
527 b (cdr value)
528 buf (marker-buffer a))))
529 (save-excursion
530 (set-buffer buf)
531 (goto-char a)
532 (setq a (current-column))
533 (goto-char b)
534 (setq b (current-column)))
535 (if (< b a) (setq tmp a a b b tmp))
536 (cons 'SPAN
537 (vector (cons (ash a -16) (logand a 65535))
538 (cons (ash b -16) (logand b 65535))))))))
539
540 (defun xselect-convert-to-sourceloc (selection type value)
541 (let (a b buf file-name tmp)
542 (cond ((cond ((extentp value)
543 (setq buf (or (extent-object value)
544 (error "selection is in a killed buffer"))
545 a (extent-start-position value)
546 b (extent-end-position value)
547 file-name (buffer-file-name buf)))
548 ((and (consp value)
549 (markerp (car value))
550 (markerp (cdr value)))
551 (setq a (marker-position (car value))
552 b (marker-position (cdr value))
553 buf (or (marker-buffer (car value))
554 (error "selection is in a killed buffer"))
555 file-name (buffer-file-name buf))))
556 (save-excursion
557 (set-buffer buf)
558 (save-restriction
559 (widen)
560 (goto-char a)
561 (beginning-of-line)
562 (setq a (1+ (count-lines 1 (point))))
563 (goto-char b)
564 (beginning-of-line)
565 (setq b (1+ (count-lines 1 (point))))))
566 (if (< b a) (setq tmp a a b b tmp))
567 (format "%s:%d" file-name a)))))
568
569 (defun xselect-convert-to-os (selection type size)
570 (symbol-name system-type))
571
572 (defun xselect-convert-to-host (selection type size)
573 (system-name))
574
575 (defun xselect-convert-to-user (selection type size)
576 (user-full-name))
577
578 (defun xselect-convert-to-class (selection type size)
579 x-emacs-application-class)
580
581 ;; We do not try to determine the name Emacs was invoked with,
582 ;; because it is not clean for a program's behavior to depend on that.
583 (defun xselect-convert-to-name (selection type size)
584 ;invocation-name
585 "xemacs")
586
587 (defun xselect-convert-to-integer (selection type value)
588 (and (integerp value)
589 (cons (ash value -16) (logand value 65535))))
590
591 (defun xselect-convert-to-atom (selection type value)
592 (and (symbolp value) value))
593
594 (defun xselect-convert-to-identity (selection type value) ; used internally
595 (vector value))
596
597 (setq selection-converter-alist
598 '((TEXT . xselect-convert-to-text)
599 (STRING . xselect-convert-to-string)
600 (TARGETS . xselect-convert-to-targets)
601 (LENGTH . xselect-convert-to-length)
602 (DELETE . xselect-convert-to-delete)
603 (FILE_NAME . xselect-convert-to-filename)
604 (CHARACTER_POSITION . xselect-convert-to-charpos)
605 (SOURCE_LOC . xselect-convert-to-sourceloc)
606 (LINE_NUMBER . xselect-convert-to-lineno)
607 (COLUMN_NUMBER . xselect-convert-to-colno)
608 (OWNER_OS . xselect-convert-to-os)
609 (HOST_NAME . xselect-convert-to-host)
610 (USER . xselect-convert-to-user)
611 (CLASS . xselect-convert-to-class)
612 (NAME . xselect-convert-to-name)
613 (ATOM . xselect-convert-to-atom)
614 (INTEGER . xselect-convert-to-integer)
615 (_EMACS_INTERNAL . xselect-convert-to-identity)
616 ))
617
618 ;FSFmacs (provide 'select)
619
620 ;;; x-select.el ends here.
621