Mercurial > hg > xemacs-beta

comparison lisp/x-select.el @ 414:da8ed4261e83 r21-2-15

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-15
author cvs
date Mon, 13 Aug 2007 11:21:38 +0200
parents 697ef44129c6
children ebe98a74bd68
comparison
equal deleted inserted replaced
413:901169e5ca31 414:da8ed4261e83
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
54 (if (consp data-type)
55 (condition-case err
56 (x-get-selection-internal type (car data-type))
57 (selection-conversion-error
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 53
68 (defun x-get-secondary-selection () 54 (defun x-get-secondary-selection ()
69 "Return text selected from some X window." 55 "Return text selected from some X window."
70 (x-get-selection 'SECONDARY)) 56 (get-selection 'SECONDARY))
71 57
72 (defun x-get-clipboard () 58 (defun x-get-clipboard ()
73 "Return text pasted to the clipboard." 59 "Return text pasted to the clipboard."
74 (x-get-selection 'CLIPBOARD)) 60 (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 61
128 (defun x-own-secondary-selection (selection &optional type) 62 (defun x-own-secondary-selection (selection &optional type)
129 "Make a secondary X Selection of the given argument. The argument may be a 63 "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 64 string or a cons of two markers (in which case the selection is considered to
131 be the text between those markers)." 65 be the text between those markers)."
133 (list (read-string "Store text for pasting: ")) 67 (list (read-string "Store text for pasting: "))
134 (list (cons ;; these need not be ordered. 68 (list (cons ;; these need not be ordered.
135 (copy-marker (point-marker)) 69 (copy-marker (point-marker))
136 (copy-marker (mark-marker)))))) 70 (copy-marker (mark-marker))))))
137 (x-own-selection selection 'SECONDARY)) 71 (x-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 72
171 (defun x-notice-selection-requests (selection type successful) 73 (defun x-notice-selection-requests (selection type successful)
172 "for possible use as the value of x-sent-selection-hooks." 74 "for possible use as the value of x-sent-selection-hooks."
173 (if (not successful) 75 (if (not successful)
174 (message "Selection request failed to convert %s to %s" 76 (message "Selection request failed to convert %s to %s"
198 (xselect-kill-buffer-hook-1 'CLIPBOARD)) 100 (xselect-kill-buffer-hook-1 'CLIPBOARD))
199 101
200 (defun xselect-kill-buffer-hook-1 (selection) 102 (defun xselect-kill-buffer-hook-1 (selection)
201 (let (value) 103 (let (value)
202 (if (and (x-selection-owner-p selection) 104 (if (and (x-selection-owner-p selection)
203 (setq value (x-get-selection-internal selection '_EMACS_INTERNAL)) 105 (setq value (get-selection-internal selection '_EMACS_INTERNAL))
204 ;; The _EMACS_INTERNAL selection type has a converter registered 106 ;; The _EMACS_INTERNAL selection type has a converter registered
205 ;; for it that does no translation. This only works if emacs is 107 ;; for it that does no translation. This only works if emacs is
206 ;; requesting the selection from itself. We could have done this 108 ;; requesting the selection from itself. We could have done this
207 ;; by writing a C function to return the raw selection data, and 109 ;; 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. 110 ;; that might be the right way to do this, but this was easy.
260 (let ((clip (x-get-clipboard))) 162 (let ((clip (x-get-clipboard)))
261 (or clip (error "there is no clipboard selection")) 163 (or clip (error "there is no clipboard selection"))
262 (push-mark) 164 (push-mark)
263 (insert clip))) 165 (insert clip)))
264 166
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 167
500 ;FSFmacs (provide 'select) 168 ;FSFmacs (provide 'select)
501 169
502 ;;; x-select.el ends here. 170 ;;; x-select.el ends here.