Mercurial > hg > xemacs-beta

comparison lisp/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
29 ;;; Commentary: 29 ;;; Commentary:
30 30
31 ;; This file is dumped with XEmacs 31 ;; This file is dumped with XEmacs
32 32
33 ;;; Code: 33 ;;; Code:
34
35 (defvar selected-text-type
36 (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
37 "The type atom used to obtain selections from the X server.
38 Can be either a valid X selection data type, or a list of such types.
39 COMPOUND_TEXT and STRING are the most commonly used data types.
40 If a list is provided, the types are tried in sequence until
41 there is a successful conversion.")
42
43 (defvar selection-sets-clipboard nil
44 "Controls the selection's relationship to the clipboard.
45 When non-nil, any operation that sets the primary selection will also
46 set the clipboard.")
47 34
48 (defun copy-primary-selection () 35 (defun copy-primary-selection ()
49 "Copy the selection to the Clipboard and the kill ring." 36 "Copy the selection to the Clipboard and the kill ring."
50 (interactive) 37 (interactive)
51 (and (console-on-window-system-p) 38 (and (console-on-window-system-p)
52 (cut-copy-clear-internal 'copy))) 39 (cut-copy-clear-internal 'copy)))
40 (define-obsolete-function-alias
41 'x-copy-primary-selection
42 'copy-primary-selection)
53 43
54 (defun kill-primary-selection () 44 (defun kill-primary-selection ()
55 "Copy the selection to the Clipboard and the kill ring, then delete it." 45 "Copy the selection to the Clipboard and the kill ring, then delete it."
56 (interactive "*") 46 (interactive "*")
57 (and (console-on-window-system-p) 47 (and (console-on-window-system-p)
58 (cut-copy-clear-internal 'cut))) 48 (cut-copy-clear-internal 'cut)))
49 (define-obsolete-function-alias
50 'x-kill-primary-selection
51 'kill-primary-selection)
59 52
60 (defun delete-primary-selection () 53 (defun delete-primary-selection ()
61 "Delete the selection without copying it to the Clipboard or the kill ring." 54 "Delete the selection without copying it to the Clipboard or the kill ring."
62 (interactive "*") 55 (interactive "*")
63 (and (console-on-window-system-p) 56 (and (console-on-window-system-p)
64 (cut-copy-clear-internal 'clear))) 57 (cut-copy-clear-internal 'clear)))
58 (define-obsolete-function-alias
59 'x-delete-primary-selection
60 'delete-primary-selection)
65 61
66 (defun yank-clipboard-selection () 62 (defun yank-clipboard-selection ()
67 "Insert the current Clipboard selection at point." 63 "Insert the current Clipboard selection at point."
68 (interactive "*") 64 (interactive "*")
69 (when (console-on-window-system-p) 65 (case (device-type (selected-device))
70 (setq last-command nil) 66 (x (x-yank-clipboard-selection))
71 (setq this-command 'yank) ; so that yank-pop works. 67 (mswindows (mswindows-paste-clipboard))
72 (let ((clip (get-clipboard))) 68 (otherwise nil)))
73 (or clip (error "there is no clipboard selection")) 69
74 (push-mark) 70 (defun selection-owner-p (&optional selection)
75 (insert clip)))) 71 "Return t if current XEmacs process owns the given Selection.
76 72 The arg should be the name of the selection in question, typically one
77 (defun get-clipboard () 73 of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience,
78 "Return text pasted to the clipboard." 74 the symbol nil is the same as PRIMARY, and t is the same as
79 (get-selection 'CLIPBOARD)) 75 SECONDARY.)"
80 76 (interactive)
81 (define-device-method get-cutbuffer 77 (case (device-type (selected-device))
82 "Return the value of one of the cut buffers. 78 (x (x-selection-owner-p selection))
83 This will do nothing under anything other than X.") 79 (mswindows (mswindows-selection-owner-p selection))
84 80 (otherwise nil)))
85 (defun get-selection-no-error (&optional type data-type) 81
86 "Return the value of a window-system selection. 82 (defun selection-exists-p (&optional selection)
83 "Whether there is an owner for the given Selection.
84 The arg should be the name of the selection in question, typically one
85 of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience,
86 the symbol nil is the same as PRIMARY, and t is the same as
87 SECONDARY."
88 (interactive)
89 (case (device-type (selected-device))
90 (x (x-selection-exists-p selection))
91 (mswindows (mswindows-selection-exists-p))
92 (otherwise nil)))
93
94 (defun own-selection (data &optional type)
95 "Make an Windows selection of type TYPE and value DATA.
87 The argument TYPE (default `PRIMARY') says which selection, 96 The argument TYPE (default `PRIMARY') says which selection,
88 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule) 97 and DATA specifies the contents. DATA may be a string,
89 says how to convert the data. Returns NIL if there is no selection" 98 a symbol, an integer (or a cons of two integers or list of two integers).
90 (condition-case err (get-selection type data-type) (t nil)))
91
92 (defun get-selection (&optional type data-type)
93 "Return the value of a window-system selection.
94 The argument TYPE (default `PRIMARY') says which selection,
95 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
96 says how to convert the data. If there is no selection an error is signalled."
97 (or type (setq type 'PRIMARY))
98 (or data-type (setq data-type selected-text-type))
99 (let ((text
100 (if (consp data-type)
101 (condition-case err
102 (get-selection-internal type (car data-type))
103 (selection-conversion-error
104 (if (cdr data-type)
105 (get-selection type (cdr data-type))
106 (signal (car err) (cdr err)))))
107 (get-selection-internal type data-type))))
108 text))
109
110 ;; FSFmacs calls this `x-set-selection', and reverses the
111 ;; first two arguments (duh ...). This order is more logical.
112 (defun own-selection (data &optional type how-to-add data-type)
113 "Make a window-system selection of type TYPE and value DATA.
114 The argument TYPE (default `PRIMARY') says which selection,
115 and DATA specifies the contents. DATA may be any lisp data type
116 that can be converted using the function corresponding to DATA-TYPE
117 in `select-converter-alist'---strings are the usual choice, but
118 other types may be permissible depending on the DATA-TYPE parameter
119 (if DATA-TYPE is not supplied, the default behaviour is window
120 system specific, but strings are always accepted).
121 HOW-TO-ADD may be any of the following:
122
123 'replace-all or nil -- replace all data in the selection.
124 'replace-existing -- replace data for specified DATA-TYPE only.
125 'append or t -- append data to existing DATA-TYPE data.
126
127 DATA-TYPE is the window-system specific data type identifier
128 (see `register-selection-data-type' for more information).
129 99
130 The selection may also be a cons of two markers pointing to the same buffer, 100 The selection may also be a cons of two markers pointing to the same buffer,
131 or an overlay. In these cases, the selection is considered to be the text 101 or an overlay. In these cases, the selection is considered to be the text
132 between the markers *at whatever time the selection is examined* (note 102 between the markers *at whatever time the selection is examined*.
133 that the window system clipboard does not necessarily duplicate this
134 behaviour - it doesn't on mswindows for example).
135 Thus, editing done in the buffer after you specify the selection 103 Thus, editing done in the buffer after you specify the selection
136 can alter the effective value of the selection. 104 can alter the effective value of the selection.
137 105
138 The data may also be a vector of valid non-vector selection values. 106 The data may also be a vector of valid non-vector selection values.
139 107
140 Interactively, the text of the region is used as the selection value." 108 Interactively, the text of the region is used as the selection value."
141 (interactive (if (not current-prefix-arg) 109 (interactive (if (not current-prefix-arg)
142 (list (read-string "Store text for pasting: ")) 110 (list (read-string "Store text for pasting: "))
143 (list (substring (region-beginning) (region-end))))) 111 (list (substring (region-beginning) (region-end)))))
144 ;; calling own-selection-internal will mess this up, so preserve it. 112 (case (device-type (selected-device))
145 (let ((zmacs-region-stays zmacs-region-stays)) 113 (x (x-own-selection data type))
146 ;FSFmacs huh?? It says: 114 (mswindows (mswindows-own-selection data type))
147 ;; "This is for temporary compatibility with pre-release Emacs 19." 115 (otherwise nil)))
148 ;(if (stringp type) 116
149 ; (setq type (intern type))) 117 (defun own-clipboard (string)
150 (or type (setq type 'PRIMARY)) 118 "Paste the given string to the Clipboard."
151 (if (null data) 119 (case (device-type (selected-device))
152 (disown-selection-internal type) 120 (x (x-own-clipboard string))
153 (own-selection-internal type data how-to-add data-type) 121 (mswindows (mswindows-own-clipboard string))
154 (when (and (eq type 'PRIMARY) 122 (otherwise nil)))
155 selection-sets-clipboard)
156 (own-selection-internal 'CLIPBOARD data how-to-add data-type)))
157 (cond ((eq type 'PRIMARY)
158 (setq primary-selection-extent
159 (select-make-extent-for-selection
160 data primary-selection-extent)))
161 ((eq type 'SECONDARY)
162 (setq secondary-selection-extent
163 (select-make-extent-for-selection
164 data secondary-selection-extent)))))
165 ;; zmacs-region-stays is for commands, not low-level functions.
166 ;; when behaving as the latter, we better not set it, or we will
167 ;; cause unwanted sticky-region behavior in kill-region and friends.
168 (if (interactive-p)
169 (setq zmacs-region-stays t))
170 data)
171
172 (defun dehilight-selection (selection)
173 "for use as a value of `lost-selection-hooks'."
174 (cond ((eq selection 'PRIMARY)
175 (if primary-selection-extent
176 (let ((inhibit-quit t))
177 (if (consp primary-selection-extent)
178 (mapcar 'delete-extent primary-selection-extent)
179 (delete-extent primary-selection-extent))
180 (setq primary-selection-extent nil)))
181 (if zmacs-regions (zmacs-deactivate-region)))
182 ((eq selection 'SECONDARY)
183 (if secondary-selection-extent
184 (let ((inhibit-quit t))
185 (if (consp secondary-selection-extent)
186 (mapcar 'delete-extent secondary-selection-extent)
187 (delete-extent secondary-selection-extent))
188 (setq secondary-selection-extent nil)))))
189 nil)
190
191 (setq lost-selection-hooks 'dehilight-selection)
192
193 (defun own-clipboard (string &optional push)
194 "Paste the given string to the window system Clipboard.
195 See `interprogram-cut-function' for more information."
196 (own-selection string 'CLIPBOARD))
197 123
198 (defun disown-selection (&optional secondary-p) 124 (defun disown-selection (&optional secondary-p)
199 "Assuming we own the selection, disown it. With an argument, discard the 125 "Assuming we own the selection, disown it. With an argument, discard the
200 secondary selection instead of the primary selection." 126 secondary selection instead of the primary selection."
201 (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)) 127 (case (device-type (selected-device))
202 (when (and selection-sets-clipboard 128 (x (x-disown-selection secondary-p))
203 (or (not secondary-p) 129 (mswindows (mswindows-disown-selection secondary-p))
204 (eq secondary-p 'PRIMARY) 130 (otherwise nil)))
205 (eq secondary-p 'CLIPBOARD))) 131
206 (disown-selection-internal 'CLIPBOARD)))
207 132
208 ;; from x-init.el 133 ;; from x-init.el
209 ;; selections and active regions 134 ;; selections and active regions
210 135
211 ;; If and only if zmacs-regions is true: 136 ;; If and only if zmacs-regions is true:
291 (mouse-track-rectangle-p 216 (mouse-track-rectangle-p
292 (setq previous-extent (list previous-extent)) 217 (setq previous-extent (list previous-extent))
293 (default-mouse-track-next-move-rect start end previous-extent) 218 (default-mouse-track-next-move-rect start end previous-extent)
294 )) 219 ))
295 previous-extent)))) 220 previous-extent))))
221 (define-obsolete-function-alias
222 'x-select-make-extent-for-selection
223 'select-make-extent-for-selection)
296 224
297 ;; moved from x-select.el 225 ;; moved from x-select.el
298 (defun valid-simple-selection-p (data) 226 (defun valid-simple-selection-p (data)
299 "An obsolete function that tests whether something was a valid simple
300 selection using the old XEmacs selection support. You shouldn't use this
301 any more, because just about anything could be a valid selection now."
302 (or (stringp data) 227 (or (stringp data)
303 ;FSFmacs huh?? (symbolp data) 228 ;FSFmacs huh?? (symbolp data)
304 (integerp data) 229 (integerp data)
305 (and (consp data) 230 (and (consp data)
306 (integerp (car data)) 231 (integerp (car data))
315 (marker-buffer (cdr data)) 240 (marker-buffer (cdr data))
316 (eq (marker-buffer (car data)) 241 (eq (marker-buffer (car data))
317 (marker-buffer (cdr data))) 242 (marker-buffer (cdr data)))
318 (buffer-live-p (marker-buffer (car data))) 243 (buffer-live-p (marker-buffer (car data)))
319 (buffer-live-p (marker-buffer (cdr data)))))) 244 (buffer-live-p (marker-buffer (cdr data))))))
245 (define-obsolete-function-alias
246 'x-valid-simple-selection-p
247 'valid-simple-selection-p)
320 248
321 (defun cut-copy-clear-internal (mode) 249 (defun cut-copy-clear-internal (mode)
322 (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode)) 250 (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
323 (or (selection-owner-p) 251 (or (selection-owner-p)
324 (error "XEmacs does not own the primary selection")) 252 (error "XEmacs does not own the primary selection"))
357 (if rect-p 285 (if rect-p
358 (delete-rectangle s e) 286 (delete-rectangle s e)
359 (delete-region s e)))) 287 (delete-region s e))))
360 (disown-selection nil) 288 (disown-selection nil)
361 ))) 289 )))
362 290 (define-obsolete-function-alias
363 291 'x-cut-copy-clear-internal
364 ;;; Functions to convert the selection into various other selection 292 'cut-copy-clear-internal)
365 ;;; types.
366
367 ;; These two functions get called by C code...
368 (defun select-convert-in (selection type value)
369 "Attempt to convert the specified external VALUE to the specified DATA-TYPE,
370 for the specified SELECTION. Return nil if this is impossible, or a
371 suitable internal representation otherwise."
372 (when value
373 (let ((handler-fn (cdr (assq type selection-converter-in-alist))))
374 (when handler-fn
375 (apply handler-fn (list selection type value))))))
376
377 (defun select-convert-out (selection type value)
378 "Attempt to convert the specified internal VALUE for the specified DATA-TYPE
379 and SELECTION. Return nil if this is impossible, or a suitable external
380 representation otherwise."
381 (when value
382 (let ((handler-fn (cdr (assq type selection-converter-out-alist))))
383 (when handler-fn
384 (apply handler-fn (list selection type value))))))
385
386 ;; The rest of the functions on this "page" are conversion handlers,
387 ;; append handlers and buffer-kill handlers.
388 (defun select-convert-to-text (selection type value)
389 (cond ((stringp value)
390 value)
391 ((extentp value)
392 (save-excursion
393 (set-buffer (extent-object value))
394 (save-restriction
395 (widen)
396 (buffer-substring (extent-start-position value)
397 (extent-end-position value)))))
398 ((and (consp value)
399 (markerp (car value))
400 (markerp (cdr value)))
401 (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
402 (signal 'error
403 (list "markers must be in the same buffer"
404 (car value) (cdr value))))
405 (save-excursion
406 (set-buffer (or (marker-buffer (car value))
407 (error "selection is in a killed buffer")))
408 (save-restriction
409 (widen)
410 (buffer-substring (car value) (cdr value)))))
411 (t nil)))
412
413 (defun select-convert-from-text (selection type value)
414 (when (stringp value)
415 value))
416
417 (defun select-convert-to-string (selection type value)
418 (let ((outval (select-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 select-convert-to-compound-text (selection type value)
425 ;; converts to compound text automatically
426 (select-convert-to-text selection type value))
427
428 (defun select-convert-to-length (selection type value)
429 (let ((value
430 (cond ((stringp value)
431 (length value))
432 ((extentp value)
433 (extent-length value))
434 ((and (consp value)
435 (markerp (car value))
436 (markerp (cdr value)))
437 (or (eq (marker-buffer (car value))
438 (marker-buffer (cdr value)))
439 (signal 'error
440 (list "markers must be in the same buffer"
441 (car value) (cdr value))))
442 (abs (- (car value) (cdr value)))))))
443 (if value ; force it to be in 32-bit format.
444 (cons (ash value -16) (logand value 65535))
445 nil)))
446
447 (defun select-convert-from-length (selection type value)
448 (select-convert-to-length selection type value))
449
450 (defun select-convert-to-targets (selection type value)
451 ;; return a vector of atoms, but remove duplicates first.
452 (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
453 (rest all))
454 (while rest
455 (cond ((memq (car rest) (cdr rest))
456 (setcdr rest (delq (car rest) (cdr rest))))
457 (t
458 (setq rest (cdr rest)))))
459 (apply 'vector all)))
460
461 (defun select-convert-to-delete (selection type value)
462 (disown-selection-internal selection)
463 ;; A return value of nil means that we do not know how to do this conversion,
464 ;; and replies with an "error". A return value of NULL means that we have
465 ;; done the conversion (and any side-effects) but have no value to return.
466 'NULL)
467
468 (defun select-convert-to-filename (selection type value)
469 (cond ((extentp value)
470 (buffer-file-name (or (extent-object value)
471 (error "selection is in a killed buffer"))))
472 ((and (consp value)
473 (markerp (car value))
474 (markerp (cdr value)))
475 (buffer-file-name (or (marker-buffer (car value))
476 (error "selection is in a killed buffer"))))
477 (t nil)))
478
479 (defun select-convert-from-filename (selection type value)
480 (when (stringp value)
481 value))
482
483 (defun select-convert-to-charpos (selection type value)
484 (let (a b tmp)
485 (cond ((cond ((extentp value)
486 (setq a (extent-start-position value)
487 b (extent-end-position value)))
488 ((and (consp value)
489 (markerp (car value))
490 (markerp (cdr value)))
491 (setq a (car value)
492 b (cdr value))))
493 (setq a (1- a) b (1- b)) ; zero-based
494 (if (< b a) (setq tmp a a b b tmp))
495 (cons 'SPAN
496 (vector (cons (ash a -16) (logand a 65535))
497 (cons (ash b -16) (logand b 65535))))))))
498
499 (defun select-convert-to-lineno (selection type value)
500 (let (a b buf tmp)
501 (cond ((cond ((extentp value)
502 (setq buf (extent-object value)
503 a (extent-start-position value)
504 b (extent-end-position value)))
505 ((and (consp value)
506 (markerp (car value))
507 (markerp (cdr value)))
508 (setq a (marker-position (car value))
509 b (marker-position (cdr value))
510 buf (marker-buffer (car value)))))
511 (save-excursion
512 (set-buffer buf)
513 (save-restriction
514 (widen)
515 (goto-char a)
516 (beginning-of-line)
517 (setq a (1+ (count-lines 1 (point))))
518 (goto-char b)
519 (beginning-of-line)
520 (setq b (1+ (count-lines 1 (point))))))
521 (if (< b a) (setq tmp a a b b tmp))
522 (cons 'SPAN
523 (vector (cons (ash a -16) (logand a 65535))
524 (cons (ash b -16) (logand b 65535))))))))
525
526 (defun select-convert-to-colno (selection type value)
527 (let (a b buf tmp)
528 (cond ((cond ((extentp value)
529 (setq buf (extent-object value)
530 a (extent-start-position value)
531 b (extent-end-position value)))
532 ((and (consp value)
533 (markerp (car value))
534 (markerp (cdr value)))
535 (setq a (car value)
536 b (cdr value)
537 buf (marker-buffer a))))
538 (save-excursion
539 (set-buffer buf)
540 (goto-char a)
541 (setq a (current-column))
542 (goto-char b)
543 (setq b (current-column)))
544 (if (< b a) (setq tmp a a b b tmp))
545 (cons 'SPAN
546 (vector (cons (ash a -16) (logand a 65535))
547 (cons (ash b -16) (logand b 65535))))))))
548
549 (defun select-convert-to-sourceloc (selection type value)
550 (let (a b buf file-name tmp)
551 (cond ((cond ((extentp value)
552 (setq buf (or (extent-object value)
553 (error "selection is in a killed buffer"))
554 a (extent-start-position value)
555 b (extent-end-position value)
556 file-name (buffer-file-name buf)))
557 ((and (consp value)
558 (markerp (car value))
559 (markerp (cdr value)))
560 (setq a (marker-position (car value))
561 b (marker-position (cdr value))
562 buf (or (marker-buffer (car value))
563 (error "selection is in a killed buffer"))
564 file-name (buffer-file-name buf))))
565 (save-excursion
566 (set-buffer buf)
567 (save-restriction
568 (widen)
569 (goto-char a)
570 (beginning-of-line)
571 (setq a (1+ (count-lines 1 (point))))
572 (goto-char b)
573 (beginning-of-line)
574 (setq b (1+ (count-lines 1 (point))))))
575 (if (< b a) (setq tmp a a b b tmp))
576 (format "%s:%d" file-name a)))))
577
578 (defun select-convert-to-os (selection type size)
579 (symbol-name system-type))
580
581 (defun select-convert-to-host (selection type size)
582 (system-name))
583
584 (defun select-convert-to-user (selection type size)
585 (user-full-name))
586
587 (defun select-convert-to-class (selection type size)
588 x-emacs-application-class)
589
590 ;; We do not try to determine the name Emacs was invoked with,
591 ;; because it is not clean for a program's behavior to depend on that.
592 (defun select-convert-to-name (selection type size)
593 ;invocation-name
594 "xemacs")
595
596 (defun select-convert-to-integer (selection type value)
597 (and (integerp value)
598 (cons (ash value -16) (logand value 65535))))
599
600 ;; Can convert from the following integer representations
601 ;;
602 ;; integer
603 ;; (integer . integer)
604 ;; (integer integer)
605 ;; (list [integer|(integer . integer)]*)
606 ;; (vector [integer|(integer . integer)]*)
607 ;;
608 ;; Cons'd integers get cleaned up a little.
609
610 (defun select-convert-from-integer (selection type value)
611 (cond ((integerp value) ; Integer
612 value)
613
614 ((and (consp value) ; (integer . integer)
615 (integerp (car value))
616 (integerp (cdr value)))
617 (if (eq (car value) 0)
618 (cdr value)
619 (if (and (eq (car value) -1)
620 (< (cdr value) 0))
621 (cdr value)
622 value)))
623
624 ((and (listp value) ; (integer integer)
625 (eq (length value) 2)
626 (integerp (car value))
627 (integerp (cadr value)))
628 (if (eq (car value) 0)
629 (cadr value)
630 (if (and (eq (car value) -1)
631 (< (cdr value) 0))
632 (- (cadr value))
633 (cons (car value) (cadr value)))))
634
635 ((listp value) ; list
636 (if (cdr value)
637 (mapcar '(lambda (x)
638 (select-convert-from-integer selection type x))
639 value)
640 (select-convert-from-integer selection type (car value))))
641
642 ((vectorp value) ; vector
643 (if (eq (length value) 1)
644 (select-convert-from-integer selection type (aref value 0))
645 (mapvector '(lambda (x)
646 (select-convert-from-integer selection type x))
647 value)))
648
649 (t nil)
650 ))
651
652 (defun select-convert-to-atom (selection type value)
653 (and (symbolp value) value))
654
655 ;;; CF_xxx conversions
656 (defun select-convert-from-cf-text (selection type value)
657 (replace-in-string (if (string-match "\0" value)
658 (substring value 0 (match-beginning 0))
659 value)
660 "\\(\r\n\\|\n\r\\)" "\n" t))
661
662 (defun select-convert-to-cf-text (selection type value)
663 (let ((text (select-convert-to-text selection type value)))
664 (concat (replace-in-string text "\n" "\r\n" t) "\0")))
665
666 ;;; Appenders
667 (defun select-append-to-text (selection type value1 value2)
668 (let ((text1 (select-convert-to-text selection 'STRING value1))
669 (text2 (select-convert-to-text selection 'STRING value2)))
670 (if (and text1 text2)
671 (concat text1 text2)
672 nil)))
673
674 (defun select-append-to-string (selection type value1 value2)
675 (select-append-to-text selection type value1 value2))
676
677 (defun select-append-to-compound-text (selection type value1 value2)
678 (select-append-to-text selection type value1 value2))
679
680 (defun select-append-to-cf-text (selection type value1 value2)
681 (let ((text1 (select-convert-from-cf-text selection 'CF_TEXT value1))
682 (text2 (select-convert-from-cf-text selection 'CF_TEXT value2)))
683 (if (and text1 text2)
684 (select-convert-to-cf-text selection type (concat text1 text2))
685 nil)))
686
687 (defun select-append-default (selection type value1 value2)
688 ;; This appender gets used if the type is "nil" - i.e. default.
689 ;; It should probably have more cases implemented than it does - e.g.
690 ;; appending numbers to strings, etc...
691 (cond ((and (stringp value1) (stringp value2))
692 (select-append-to-string selection 'STRING value1 value2))
693 (t nil)))
694
695 ;;; Buffer kill handlers
696
697 ;; #### Should this function take the text *out* of the buffer that's
698 ;; being killed? Or should it do what the original code did and just
699 ;; destroy the selection?
700 (defun select-buffer-killed-default (selection type value buffer)
701 ;; This handler gets used if the type is "nil".
702 (cond ((extentp value)
703 (unless (eq (extent-object value) buffer)
704 value))
705 ((markerp value)
706 (unless (eq (marker-buffer value) buffer)
707 value))
708 ((and (consp value)
709 (markerp (car value))
710 (markerp (cdr value)))
711 (unless (or (eq (marker-buffer (car value)) buffer)
712 (eq (marker-buffer (cdr value)) buffer))
713 value))
714 (t value)))
715
716 (defun select-buffer-killed-text (selection type value buffer)
717 (select-buffer-killed-default selection type value buffer))
718
719 ;; Types listed in here can be selections of XEmacs
720 (setq selection-converter-out-alist
721 '((TEXT . select-convert-to-text)
722 (STRING . select-convert-to-string)
723 (COMPOUND_TEXT . select-convert-to-compound-text)
724 (TARGETS . select-convert-to-targets)
725 (LENGTH . select-convert-to-length)
726 (DELETE . select-convert-to-delete)
727 (FILE_NAME . select-convert-to-filename)
728 (CHARACTER_POSITION . select-convert-to-charpos)
729 (SOURCE_LOC . select-convert-to-sourceloc)
730 (LINE_NUMBER . select-convert-to-lineno)
731 (COLUMN_NUMBER . select-convert-to-colno)
732 (OWNER_OS . select-convert-to-os)
733 (HOST_NAME . select-convert-to-host)
734 (USER . select-convert-to-user)
735 (CLASS . select-convert-to-class)
736 (NAME . select-convert-to-name)
737 (ATOM . select-convert-to-atom)
738 (INTEGER . select-convert-to-integer)
739 (CF_TEXT . select-convert-to-cf-text)
740 ))
741
742 ;; Types listed here can be selections foreign to XEmacs
743 (setq selection-converter-in-alist
744 '(; Specific types that get handled by generic converters
745 (COMPOUND_TEXT . select-convert-from-text)
746 (SOURCE_LOC . select-convert-from-text)
747 (OWNER_OS . select-convert-from-text)
748 (HOST_NAME . select-convert-from-text)
749 (USER . select-convert-from-text)
750 (CLASS . select-convert-from-text)
751 (NAME . select-convert-from-text)
752 ; Generic types
753 (INTEGER . select-convert-from-integer)
754 (TEXT . select-convert-from-text)
755 (STRING . select-convert-from-text)
756 (LENGTH . select-convert-from-length)
757 (FILE_NAME . select-convert-from-filename)
758 (CF_TEXT . select-convert-from-cf-text)
759 ))
760
761 ;; Types listed here can be appended by own-selection
762 (setq selection-appender-alist
763 '((nil . select-append-default)
764 (TEXT . select-append-to-text)
765 (STRING . select-append-to-string)
766 (COMPOUND_TEXT . select-append-to-compound-text)
767 (CF_TEXT . select-append-to-cf-text)
768 ))
769
770 ;; Types listed here have buffer-kill handlers
771 (setq selection-buffer-killed-alist
772 '((nil . select-buffer-killed-default)
773 (TEXT . select-buffer-killed-text)
774 (STRING . select-buffer-killed-text)
775 (COMPOUND_TEXT . select-buffer-killed-text)
776 (CF_TEXT . select-buffer-killed-text)))
777
778 ;; Lists of types that are coercible (can be converted to other types)
779 (setq selection-coercible-types '(TEXT STRING COMPOUND_TEXT))
780 293
781 ;;; select.el ends here 294 ;;; select.el ends here