Mercurial > hg > xemacs-beta

comparison lisp/x-select.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 57709be46d1b
children de805c49cfc1
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
33 ;; all upper-case; this may seem tasteless, but it makes there be a 1:1 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). 34 ;; correspondence between these symbols and X Atoms (which are upcased).
35 35
36 ;;; Code: 36 ;;; Code:
37 37
38 (defvar x-selected-text-type 38 (define-obsolete-function-alias 'x-selection-exists-p 'selection-exists-p)
39 (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING) 39 (define-obsolete-function-alias 'x-selection-owner-p 'selection-owner-p)
40 "The type atom used to obtain selections from the X server. 40 (define-obsolete-variable-alias 'x-selection-converter-alist 'selection-converter-alist)
41 Can be either a valid X selection data type, or a list of such types. 41 (define-obsolete-variable-alias 'x-lost-selection-hooks 'lost-selection-hooks)
42 COMPOUND_TEXT and STRING are the most commonly used data types. 42 (define-obsolete-variable-alias 'x-selected-text-type 'selected-text-type)
43 If a list is provided, the types are tried in sequence until 43 (define-obsolete-function-alias 'x-valid-simple-selection-p 'valid-simple-selection-p)
44 there is a successful conversion.") 44 (define-obsolete-function-alias 'x-own-selection 'own-selection)
45 45 (define-obsolete-function-alias 'x-disown-selection 'disown-selection)
46 (defun x-get-selection (&optional type data-type) 46 (define-obsolete-function-alias 'x-delete-primary-selection 'delete-primary-selection)
47 "Return the value of an X Windows selection. 47 (define-obsolete-function-alias 'x-copy-primary-selection 'copy-primary-selection)
48 The argument TYPE (default `PRIMARY') says which selection, 48 (define-obsolete-function-alias 'x-kill-primary-selection 'kill-primary-selection)
49 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule) 49 (define-obsolete-function-alias 'x-select-make-extent-for-selection
50 says how to convert the data." 50 'select-make-extent-for-selection)
51 (or type (setq type 'PRIMARY)) 51 (define-obsolete-function-alias 'x-cut-copy-clear-internal 'cut-copy-clear-internal)
52 (or data-type (setq data-type x-selected-text-type)) 52 (define-obsolete-function-alias 'x-get-selection 'get-selection)
53 (let ((text 53 (define-obsolete-function-alias 'x-get-clipboard 'get-clipboard)
54 (if (consp data-type) 54 (define-obsolete-function-alias 'x-yank-clipboard-selection
55 (condition-case err 55 'yank-clipboard-selection)
56 (x-get-selection-internal type (car data-type)) 56 (define-obsolete-function-alias 'x-disown-selection-internal
57 (selection-conversion-error 57 'disown-selection-internal)
58 (if (cdr data-type)
59 (x-get-selection type (cdr data-type))
60 (signal (car err) (cdr err)))))
61 (x-get-selection-internal type data-type))))
62 (when (and (consp text) (symbolp (car text)))
63 (setq text (cdr text)))
64 (when (not (stringp text))
65 (error "Selection is not a string: %S" text))
66 text))
67 58
68 (defun x-get-secondary-selection () 59 (defun x-get-secondary-selection ()
69 "Return text selected from some X window." 60 "Return text selected from some X window."
70 (x-get-selection 'SECONDARY)) 61 (get-selection 'SECONDARY))
71
72 (defun x-get-clipboard ()
73 "Return text pasted to the clipboard."
74 (x-get-selection 'CLIPBOARD))
75
76 ;; FSFmacs calls this `x-set-selection', and reverses the
77 ;; arguments (duh ...). This order is more logical.
78 (defun x-own-selection (data &optional type)
79 "Make an X Windows selection of type TYPE and value DATA.
80 The argument TYPE (default `PRIMARY') says which selection,
81 and DATA specifies the contents. DATA may be a string,
82 a symbol, an integer (or a cons of two integers or list of two integers).
83
84 The selection may also be a cons of two markers pointing to the same buffer,
85 or an overlay. In these cases, the selection is considered to be the text
86 between the markers *at whatever time the selection is examined*.
87 Thus, editing done in the buffer after you specify the selection
88 can alter the effective value of the selection.
89
90 The data may also be a vector of valid non-vector selection values.
91
92 Interactively, the text of the region is used as the selection value."
93 (interactive (if (not current-prefix-arg)
94 (list (read-string "Store text for pasting: "))
95 (list (substring (region-beginning) (region-end)))))
96 ;FSFmacs huh?? It says:
97 ;; "This is for temporary compatibility with pre-release Emacs 19."
98 ;(if (stringp type)
99 ; (setq type (intern type)))
100 (or (x-valid-simple-selection-p data)
101 (and (vectorp data)
102 (let ((valid t)
103 (i (1- (length data))))
104 (while (>= i 0)
105 (or (x-valid-simple-selection-p (aref data i))
106 (setq valid nil))
107 (setq i (1- i)))
108 valid))
109 (signal 'error (list "invalid selection" data)))
110 (or type (setq type 'PRIMARY))
111 (if data
112 (x-own-selection-internal type data)
113 (x-disown-selection-internal type))
114 (cond ((eq type 'PRIMARY)
115 (setq primary-selection-extent
116 (select-make-extent-for-selection
117 data primary-selection-extent)))
118 ((eq type 'SECONDARY)
119 (setq secondary-selection-extent
120 (select-make-extent-for-selection
121 data secondary-selection-extent))))
122 (setq zmacs-region-stays t)
123 data)
124
125 (defun x-valid-simple-selection-p (data)
126 (valid-simple-selection-p data))
127 62
128 (defun x-own-secondary-selection (selection &optional type) 63 (defun x-own-secondary-selection (selection &optional type)
129 "Make a secondary X Selection of the given argument. The argument may be a 64 "Make a secondary X Selection of the given argument. The argument may be a
130 string or a cons of two markers (in which case the selection is considered to 65 string or a cons of two markers (in which case the selection is considered to
131 be the text between those markers)." 66 be the text between those markers)."
132 (interactive (if (not current-prefix-arg) 67 (interactive (if (not current-prefix-arg)
133 (list (read-string "Store text for pasting: ")) 68 (list (read-string "Store text for pasting: "))
134 (list (cons ;; these need not be ordered. 69 (list (cons ;; these need not be ordered.
135 (copy-marker (point-marker)) 70 (copy-marker (point-marker))
136 (copy-marker (mark-marker)))))) 71 (copy-marker (mark-marker))))))
137 (x-own-selection selection 'SECONDARY)) 72 (own-selection selection 'SECONDARY))
138
139
140 (defun x-own-clipboard (string)
141 "Paste the given string to the X Clipboard."
142 (x-own-selection string 'CLIPBOARD))
143
144
145 (defun x-disown-selection (&optional secondary-p)
146 "Assuming we own the selection, disown it. With an argument, discard the
147 secondary selection instead of the primary selection."
148 (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
149
150 (defun x-dehilight-selection (selection)
151 "for use as a value of `x-lost-selection-hooks'."
152 (cond ((eq selection 'PRIMARY)
153 (if primary-selection-extent
154 (let ((inhibit-quit t))
155 (if (consp primary-selection-extent)
156 (mapcar 'delete-extent primary-selection-extent)
157 (delete-extent primary-selection-extent))
158 (setq primary-selection-extent nil)))
159 (if zmacs-regions (zmacs-deactivate-region)))
160 ((eq selection 'SECONDARY)
161 (if secondary-selection-extent
162 (let ((inhibit-quit t))
163 (if (consp secondary-selection-extent)
164 (mapcar 'delete-extent secondary-selection-extent)
165 (delete-extent secondary-selection-extent))
166 (setq secondary-selection-extent nil)))))
167 nil)
168
169 (setq x-lost-selection-hooks 'x-dehilight-selection)
170 73
171 (defun x-notice-selection-requests (selection type successful) 74 (defun x-notice-selection-requests (selection type successful)
172 "for possible use as the value of x-sent-selection-hooks." 75 "for possible use as the value of x-sent-selection-hooks."
173 (if (not successful) 76 (if (not successful)
174 (message "Selection request failed to convert %s to %s" 77 (message "Selection request failed to convert %s to %s"
197 (xselect-kill-buffer-hook-1 'SECONDARY) 100 (xselect-kill-buffer-hook-1 'SECONDARY)
198 (xselect-kill-buffer-hook-1 'CLIPBOARD)) 101 (xselect-kill-buffer-hook-1 'CLIPBOARD))
199 102
200 (defun xselect-kill-buffer-hook-1 (selection) 103 (defun xselect-kill-buffer-hook-1 (selection)
201 (let (value) 104 (let (value)
202 (if (and (x-selection-owner-p selection) 105 (if (and (selection-owner-p selection)
203 (setq value (x-get-selection-internal selection '_EMACS_INTERNAL)) 106 (setq value (get-selection-internal selection '_EMACS_INTERNAL))
204 ;; The _EMACS_INTERNAL selection type has a converter registered 107 ;; The _EMACS_INTERNAL selection type has a converter registered
205 ;; for it that does no translation. This only works if emacs is 108 ;; for it that does no translation. This only works if emacs is
206 ;; requesting the selection from itself. We could have done this 109 ;; requesting the selection from itself. We could have done this
207 ;; by writing a C function to return the raw selection data, and 110 ;; by writing a C function to return the raw selection data, and
208 ;; that might be the right way to do this, but this was easy. 111 ;; that might be the right way to do this, but this was easy.
210 (markerp (car value)) 113 (markerp (car value))
211 (eq (current-buffer) (marker-buffer (car value)))) 114 (eq (current-buffer) (marker-buffer (car value))))
212 (and (extent-live-p value) 115 (and (extent-live-p value)
213 (eq (current-buffer) (extent-object value))) 116 (eq (current-buffer) (extent-object value)))
214 (and (extentp value) (not (extent-live-p value))))) 117 (and (extentp value) (not (extent-live-p value)))))
215 (x-disown-selection-internal selection)))) 118 (disown-selection-internal selection))))
216 119
217 120
218 ;;; Cut Buffer support 121 ;;; Cut Buffer support
219 122
220 ;;; FSF name x-get-cut-buffer 123 ;;; FSF name x-get-cut-buffer
248 (if push 151 (if push
249 (x-rotate-cutbuffers-internal 1)) 152 (x-rotate-cutbuffers-internal 1))
250 (x-store-cutbuffer-internal 'CUT_BUFFER0 string)))) 153 (x-store-cutbuffer-internal 'CUT_BUFFER0 string))))
251 154
252 155
253 ;;; Random utility functions
254
255 (defun x-yank-clipboard-selection ()
256 "Insert the current Clipboard selection at point."
257 (interactive "*")
258 (setq last-command nil)
259 (setq this-command 'yank) ; so that yank-pop works.
260 (let ((clip (x-get-clipboard)))
261 (or clip (error "there is no clipboard selection"))
262 (push-mark)
263 (insert clip)))
264
265 ;;; Functions to convert the selection into various other selection types.
266 ;;; Every selection type that emacs handles is implemented this way, except
267 ;;; for TIMESTAMP, which is a special case.
268
269 (defun xselect-convert-to-text (selection type value)
270 (cond ((stringp value)
271 value)
272 ((extentp value)
273 (save-excursion
274 (set-buffer (extent-object value))
275 (save-restriction
276 (widen)
277 (buffer-substring (extent-start-position value)
278 (extent-end-position value)))))
279 ((and (consp value)
280 (markerp (car value))
281 (markerp (cdr value)))
282 (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
283 (signal 'error
284 (list "markers must be in the same buffer"
285 (car value) (cdr value))))
286 (save-excursion
287 (set-buffer (or (marker-buffer (car value))
288 (error "selection is in a killed buffer")))
289 (save-restriction
290 (widen)
291 (buffer-substring (car value) (cdr value)))))
292 (t nil)))
293
294 (defun xselect-convert-to-string (selection type value)
295 (let ((outval (xselect-convert-to-text selection type value)))
296 ;; force the string to be not in Compound Text format.
297 (if (stringp outval)
298 (cons 'STRING outval)
299 outval)))
300
301 (defun xselect-convert-to-compound-text (selection type value)
302 ;; converts to compound text automatically
303 (xselect-convert-to-text selection type value))
304
305 (defun xselect-convert-to-length (selection type value)
306 (let ((value
307 (cond ((stringp value)
308 (length value))
309 ((extentp value)
310 (extent-length value))
311 ((and (consp value)
312 (markerp (car value))
313 (markerp (cdr value)))
314 (or (eq (marker-buffer (car value))
315 (marker-buffer (cdr value)))
316 (signal 'error
317 (list "markers must be in the same buffer"
318 (car value) (cdr value))))
319 (abs (- (car value) (cdr value)))))))
320 (if value ; force it to be in 32-bit format.
321 (cons (ash value -16) (logand value 65535))
322 nil)))
323
324 (defun xselect-convert-to-targets (selection type value)
325 ;; return a vector of atoms, but remove duplicates first.
326 (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
327 (rest all))
328 (while rest
329 (cond ((memq (car rest) (cdr rest))
330 (setcdr rest (delq (car rest) (cdr rest))))
331 ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
332 (setcdr rest (cdr (cdr rest))))
333 (t
334 (setq rest (cdr rest)))))
335 (apply 'vector all)))
336
337 (defun xselect-convert-to-delete (selection type value)
338 (x-disown-selection-internal selection)
339 ;; A return value of nil means that we do not know how to do this conversion,
340 ;; and replies with an "error". A return value of NULL means that we have
341 ;; done the conversion (and any side-effects) but have no value to return.
342 'NULL)
343
344 (defun xselect-convert-to-filename (selection type value)
345 (cond ((extentp value)
346 (buffer-file-name (or (extent-object value)
347 (error "selection is in a killed buffer"))))
348 ((and (consp value)
349 (markerp (car value))
350 (markerp (cdr value)))
351 (buffer-file-name (or (marker-buffer (car value))
352 (error "selection is in a killed buffer"))))
353 (t nil)))
354
355 (defun xselect-convert-to-charpos (selection type value)
356 (let (a b tmp)
357 (cond ((cond ((extentp value)
358 (setq a (extent-start-position value)
359 b (extent-end-position value)))
360 ((and (consp value)
361 (markerp (car value))
362 (markerp (cdr value)))
363 (setq a (car value)
364 b (cdr value))))
365 (setq a (1- a) b (1- b)) ; zero-based
366 (if (< b a) (setq tmp a a b b tmp))
367 (cons 'SPAN
368 (vector (cons (ash a -16) (logand a 65535))
369 (cons (ash b -16) (logand b 65535))))))))
370
371 (defun xselect-convert-to-lineno (selection type value)
372 (let (a b buf tmp)
373 (cond ((cond ((extentp value)
374 (setq buf (extent-object value)
375 a (extent-start-position value)
376 b (extent-end-position value)))
377 ((and (consp value)
378 (markerp (car value))
379 (markerp (cdr value)))
380 (setq a (marker-position (car value))
381 b (marker-position (cdr value))
382 buf (marker-buffer (car value)))))
383 (save-excursion
384 (set-buffer buf)
385 (save-restriction
386 (widen)
387 (goto-char a)
388 (beginning-of-line)
389 (setq a (1+ (count-lines 1 (point))))
390 (goto-char b)
391 (beginning-of-line)
392 (setq b (1+ (count-lines 1 (point))))))
393 (if (< b a) (setq tmp a a b b tmp))
394 (cons 'SPAN
395 (vector (cons (ash a -16) (logand a 65535))
396 (cons (ash b -16) (logand b 65535))))))))
397
398 (defun xselect-convert-to-colno (selection type value)
399 (let (a b buf tmp)
400 (cond ((cond ((extentp value)
401 (setq buf (extent-object value)
402 a (extent-start-position value)
403 b (extent-end-position value)))
404 ((and (consp value)
405 (markerp (car value))
406 (markerp (cdr value)))
407 (setq a (car value)
408 b (cdr value)
409 buf (marker-buffer a))))
410 (save-excursion
411 (set-buffer buf)
412 (goto-char a)
413 (setq a (current-column))
414 (goto-char b)
415 (setq b (current-column)))
416 (if (< b a) (setq tmp a a b b tmp))
417 (cons 'SPAN
418 (vector (cons (ash a -16) (logand a 65535))
419 (cons (ash b -16) (logand b 65535))))))))
420
421 (defun xselect-convert-to-sourceloc (selection type value)
422 (let (a b buf file-name tmp)
423 (cond ((cond ((extentp value)
424 (setq buf (or (extent-object value)
425 (error "selection is in a killed buffer"))
426 a (extent-start-position value)
427 b (extent-end-position value)
428 file-name (buffer-file-name buf)))
429 ((and (consp value)
430 (markerp (car value))
431 (markerp (cdr value)))
432 (setq a (marker-position (car value))
433 b (marker-position (cdr value))
434 buf (or (marker-buffer (car value))
435 (error "selection is in a killed buffer"))
436 file-name (buffer-file-name buf))))
437 (save-excursion
438 (set-buffer buf)
439 (save-restriction
440 (widen)
441 (goto-char a)
442 (beginning-of-line)
443 (setq a (1+ (count-lines 1 (point))))
444 (goto-char b)
445 (beginning-of-line)
446 (setq b (1+ (count-lines 1 (point))))))
447 (if (< b a) (setq tmp a a b b tmp))
448 (format "%s:%d" file-name a)))))
449
450 (defun xselect-convert-to-os (selection type size)
451 (symbol-name system-type))
452
453 (defun xselect-convert-to-host (selection type size)
454 (system-name))
455
456 (defun xselect-convert-to-user (selection type size)
457 (user-full-name))
458
459 (defun xselect-convert-to-class (selection type size)
460 x-emacs-application-class)
461
462 ;; We do not try to determine the name Emacs was invoked with,
463 ;; because it is not clean for a program's behavior to depend on that.
464 (defun xselect-convert-to-name (selection type size)
465 ;invocation-name
466 "xemacs")
467
468 (defun xselect-convert-to-integer (selection type value)
469 (and (integerp value)
470 (cons (ash value -16) (logand value 65535))))
471
472 (defun xselect-convert-to-atom (selection type value)
473 (and (symbolp value) value))
474
475 (defun xselect-convert-to-identity (selection type value) ; used internally
476 (vector value))
477
478 (setq selection-converter-alist
479 '((TEXT . xselect-convert-to-text)
480 (STRING . xselect-convert-to-string)
481 (COMPOUND_TEXT . xselect-convert-to-compound-text)
482 (TARGETS . xselect-convert-to-targets)
483 (LENGTH . xselect-convert-to-length)
484 (DELETE . xselect-convert-to-delete)
485 (FILE_NAME . xselect-convert-to-filename)
486 (CHARACTER_POSITION . xselect-convert-to-charpos)
487 (SOURCE_LOC . xselect-convert-to-sourceloc)
488 (LINE_NUMBER . xselect-convert-to-lineno)
489 (COLUMN_NUMBER . xselect-convert-to-colno)
490 (OWNER_OS . xselect-convert-to-os)
491 (HOST_NAME . xselect-convert-to-host)
492 (USER . xselect-convert-to-user)
493 (CLASS . xselect-convert-to-class)
494 (NAME . xselect-convert-to-name)
495 (ATOM . xselect-convert-to-atom)
496 (INTEGER . xselect-convert-to-integer)
497 (_EMACS_INTERNAL . xselect-convert-to-identity)
498 ))
499
500 ;FSFmacs (provide 'select) 156 ;FSFmacs (provide 'select)
501 157
502 ;;; x-select.el ends here. 158 ;;; x-select.el ends here.