Mercurial > hg > xemacs-beta

comparison lisp/x-select.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents de805c49cfc1
children da8ed4261e83
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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 (define-obsolete-function-alias 'x-selection-exists-p 'selection-exists-p) 38 (defvar x-selected-text-type
39 (define-obsolete-function-alias 'x-selection-owner-p 'selection-owner-p) 39 (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
40 (define-obsolete-variable-alias 'x-selection-converter-alist 'selection-converter-alist) 40 "The type atom used to obtain selections from the X server.
41 (define-obsolete-variable-alias 'x-lost-selection-hooks 'lost-selection-hooks) 41 Can be either a valid X selection data type, or a list of such types.
42 (define-obsolete-variable-alias 'x-selected-text-type 'selected-text-type) 42 COMPOUND_TEXT and STRING are the most commonly used data types.
43 (define-obsolete-function-alias 'x-valid-simple-selection-p 'valid-simple-selection-p) 43 If a list is provided, the types are tried in sequence until
44 (define-obsolete-function-alias 'x-own-selection 'own-selection) 44 there is a successful conversion.")
45 (define-obsolete-function-alias 'x-disown-selection 'disown-selection) 45
46 (define-obsolete-function-alias 'x-delete-primary-selection 'delete-primary-selection) 46 (defun x-get-selection (&optional type data-type)
47 (define-obsolete-function-alias 'x-copy-primary-selection 'copy-primary-selection) 47 "Return the value of an X Windows selection.
48 (define-obsolete-function-alias 'x-kill-primary-selection 'kill-primary-selection) 48 The argument TYPE (default `PRIMARY') says which selection,
49 (define-obsolete-function-alias 'x-select-make-extent-for-selection 49 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
50 'select-make-extent-for-selection) 50 says how to convert the data."
51 (define-obsolete-function-alias 'x-cut-copy-clear-internal 'cut-copy-clear-internal) 51 (or type (setq type 'PRIMARY))
52 (define-obsolete-function-alias 'x-get-selection 'get-selection) 52 (or data-type (setq data-type x-selected-text-type))
53 (define-obsolete-function-alias 'x-get-clipboard 'get-clipboard) 53 (let ((text
54 (define-obsolete-function-alias 'x-yank-clipboard-selection 54 (if (consp data-type)
55 'yank-clipboard-selection) 55 (condition-case err
56 (define-obsolete-function-alias 'x-disown-selection-internal 56 (x-get-selection-internal type (car data-type))
57 'disown-selection-internal) 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))
58 67
59 (defun x-get-secondary-selection () 68 (defun x-get-secondary-selection ()
60 "Return text selected from some X window." 69 "Return text selected from some X window."
61 (get-selection 'SECONDARY)) 70 (x-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))
62 127
63 (defun x-own-secondary-selection (selection &optional type) 128 (defun x-own-secondary-selection (selection &optional type)
64 "Make a secondary X Selection of the given argument. The argument may be a 129 "Make a secondary X Selection of the given argument. The argument may be a
65 string or a cons of two markers (in which case the selection is considered to 130 string or a cons of two markers (in which case the selection is considered to
66 be the text between those markers)." 131 be the text between those markers)."
67 (interactive (if (not current-prefix-arg) 132 (interactive (if (not current-prefix-arg)
68 (list (read-string "Store text for pasting: ")) 133 (list (read-string "Store text for pasting: "))
69 (list (cons ;; these need not be ordered. 134 (list (cons ;; these need not be ordered.
70 (copy-marker (point-marker)) 135 (copy-marker (point-marker))
71 (copy-marker (mark-marker)))))) 136 (copy-marker (mark-marker))))))
72 (own-selection selection 'SECONDARY)) 137 (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)
73 170
74 (defun x-notice-selection-requests (selection type successful) 171 (defun x-notice-selection-requests (selection type successful)
75 "for possible use as the value of x-sent-selection-hooks." 172 "for possible use as the value of x-sent-selection-hooks."
76 (if (not successful) 173 (if (not successful)
77 (message "Selection request failed to convert %s to %s" 174 (message "Selection request failed to convert %s to %s"
84 (message "Selection request failed to convert %s to %s" 181 (message "Selection request failed to convert %s to %s"
85 selection type))) 182 selection type)))
86 183
87 ;(setq x-sent-selection-hooks 'x-notice-selection-requests) 184 ;(setq x-sent-selection-hooks 'x-notice-selection-requests)
88 ;(setq x-sent-selection-hooks 'x-notice-selection-failures) 185 ;(setq x-sent-selection-hooks 'x-notice-selection-failures)
186
187
188 ;;; Selections in killed buffers
189 ;;; this function is called by kill-buffer as if it were on the
190 ;;; kill-buffer-hook (though it isn't really).
191
192 (defun xselect-kill-buffer-hook ()
193 ;; Probably the right thing is to write a C function to return a list
194 ;; of the selections which emacs owns, since it could conceivably own
195 ;; a user-defined selection type that we've never heard of.
196 (xselect-kill-buffer-hook-1 'PRIMARY)
197 (xselect-kill-buffer-hook-1 'SECONDARY)
198 (xselect-kill-buffer-hook-1 'CLIPBOARD))
199
200 (defun xselect-kill-buffer-hook-1 (selection)
201 (let (value)
202 (if (and (x-selection-owner-p selection)
203 (setq value (x-get-selection-internal selection '_EMACS_INTERNAL))
204 ;; The _EMACS_INTERNAL selection type has a converter registered
205 ;; for it that does no translation. This only works if emacs is
206 ;; requesting the selection from itself. We could have done this
207 ;; 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.
209 (or (and (consp value)
210 (markerp (car value))
211 (eq (current-buffer) (marker-buffer (car value))))
212 (and (extent-live-p value)
213 (eq (current-buffer) (extent-object value)))
214 (and (extentp value) (not (extent-live-p value)))))
215 (x-disown-selection-internal selection))))
89 216
90 217
91 ;;; Cut Buffer support 218 ;;; Cut Buffer support
92 219
93 ;;; FSF name x-get-cut-buffer 220 ;;; FSF name x-get-cut-buffer
121 (if push 248 (if push
122 (x-rotate-cutbuffers-internal 1)) 249 (x-rotate-cutbuffers-internal 1))
123 (x-store-cutbuffer-internal 'CUT_BUFFER0 string)))) 250 (x-store-cutbuffer-internal 'CUT_BUFFER0 string))))
124 251
125 252
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
126 ;FSFmacs (provide 'select) 500 ;FSFmacs (provide 'select)
127 501
128 ;;; x-select.el ends here. 502 ;;; x-select.el ends here.