(G-GT-46512): Unify G-GT-46512 instead of A-GT-46512; unify G-UU+8936.
[chise/xemacs-chise.git] / lisp / select.el
1 ;;; select.el --- Lisp interface to windows selections.
2
3 ;; Copyright (C) 1998 Andy Piper.
4 ;; Copyright (C) 1990, 1997 Free Software Foundation, Inc.
5 ;; Copyright (C) 1995 Sun Microsystems.
6
7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: extensions, dumped
9
10 ;; This file is part of XEmacs.
11
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20 ;; General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING.  If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26
27 ;;; Synched up with: Not in FSF
28
29 ;;; Commentary:
30
31 ;; This file is dumped with XEmacs
32
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
48 (defun copy-primary-selection ()
49   "Copy the selection to the Clipboard and the kill ring."
50   (interactive)
51   (and (console-on-window-system-p)
52        (cut-copy-clear-internal 'copy)))
53
54 (defun kill-primary-selection ()
55   "Copy the selection to the Clipboard and the kill ring, then delete it."
56   (interactive "*")
57   (and (console-on-window-system-p)
58        (cut-copy-clear-internal 'cut)))
59
60 (defun delete-primary-selection ()
61   "Delete the selection without copying it to the Clipboard or the kill ring."
62   (interactive "*")
63   (and (console-on-window-system-p)
64        (cut-copy-clear-internal 'clear)))
65
66 (defun yank-clipboard-selection ()
67   "Insert the current Clipboard selection at point."
68   (interactive "*")
69   (when (console-on-window-system-p)
70     (setq last-command nil)
71     (setq this-command 'yank) ; so that yank-pop works.
72     (let ((clip (get-clipboard)))
73       (or clip (error "there is no clipboard selection"))
74       (push-mark)
75       (insert clip))))
76
77 (defun get-clipboard ()
78   "Return text pasted to the clipboard.
79 Not suitable for `interprogram-paste-function', use `get-clipboard-foreign'."
80   (get-selection 'CLIPBOARD))
81
82 (defun get-clipboard-foreign ()
83   "Return text pasted to the clipboard by another program.
84 See `interprogram-paste-function' for more information."
85   (get-selection-foreign 'CLIPBOARD))
86
87 (define-device-method get-cutbuffer
88   "Return the value of one of the cut buffers.
89 This will do nothing under anything other than X.")
90
91 (defun get-selection-no-error (&optional type data-type)
92   "Return the value of a window-system selection.
93 The argument TYPE (default `PRIMARY') says which selection,
94 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
95 says how to convert the data. Returns NIL if there is no selection."
96   (condition-case nil (get-selection type data-type) (t nil)))
97
98 (defun get-selection (&optional type data-type)
99   "Return the value of a window-system selection.
100 The argument TYPE (default `PRIMARY') says which selection,
101 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
102 says how to convert the data. If there is no selection an error is signalled.
103 Not suitable in a `interprogram-paste-function', q.v."
104   (or type (setq type 'PRIMARY))
105   (or data-type (setq data-type selected-text-type))
106   (if (consp data-type)
107       (condition-case err
108           (get-selection-internal type (car data-type))
109         (selection-conversion-error
110          (if (cdr data-type)
111              (get-selection type (cdr data-type))
112            (signal (car err) (cdr err)))))
113     (get-selection-internal type data-type)))
114
115 (defun get-selection-foreign (&optional type data-type)
116   "Return the value of a window-system selection, or nil if XEmacs owns it.
117 The argument TYPE (default `PRIMARY') says which selection,
118 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
119 says how to convert the data. If there is no selection an error is signalled.
120 See `interprogram-paste-function' for more information."
121   (unless (selection-owner-p type)
122     (get-selection type data-type)))
123
124 ;; FSFmacs calls this `x-set-selection', and reverses the
125 ;; first two arguments (duh ...).  This order is more logical.
126 (defun own-selection (data &optional type how-to-add data-type)
127   "Make a window-system selection of type TYPE and value DATA.
128 The argument TYPE (default `PRIMARY') says which selection,
129 and DATA specifies the contents.  DATA may be any lisp data type
130 that can be converted using the function corresponding to DATA-TYPE
131 in `select-converter-alist'---strings are the usual choice, but
132 other types may be permissible depending on the DATA-TYPE parameter
133 (if DATA-TYPE is not supplied, the default behavior is window
134 system specific, but strings are always accepted).
135 HOW-TO-ADD may be any of the following:
136
137   'replace-all or nil -- replace all data in the selection.
138   'replace-existing   -- replace data for specified DATA-TYPE only.
139   'append or t        -- append data to existing DATA-TYPE data.
140
141 DATA-TYPE is the window-system specific data type identifier
142 (see `register-selection-data-type' for more information).
143
144 The selection may also be a cons of two markers pointing to the same buffer,
145 or an overlay.  In these cases, the selection is considered to be the text
146 between the markers *at whatever time the selection is examined* (note
147 that the window system clipboard does not necessarily duplicate this
148 behavior - it doesn't on mswindows for example).
149 Thus, editing done in the buffer after you specify the selection
150 can alter the effective value of the selection.
151
152 The data may also be a vector of valid non-vector selection values.
153
154 Interactively, the text of the region is used as the selection value."
155   (interactive (if (not current-prefix-arg)
156                    (list (read-string "Store text for pasting: "))
157                  (list (substring (region-beginning) (region-end)))))
158   ;; calling own-selection-internal will mess this up, so preserve it.
159   (let ((zmacs-region-stays zmacs-region-stays))
160                                         ;FSFmacs huh??  It says:
161     ;; "This is for temporary compatibility with pre-release Emacs 19."
162                                         ;(if (stringp type)
163                                         ;    (setq type (intern type)))
164     (or type (setq type 'PRIMARY))
165     (if (null data)
166         (disown-selection-internal type)
167       (own-selection-internal type data how-to-add data-type)
168       (when (and (eq type 'PRIMARY)
169                  selection-sets-clipboard)
170          (own-selection-internal 'CLIPBOARD data how-to-add data-type)))
171     (cond ((eq type 'PRIMARY)
172            (setq primary-selection-extent
173                  (select-make-extent-for-selection
174                   data primary-selection-extent)))
175           ((eq type 'SECONDARY)
176            (setq secondary-selection-extent
177                  (select-make-extent-for-selection
178                   data secondary-selection-extent)))))
179   ;; zmacs-region-stays is for commands, not low-level functions.
180   ;; when behaving as the latter, we better not set it, or we will
181   ;; cause unwanted sticky-region behavior in kill-region and friends.
182   (if (interactive-p)
183   (setq zmacs-region-stays t))
184   data)
185
186 (defun dehilight-selection (selection)
187   "for use as a value of `lost-selection-hooks'."
188   (cond ((eq selection 'PRIMARY)
189          (if primary-selection-extent
190              (let ((inhibit-quit t))
191                (if (consp primary-selection-extent)
192                    (mapcar 'delete-extent primary-selection-extent)
193                  (delete-extent primary-selection-extent))
194                (setq primary-selection-extent nil)))
195          (if zmacs-regions (zmacs-deactivate-region)))
196         ((eq selection 'SECONDARY)
197          (if secondary-selection-extent
198              (let ((inhibit-quit t))
199                (if (consp secondary-selection-extent)
200                    (mapcar 'delete-extent secondary-selection-extent)
201                  (delete-extent secondary-selection-extent))
202                (setq secondary-selection-extent nil)))))
203   nil)
204
205 (setq lost-selection-hooks 'dehilight-selection)
206
207 (defun own-clipboard (string &optional push)
208   "Paste the given string to the window system Clipboard.
209 See `interprogram-cut-function' for more information."
210   (own-selection string 'CLIPBOARD))
211
212 (defun disown-selection (&optional secondary-p)
213   "Assuming we own the selection, disown it.
214 With an argument, discard the secondary selection instead of the
215 primary selection."
216   (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY))
217   (when (and selection-sets-clipboard
218              (or (not secondary-p)
219                  (eq secondary-p 'PRIMARY)
220                  (eq secondary-p 'CLIPBOARD)))
221     (disown-selection-internal 'CLIPBOARD)))
222
223 ;; from x-init.el
224 ;; selections and active regions
225
226 ;; If and only if zmacs-regions is true:
227
228 ;; When a mark is pushed and the region goes into the "active" state, we
229 ;; assert it as the Primary selection.  This causes it to be hilighted.
230 ;; When the region goes into the "inactive" state, we disown the Primary
231 ;; selection, causing the region to be dehilighted.
232
233 ;; Note that it is possible for the region to be in the "active" state
234 ;; and not be hilighted, if it is in the active state and then some other
235 ;; application asserts the selection.  This is probably not a big deal.
236
237 (defun activate-region-as-selection ()
238   (if (marker-buffer (mark-marker t))
239       (own-selection (cons (point-marker t) (mark-marker t)))))
240
241 ; moved from x-select.el
242 (defvar primary-selection-extent nil
243   "The extent of the primary selection; don't use this.")
244
245 (defvar secondary-selection-extent nil
246   "The extent of the secondary selection; don't use this.")
247
248 (defun select-make-extent-for-selection (selection previous-extent)
249   ;; Given a selection, this makes an extent in the buffer which holds that
250   ;; selection, for highlighting purposes.  If the selection isn't associated
251   ;; with a buffer, this does nothing.
252   (let ((buffer nil)
253         (valid (and (extentp previous-extent)
254                     (extent-object previous-extent)
255                     (buffer-live-p (extent-object previous-extent))))
256         start end)
257     (cond ((stringp selection)
258            ;; if we're selecting a string, lose the previous extent used
259            ;; to highlight the selection.
260            (setq valid nil))
261           ((consp selection)
262            (setq start (min (car selection) (cdr selection))
263                  end (max (car selection) (cdr selection))
264                  valid (and valid
265                             (eq (marker-buffer (car selection))
266                                 (extent-object previous-extent)))
267                  buffer (marker-buffer (car selection))))
268           ((extentp selection)
269            (setq start (extent-start-position selection)
270                  end (extent-end-position selection)
271                  valid (and valid
272                             (eq (extent-object selection)
273                                 (extent-object previous-extent)))
274                  buffer (extent-object selection)))
275           (t
276            (signal 'error (list "invalid selection" selection))))
277
278     (if valid
279         nil
280       (condition-case ()
281           (if (listp previous-extent)
282               (mapcar 'delete-extent previous-extent)
283             (delete-extent previous-extent))
284         (error nil)))
285
286     (if (not buffer)
287         ;; string case
288         nil
289       ;; normal case
290       (if valid
291           (set-extent-endpoints previous-extent start end)
292         (setq previous-extent (make-extent start end buffer))
293
294         ;; Make the extent be closed on the right, which means that if
295         ;; characters are inserted exactly at the end of the extent, the
296         ;; extent will grow to cover them.  This is important for shell
297         ;; buffers - suppose one makes a selection, and one end is at
298         ;; point-max.  If the shell produces output, that marker will remain
299         ;; at point-max (its position will increase).  So it's important that
300         ;; the extent exhibit the same behavior, lest the region covered by
301         ;; the extent (the visual indication), and the region between point
302         ;; and mark (the actual selection value) become different!
303         (set-extent-property previous-extent 'end-open nil)
304
305         (cond
306          (mouse-track-rectangle-p
307           (setq previous-extent (list previous-extent))
308           (default-mouse-track-next-move-rect start end previous-extent)
309           ))
310         previous-extent))))
311
312 ;; moved from x-select.el
313 (defun valid-simple-selection-p (data)
314   "An obsolete function that tests whether something was a valid simple
315 selection using the old XEmacs selection support. You shouldn't use this
316 any more, because just about anything could be a valid selection now."
317   (or (stringp data)
318       ;FSFmacs huh?? (symbolp data)
319       (integerp data)
320       (and (consp data)
321            (integerp (car data))
322            (or (integerp (cdr data))
323                (and (consp (cdr data))
324                     (integerp (car (cdr data))))))
325       (extentp data)
326       (and (consp data)
327            (markerp (car data))
328            (markerp (cdr data))
329            (marker-buffer (car data))
330            (marker-buffer (cdr data))
331            (eq (marker-buffer (car data))
332                (marker-buffer (cdr data)))
333            (buffer-live-p (marker-buffer (car data)))
334            (buffer-live-p (marker-buffer (cdr data))))))
335
336 (defun cut-copy-clear-internal (mode)
337   (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
338   (or (selection-owner-p)
339       (error "XEmacs does not own the primary selection"))
340   (setq last-command nil)
341   (or primary-selection-extent
342       (error "the primary selection is not an extent?"))
343   (save-excursion
344     (let (rect-p b s e)
345       (cond
346        ((consp primary-selection-extent)
347         (setq rect-p t
348               b (extent-object (car primary-selection-extent))
349               s (extent-start-position (car primary-selection-extent))
350               e (extent-end-position (car (reverse primary-selection-extent)))))
351        (t
352         (setq rect-p nil
353               b (extent-object primary-selection-extent)
354               s (extent-start-position primary-selection-extent)
355               e (extent-end-position primary-selection-extent))))
356       (set-buffer b)
357       (cond ((memq mode '(cut copy))
358              (if rect-p
359                  (progn
360                    ;; why is killed-rectangle free?  Is it used somewhere?
361                    ;; should it be defvarred?
362                    (setq killed-rectangle (extract-rectangle s e))
363                    (kill-new (mapconcat #'identity killed-rectangle "\n")))
364                (copy-region-as-kill s e))
365              ;; Maybe killing doesn't own clipboard.  Make sure it happens.
366              ;; This memq is kind of grody, because they might have done it
367              ;; some other way, but owning the clipboard twice in that case
368              ;; wouldn't actually hurt anything.
369              (or (and (consp kill-hooks) (memq 'own-clipboard kill-hooks))
370                  (own-clipboard (car kill-ring)))))
371       (cond ((memq mode '(cut clear))
372              (if rect-p
373                  (delete-rectangle s e)
374                (delete-region s e))))
375       (disown-selection nil)
376       )))
377
378 \f
379 ;;; Functions to convert the selection into various other selection
380 ;;; types.
381
382 ;; These next three functions get called by C code...
383 (defun select-convert-in (selection type value)
384   "Attempt to convert the specified external VALUE to the specified DATA-TYPE,
385 for the specified SELECTION. Return nil if this is impossible, or a
386 suitable internal representation otherwise."
387   (when value
388     (let ((handler-fn (cdr (assq type selection-converter-in-alist))))
389       (when handler-fn
390         (apply handler-fn (list selection type value))))))
391
392 (defun select-convert-out (selection type value)
393   "Attempt to convert the specified internal VALUE for the specified DATA-TYPE
394 and SELECTION. Return nil if this is impossible, or a suitable external
395 representation otherwise."
396   (when value
397     (let ((handler-fn (cdr (assq type selection-converter-out-alist))))
398       (when handler-fn
399         (apply handler-fn (list selection type value))))))
400
401 (defun select-coerce (selection type value)
402   "Attempt to convert the specified internal VALUE to a representation
403 suitable for return from `get-selection' in the specified DATA-TYPE. Return
404 nil if this is impossible, or a suitable representation otherwise."
405   (when value
406     (let ((handler-fn (cdr (assq type selection-coercion-alist))))
407       (when handler-fn
408         (apply handler-fn (list selection type value))))))
409
410 ;; The rest of the functions on this "page" are conversion handlers,
411 ;; append handlers and buffer-kill handlers.
412 (defun select-convert-to-text (selection type value)
413   (cond ((stringp value)
414          value)
415         ((extentp value)
416          (save-excursion
417            (set-buffer (extent-object value))
418            (save-restriction
419              (widen)
420              (buffer-substring (extent-start-position value)
421                                (extent-end-position value)))))
422         ((and (consp value)
423               (markerp (car value))
424               (markerp (cdr value)))
425          (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
426              (signal 'error
427                      (list "markers must be in the same buffer"
428                            (car value) (cdr value))))
429          (save-excursion
430            (set-buffer (or (marker-buffer (car value))
431                            (error "selection is in a killed buffer")))
432            (save-restriction
433              (widen)
434              (buffer-substring (car value) (cdr value)))))
435         (t nil)))
436
437 (defun select-coerce-to-text (selection type value)
438   (select-convert-to-text selection type value))
439
440 (defun select-convert-from-text (selection type value)
441   (when (stringp value)
442     value))
443
444 (defun select-convert-to-string (selection type value)
445   (let ((outval (select-convert-to-text selection type value)))
446     ;; force the string to be not in Compound Text format. This grubby
447     ;; hack will go soon, to be replaced by a more general mechanism.
448     (if (stringp outval)
449         (cons 'STRING outval)
450       outval)))
451
452 (defun select-convert-to-compound-text (selection type value)
453   ;; converts to compound text automatically
454   (select-convert-to-text selection type value))
455
456 (defun select-convert-to-length (selection type value)
457   (let ((value
458          (cond ((stringp value)
459                 (length value))
460                ((extentp value)
461                 (extent-length value))
462                ((and (consp value)
463                      (markerp (car value))
464                      (markerp (cdr value)))
465                 (or (eq (marker-buffer (car value))
466                         (marker-buffer (cdr value)))
467                     (signal 'error
468                             (list "markers must be in the same buffer"
469                                   (car value) (cdr value))))
470                 (abs (- (car value) (cdr value)))))))
471     (if value ; force it to be in 32-bit format.
472         (cons (ash value -16) (logand value 65535))
473       nil)))
474
475 (defun select-convert-from-length (selection type value)
476   (select-convert-to-length selection type value))
477
478 (defun select-convert-to-targets (selection type value)
479   ;; return a vector of atoms, but remove duplicates first.
480   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
481          (rest all))
482     (while rest
483       (cond ((memq (car rest) (cdr rest))
484              (setcdr rest (delq (car rest) (cdr rest))))
485             (t
486              (setq rest (cdr rest)))))
487     (apply 'vector all)))
488
489 (defun select-convert-to-delete (selection type value)
490   (disown-selection-internal selection)
491   ;; A return value of nil means that we do not know how to do this conversion,
492   ;; and replies with an "error".  A return value of NULL means that we have
493   ;; done the conversion (and any side-effects) but have no value to return.
494   'NULL)
495
496 (defun select-convert-to-filename (selection type value)
497   (cond ((extentp value)
498          (buffer-file-name (or (extent-object value)
499                                (error "selection is in a killed buffer"))))
500         ((and (consp value)
501               (markerp (car value))
502               (markerp (cdr value)))
503          (buffer-file-name (or (marker-buffer (car value))
504                                (error "selection is in a killed buffer"))))
505         (t nil)))
506
507 (defun select-convert-from-filename (selection type value)
508   (when (stringp value)
509     value))
510
511 (defun select-convert-to-charpos (selection type value)
512   (let (a b tmp)
513     (cond ((cond ((extentp value)
514                   (setq a (extent-start-position value)
515                         b (extent-end-position value)))
516                  ((and (consp value)
517                        (markerp (car value))
518                        (markerp (cdr value)))
519                   (setq a (car value)
520                         b (cdr value))))
521            (setq a (1- a) b (1- b)) ; zero-based
522            (if (< b a) (setq tmp a a b b tmp))
523            (cons 'SPAN
524                  (vector (cons (ash a -16) (logand a 65535))
525                          (cons (ash b -16) (logand b 65535))))))))
526
527 (defun select-convert-to-lineno (selection type value)
528   (let (a b buf tmp)
529     (cond ((cond ((extentp value)
530                   (setq buf (extent-object value)
531                         a (extent-start-position value)
532                         b (extent-end-position value)))
533                  ((and (consp value)
534                        (markerp (car value))
535                        (markerp (cdr value)))
536                   (setq a (marker-position (car value))
537                         b (marker-position (cdr value))
538                         buf (marker-buffer (car value)))))
539            (save-excursion
540              (set-buffer buf)
541              (save-restriction
542                (widen)
543                (goto-char a)
544                (beginning-of-line)
545                (setq a (1+ (count-lines 1 (point))))
546                (goto-char b)
547                (beginning-of-line)
548                (setq b (1+ (count-lines 1 (point))))))
549            (if (< b a) (setq tmp a a b b tmp))
550            (cons 'SPAN
551                  (vector (cons (ash a -16) (logand a 65535))
552                          (cons (ash b -16) (logand b 65535))))))))
553
554 (defun select-convert-to-colno (selection type value)
555   (let (a b buf tmp)
556     (cond ((cond ((extentp value)
557                   (setq buf (extent-object value)
558                         a (extent-start-position value)
559                         b (extent-end-position value)))
560                  ((and (consp value)
561                        (markerp (car value))
562                        (markerp (cdr value)))
563                   (setq a (car value)
564                         b (cdr value)
565                         buf (marker-buffer a))))
566            (save-excursion
567              (set-buffer buf)
568              (goto-char a)
569              (setq a (current-column))
570              (goto-char b)
571              (setq b (current-column)))
572            (if (< b a) (setq tmp a a b b tmp))
573            (cons 'SPAN
574                  (vector (cons (ash a -16) (logand a 65535))
575                          (cons (ash b -16) (logand b 65535))))))))
576
577 (defun select-convert-to-sourceloc (selection type value)
578   (let (a b buf file-name tmp)
579     (cond ((cond ((extentp value)
580                   (setq buf (or (extent-object value)
581                                 (error "selection is in a killed buffer"))
582                         a (extent-start-position value)
583                         b (extent-end-position value)
584                         file-name (buffer-file-name buf)))
585                  ((and (consp value)
586                        (markerp (car value))
587                        (markerp (cdr value)))
588                   (setq a (marker-position (car value))
589                         b (marker-position (cdr value))
590                         buf (or (marker-buffer (car value))
591                                 (error "selection is in a killed buffer"))
592                         file-name (buffer-file-name buf))))
593            (save-excursion
594              (set-buffer buf)
595              (save-restriction
596                (widen)
597                (goto-char a)
598                (beginning-of-line)
599                (setq a (1+ (count-lines 1 (point))))
600                (goto-char b)
601                (beginning-of-line)
602                (setq b (1+ (count-lines 1 (point))))))
603            (if (< b a) (setq tmp a a b b tmp))
604            (format "%s:%d" file-name a)))))
605
606 (defun select-convert-to-os (selection type size)
607   (symbol-name system-type))
608
609 (defun select-convert-to-host (selection type size)
610   (system-name))
611
612 (defun select-convert-to-user (selection type size)
613   (user-full-name))
614
615 (defun select-convert-to-class (selection type size)
616   (symbol-value 'x-emacs-application-class))
617
618 ;; We do not try to determine the name Emacs was invoked with,
619 ;; because it is not clean for a program's behavior to depend on that.
620 (defun select-convert-to-name (selection type size)
621   ;invocation-name
622   "xemacs")
623
624 (defun select-convert-to-integer (selection type value)
625   (and (integerp value)
626        (cons (ash value -16) (logand value 65535))))
627
628 ;; Can convert from the following integer representations
629 ;;
630 ;;    integer
631 ;;    (integer . integer)
632 ;;    (integer integer)
633 ;;    (list [integer|(integer . integer)]*)
634 ;;    (vector [integer|(integer . integer)]*)
635 ;;
636 ;; Cons'd integers get cleaned up a little.
637
638 (defun select-convert-from-integer (selection type value)
639   (cond ((integerp value)               ; Integer
640          value)
641
642         ((and (consp value)             ; (integer . integer)
643               (integerp (car value))
644               (integerp (cdr value)))
645          (if (eq (car value) 0)
646              (cdr value)
647            (if (and (eq (car value) -1)
648                     (< (cdr value) 0))
649                (cdr value)
650              value)))
651
652         ((and (listp value)             ; (integer integer)
653               (eq (length value) 2)
654               (integerp (car value))
655               (integerp (cadr value)))
656          (if (eq (car value) 0)
657              (cadr value)
658            (if (and (eq (car value) -1)
659                     (< (cdr value) 0))
660                (- (cadr value))
661              (cons (car value) (cadr value)))))
662
663         ((listp value)                  ; list
664          (if (cdr value)
665              (mapcar '(lambda (x)
666                         (select-convert-from-integer selection type x))
667                      value)
668            (select-convert-from-integer selection type (car value))))
669
670         ((vectorp value)                ; vector
671          (if (eq (length value) 1)
672              (select-convert-from-integer selection type (aref value 0))
673            (mapvector '(lambda (x)
674                         (select-convert-from-integer selection type x))
675                      value)))
676
677         (t nil)
678         ))
679
680 (defun select-convert-to-atom (selection type value)
681   (and (symbolp value) value))
682
683 ;;; CF_xxx conversions
684 (defun select-convert-from-cf-text (selection type value)
685   (replace-in-string (if (string-match "\0" value)
686                          (substring value 0 (match-beginning 0))
687                        value)
688                      "\\(\r\n\\|\n\r\\)" "\n" t))
689
690 (defun select-convert-to-cf-text (selection type value)
691   (let ((text (select-convert-to-text selection type value)))
692     (concat (replace-in-string text "\n" "\r\n" t) "\0")))
693
694 ;;; Appenders
695 (defun select-append-to-text (selection type value1 value2)
696   (let ((text1 (select-convert-to-text selection 'STRING value1))
697         (text2 (select-convert-to-text selection 'STRING value2)))
698     (if (and text1 text2)
699         (concat text1 text2)
700       nil)))
701
702 (defun select-append-to-string (selection type value1 value2)
703   (select-append-to-text selection type value1 value2))
704
705 (defun select-append-to-compound-text (selection type value1 value2)
706   (select-append-to-text selection type value1 value2))
707
708 (defun select-append-to-cf-text (selection type value1 value2)
709   (let ((text1 (select-convert-from-cf-text selection 'CF_TEXT value1))
710         (text2 (select-convert-from-cf-text selection 'CF_TEXT value2)))
711     (if (and text1 text2)
712         (select-convert-to-cf-text selection type (concat text1 text2))
713       nil)))
714
715 (defun select-append-default (selection type value1 value2)
716 ;; This appender gets used if the type is "nil" - i.e. default.
717 ;; It should probably have more cases implemented than it does - e.g.
718 ;; appending numbers to strings, etc...
719   (cond ((and (stringp value1) (stringp value2))
720          (select-append-to-string selection 'STRING value1 value2))
721         (t nil)))
722
723 ;;; Buffer kill handlers
724
725 (defun select-buffer-killed-default (selection type value buffer)
726 ;; This handler gets used if the type is "nil".
727   (cond ((extentp value)
728          (if (eq (extent-object value) buffer)
729              ; If this selection is on the clipboard, grab it quick
730              (when (eq selection 'CLIPBOARD)
731                (save-excursion
732                  (set-buffer (extent-object value))
733                  (save-restriction
734                   (widen)
735                   (buffer-substring (extent-start-position value)
736                                     (extent-end-position value)))))
737            value))
738         ((markerp value)
739          (unless (eq (marker-buffer value) buffer)
740            value))
741         ((and (consp value)
742               (markerp (car value))
743               (markerp (cdr value)))
744          (if (or (eq (marker-buffer (car value)) buffer)
745                  (eq (marker-buffer (cdr value)) buffer))
746              ; If this selection is on the clipboard, grab it quick
747              (when (eq selection 'CLIPBOARD)
748                (save-excursion
749                  (set-buffer (marker-buffer (car value)))
750                  (save-restriction
751                    (widen)
752                    (buffer-substring (car value) (cdr value)))))
753              value))
754         (t value)))
755
756 (defun select-buffer-killed-text (selection type value buffer)
757   (select-buffer-killed-default selection type value buffer))
758
759 ;; Types listed in here can be selections of XEmacs
760 (setq selection-converter-out-alist
761       '((TEXT . select-convert-to-text)
762         (STRING . select-convert-to-string)
763         (COMPOUND_TEXT . select-convert-to-compound-text)
764         (TARGETS . select-convert-to-targets)
765         (LENGTH . select-convert-to-length)
766         (DELETE . select-convert-to-delete)
767         (FILE_NAME . select-convert-to-filename)
768         (CHARACTER_POSITION . select-convert-to-charpos)
769         (SOURCE_LOC . select-convert-to-sourceloc)
770         (LINE_NUMBER . select-convert-to-lineno)
771         (COLUMN_NUMBER . select-convert-to-colno)
772         (OWNER_OS . select-convert-to-os)
773         (HOST_NAME . select-convert-to-host)
774         (USER . select-convert-to-user)
775         (CLASS . select-convert-to-class)
776         (NAME . select-convert-to-name)
777         (ATOM . select-convert-to-atom)
778         (INTEGER . select-convert-to-integer)
779         (CF_TEXT . select-convert-to-cf-text)
780         ))
781
782 ;; Types listed here can be selections foreign to XEmacs
783 (setq selection-converter-in-alist
784       '(; Specific types that get handled by generic converters
785         (COMPOUND_TEXT . select-convert-from-text)
786         (SOURCE_LOC . select-convert-from-text)
787         (OWNER_OS . select-convert-from-text)
788         (HOST_NAME . select-convert-from-text)
789         (USER . select-convert-from-text)
790         (CLASS . select-convert-from-text)
791         (NAME . select-convert-from-text)
792         ; Generic types
793         (INTEGER . select-convert-from-integer)
794         (TEXT . select-convert-from-text)
795         (STRING . select-convert-from-text)
796         (LENGTH . select-convert-from-length)
797         (FILE_NAME . select-convert-from-filename)
798         (CF_TEXT . select-convert-from-cf-text)
799         ))
800
801 ;; Types listed here have special coercion functions that can munge
802 ;; other types. This can also be used to add special features - e.g.
803 ;; being able to pass a region or a cons of markers to own-selection,
804 ;; but getting the *current* text in the region back when calling
805 ;; get-selection.
806 ;;
807 ;; Any function listed in here *will be called* whenever a value of
808 ;; its type is retrieved from the internal selection cache, or when
809 ;; no suitable values could be found in which case XEmacs looks for
810 ;; values with types listed in selection-coercible-types.
811 (setq selection-coercion-alist
812       '((TEXT . select-coerce-to-text)
813         (STRING . select-coerce-to-text)
814         (COMPOUND_TEXT . select-coerce-to-text)
815         (CF_TEXT . select-coerce-to-text)))
816
817 ;; Types listed here can be appended by own-selection
818 (setq selection-appender-alist
819       '((nil . select-append-default)
820         (TEXT . select-append-to-text)
821         (STRING . select-append-to-string)
822         (COMPOUND_TEXT . select-append-to-compound-text)
823         (CF_TEXT . select-append-to-cf-text)
824         ))
825
826 ;; Types listed here have buffer-kill handlers
827 (setq selection-buffer-killed-alist
828       '((nil . select-buffer-killed-default)
829         (TEXT . select-buffer-killed-text)
830         (STRING . select-buffer-killed-text)
831         (COMPOUND_TEXT . select-buffer-killed-text)
832         (CF_TEXT . select-buffer-killed-text)))
833
834 ;; Lists of types that are coercible (can be converted to other types)
835 (setq selection-coercible-types '(TEXT STRING COMPOUND_TEXT))
836
837 ;;; select.el ends here