update.
[chise/xemacs-chise.git-] / src / select-gtk.c
1 /* GTK selection processing for XEmacs
2    Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
3
4 This file is part of XEmacs.
5
6 XEmacs is free software; you can redistribute it and/or modify it
7 under the terms of the GNU General Public License as published by the
8 Free Software Foundation; either version 2, or (at your option) any
9 later version.
10
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
14 for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with XEmacs; see the file COPYING.  If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA.  */
20
21 /* Synched up with: Not synched with FSF. */
22
23 /* Authorship:
24
25    Written by Kevin Gallo for FSF Emacs.
26    Rewritten for mswindows by Jonathan Harris, December 1997 for 21.0.
27    Rewritten for GTK by William Perry, April 2000 for 21.1
28  */
29
30
31 #include <config.h>
32 #include "lisp.h"
33 #include "events.h"
34 #include "buffer.h"
35 #include "device.h"
36 #include "console-gtk.h"
37 #include "select.h"
38 #include "opaque.h"
39 #include "frame.h"
40
41 int lisp_to_time (Lisp_Object, time_t *);
42 static Lisp_Object Vretrieved_selection;
43 static gboolean waiting_for_selection;
44 Lisp_Object Vgtk_sent_selection_hooks;
45
46 static Lisp_Object atom_to_symbol (struct device *d, GdkAtom atom);
47 static GdkAtom symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists);
48
49 static void lisp_data_to_selection_data (struct device *,
50                                          Lisp_Object obj,
51                                          unsigned char **data_ret,
52                                          GdkAtom *type_ret,
53                                          unsigned int *size_ret,
54                                          int *format_ret);
55 static Lisp_Object selection_data_to_lisp_data (struct device *,
56                                                 Extbyte *data,
57                                                 size_t size,
58                                                 GdkAtom type,
59                                                 int format);
60
61 /* Set the selection data to GDK_NONE and NULL data, meaning we were
62 ** unable to do what they wanted.
63 */
64 static void
65 gtk_decline_selection_request (GtkSelectionData *data)
66 {
67   gtk_selection_data_set (data, GDK_NONE, 0, NULL, 0);
68 }
69
70 /* Used as an unwind-protect clause so that, if a selection-converter signals
71    an error, we tell the requestor that we were unable to do what they wanted
72    before we throw to top-level or go into the debugger or whatever.
73  */
74 struct _selection_closure
75 {
76   GtkSelectionData *data;
77   gboolean successful;
78 };
79
80 static Lisp_Object
81 gtk_selection_request_lisp_error (Lisp_Object closure)
82 {
83   struct _selection_closure *cl = (struct _selection_closure *)
84     get_opaque_ptr (closure);
85
86   free_opaque_ptr (closure);
87   if (cl->successful == TRUE)
88     return Qnil;
89   gtk_decline_selection_request (cl->data);
90   return Qnil;
91 }
92
93 /* This provides the current selection to a requester.
94 **
95 ** This is connected to the selection_get() signal of the application
96 ** shell in device-gtk.c:gtk_init_device().
97 **
98 ** This is radically different than the old selection code (21.1.x),
99 ** but has been modeled after the X code, and appears to work.
100 **
101 ** WMP Feb 12 2001
102 */
103 void
104 emacs_gtk_selection_handle (GtkWidget *widget,
105                             GtkSelectionData *selection_data,
106                             guint info,
107                             guint time_stamp,
108                             gpointer data)
109 {
110   /* This function can GC */
111   struct gcpro gcpro1, gcpro2;
112   Lisp_Object temp_obj;
113   Lisp_Object selection_symbol;
114   Lisp_Object target_symbol = Qnil;
115   Lisp_Object converted_selection = Qnil;
116   guint32 local_selection_time;
117   Lisp_Object successful_p = Qnil;
118   int count;
119   struct device *d = decode_gtk_device (Qnil);
120   struct _selection_closure *cl = NULL;
121
122   GCPRO2 (converted_selection, target_symbol);
123
124   selection_symbol = atom_to_symbol (d, selection_data->selection);
125   target_symbol = atom_to_symbol (d, selection_data->target);
126
127 #if 0 /* #### MULTIPLE doesn't work yet */
128   if (EQ (target_symbol, QMULTIPLE))
129     target_symbol = fetch_multiple_target (selection_data);
130 #endif
131
132   temp_obj = Fget_selection_timestamp (selection_symbol);
133
134   if (NILP (temp_obj))
135     {
136       /* We don't appear to have the selection. */
137       gtk_decline_selection_request (selection_data);
138
139       goto DONE_LABEL;
140     }
141
142   local_selection_time = * (guint32 *) XOPAQUE_DATA (temp_obj);
143
144   if (time_stamp != GDK_CURRENT_TIME &&
145       local_selection_time > time_stamp)
146     {
147       /* Someone asked for the selection, and we have one, but not the one
148          they're looking for. */
149       gtk_decline_selection_request (selection_data);
150       goto DONE_LABEL;
151     }
152
153   converted_selection = select_convert_out (selection_symbol,
154                                             target_symbol, Qnil);
155
156   /* #### Is this the right thing to do? I'm no X expert. -- ajh */
157   if (NILP (converted_selection))
158     {
159       /* We don't appear to have a selection in that data type. */
160       gtk_decline_selection_request (selection_data);
161       goto DONE_LABEL;
162     }
163
164   count = specpdl_depth ();
165
166   cl = (struct _selection_closure *) xmalloc (sizeof (*cl));
167   cl->data = selection_data;
168   cl->successful = FALSE;
169
170   record_unwind_protect (gtk_selection_request_lisp_error,
171                          make_opaque_ptr (cl));
172
173   {
174     unsigned char *data;
175     unsigned int size;
176     int format;
177     GdkAtom type;
178     lisp_data_to_selection_data (d, converted_selection,
179                                  &data, &type, &size, &format);
180
181     gtk_selection_data_set (selection_data, type, format, data, size);
182     successful_p = Qt;
183     /* Tell x_selection_request_lisp_error() it's cool. */
184     cl->successful = TRUE;
185     xfree (data);
186   }
187
188   unbind_to (count, Qnil);
189
190  DONE_LABEL:
191
192   if (cl) xfree (cl);
193
194   UNGCPRO;
195
196   /* Let random lisp code notice that the selection has been asked for. */
197   {
198     Lisp_Object val = Vgtk_sent_selection_hooks;
199     if (!UNBOUNDP (val) && !NILP (val))
200       {
201         Lisp_Object rest;
202         if (CONSP (val) && !EQ (XCAR (val), Qlambda))
203           for (rest = val; !NILP (rest); rest = Fcdr (rest))
204             call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
205         else
206           call3 (val, selection_symbol, target_symbol, successful_p);
207       }
208   }
209 }
210
211
212 void
213 emacs_gtk_selection_clear_event_handle (GtkWidget *widget,
214                                         GdkEventSelection *event,
215                                         gpointer data)
216 {
217   GdkAtom selection = event->selection;
218   guint32 changed_owner_time = event->time;
219   struct device *d = decode_gtk_device (Qnil);
220
221   Lisp_Object selection_symbol, local_selection_time_lisp;
222   guint32 local_selection_time;
223
224   selection_symbol = atom_to_symbol (d, selection);
225
226   local_selection_time_lisp = Fget_selection_timestamp (selection_symbol);
227
228   /* We don't own the selection, so that's fine. */
229   if (NILP (local_selection_time_lisp))
230     return;
231
232   local_selection_time = *(guint32 *) XOPAQUE_DATA (local_selection_time_lisp);
233
234   /* This SelectionClear is for a selection that we no longer own, so we can
235      disregard it.  (That is, we have reasserted the selection since this
236      request was generated.)
237    */
238   if (changed_owner_time != GDK_CURRENT_TIME &&
239       local_selection_time > changed_owner_time)
240     return;
241
242   handle_selection_clear (selection_symbol);
243 }
244
245
246 \f
247 static GtkWidget *reading_selection_reply;
248 static GdkAtom reading_which_selection;
249 static int selection_reply_timed_out;
250
251 /* Gets the current selection owned by another application */
252 void
253 emacs_gtk_selection_received (GtkWidget *widget,
254                               GtkSelectionData *selection_data,
255                               gpointer user_data)
256 {
257   waiting_for_selection = FALSE;
258   Vretrieved_selection = Qnil;
259
260   reading_selection_reply = NULL;
261
262   signal_fake_event ();
263
264   if (selection_data->length < 0)
265     {
266       return;
267     }
268
269   Vretrieved_selection =
270     selection_data_to_lisp_data (NULL,
271                                  selection_data->data,
272                                  selection_data->length,
273                                  selection_data->type,
274                                  selection_data->format);
275 }
276
277 static int
278 selection_reply_done (void *ignore)
279 {
280   return !reading_selection_reply;
281 }
282
283 /* Do protocol to read selection-data from the server.
284    Converts this to lisp data and returns it.
285  */
286 static Lisp_Object
287 gtk_get_foreign_selection (Lisp_Object selection_symbol,
288                            Lisp_Object target_type)
289 {
290   /* This function can GC */
291   struct device *d = decode_gtk_device (Qnil);
292   GtkWidget *requestor = DEVICE_GTK_APP_SHELL (d);
293   guint32 requestor_time = DEVICE_GTK_MOUSE_TIMESTAMP (d);
294   GdkAtom selection_atom = symbol_to_gtk_atom (d, selection_symbol, 0);
295   int speccount;
296   GdkAtom type_atom = symbol_to_gtk_atom (d, (CONSP (target_type) ?
297                                               XCAR (target_type) : target_type), 0);
298
299   gtk_selection_convert (requestor, selection_atom, type_atom,
300                          requestor_time);
301
302   signal_fake_event ();
303
304   /* Block until the reply has been read. */
305   reading_selection_reply = requestor;
306   reading_which_selection = selection_atom;
307   selection_reply_timed_out = 0;
308
309   speccount = specpdl_depth ();
310
311 #if 0
312   /* add a timeout handler */
313   if (gtk_selection_timeout > 0)
314     {
315       Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout),
316                                      Qx_selection_reply_timeout_internal,
317                                      Qnil, Qnil);
318       record_unwind_protect (Fdisable_timeout, id);
319     }
320 #endif
321
322   /* This is ^Gable */
323   wait_delaying_user_input (selection_reply_done, 0);
324
325   if (selection_reply_timed_out)
326     error ("timed out waiting for reply from selection owner");
327
328   unbind_to (speccount, Qnil);
329
330   /* otherwise, the selection is waiting for us on the requested property. */
331   return select_convert_in (selection_symbol,
332                             target_type,
333                             Vretrieved_selection);
334 }
335
336
337 #if 0
338 static void
339 gtk_get_window_property (struct device *d, GtkWidget *window, GdkAtom property,
340                          Extbyte **data_ret, int *bytes_ret,
341                          GdkAtom *actual_type_ret, int *actual_format_ret,
342                          unsigned long *actual_size_ret, int delete_p)
343 {
344   size_t total_size;
345   unsigned long bytes_remaining;
346   int offset = 0;
347   unsigned char *tmp_data = 0;
348   int result;
349   int buffer_size = SELECTION_QUANTUM (display);
350   if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
351
352   /* First probe the thing to find out how big it is. */
353   result = XGetWindowProperty (display, window, property,
354                                0, 0, False, AnyPropertyType,
355                                actual_type_ret, actual_format_ret,
356                                actual_size_ret,
357                                &bytes_remaining, &tmp_data);
358   if (result != Success)
359     {
360       *data_ret = 0;
361       *bytes_ret = 0;
362       return;
363     }
364   XFree ((char *) tmp_data);
365
366   if (*actual_type_ret == None || *actual_format_ret == 0)
367     {
368       if (delete_p) XDeleteProperty (display, window, property);
369       *data_ret = 0;
370       *bytes_ret = 0;
371       return;
372     }
373
374   total_size = bytes_remaining + 1;
375   *data_ret = (Extbyte *) xmalloc (total_size);
376
377   /* Now read, until we've gotten it all. */
378   while (bytes_remaining)
379     {
380 #if 0
381       int last = bytes_remaining;
382 #endif
383       result =
384         XGetWindowProperty (display, window, property,
385                             offset/4, buffer_size/4,
386                             (delete_p ? True : False),
387                             AnyPropertyType,
388                             actual_type_ret, actual_format_ret,
389                             actual_size_ret, &bytes_remaining, &tmp_data);
390 #if 0
391       stderr_out ("<< read %d\n", last-bytes_remaining);
392 #endif
393       /* If this doesn't return Success at this point, it means that
394          some clod deleted the selection while we were in the midst of
395          reading it.  Deal with that, I guess....
396        */
397       if (result != Success) break;
398       *actual_size_ret *= *actual_format_ret / 8;
399       memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
400       offset += *actual_size_ret;
401       XFree ((char *) tmp_data);
402     }
403   *bytes_ret = offset;
404 }
405
406
407 static void
408 receive_incremental_selection (Display *display, Window window, Atom property,
409                                /* this one is for error messages only */
410                                Lisp_Object target_type,
411                                unsigned int min_size_bytes,
412                                Extbyte **data_ret, int *size_bytes_ret,
413                                Atom *type_ret, int *format_ret,
414                                unsigned long *size_ret)
415 {
416   /* This function can GC */
417   int offset = 0;
418   int prop_id;
419   *size_bytes_ret = min_size_bytes;
420   *data_ret = (Extbyte *) xmalloc (*size_bytes_ret);
421 #if 0
422   stderr_out ("\nread INCR %d\n", min_size_bytes);
423 #endif
424   /* At this point, we have read an INCR property, and deleted it (which
425      is how we ack its receipt: the sending window will be selecting
426      PropertyNotify events on our window to notice this).
427
428      Now, we must loop, waiting for the sending window to put a value on
429      that property, then reading the property, then deleting it to ack.
430      We are done when the sender places a property of length 0.
431    */
432   prop_id = expect_property_change (display, window, property,
433                                     PropertyNewValue);
434   while (1)
435     {
436       Extbyte *tmp_data;
437       int tmp_size_bytes;
438       wait_for_property_change (prop_id);
439       /* expect it again immediately, because x_get_window_property may
440          .. no it won't, I don't get it.
441          .. Ok, I get it now, the Xt code that implements INCR is broken.
442        */
443       prop_id = expect_property_change (display, window, property,
444                                         PropertyNewValue);
445       x_get_window_property (display, window, property,
446                              &tmp_data, &tmp_size_bytes,
447                              type_ret, format_ret, size_ret, 1);
448
449       if (tmp_size_bytes == 0) /* we're done */
450         {
451 #if 0
452           stderr_out ("  read INCR done\n");
453 #endif
454           unexpect_property_change (prop_id);
455           if (tmp_data) xfree (tmp_data);
456           break;
457         }
458 #if 0
459       stderr_out ("  read INCR %d\n", tmp_size_bytes);
460 #endif
461       if (*size_bytes_ret < offset + tmp_size_bytes)
462         {
463 #if 0
464           stderr_out ("  read INCR realloc %d -> %d\n",
465                    *size_bytes_ret, offset + tmp_size_bytes);
466 #endif
467           *size_bytes_ret = offset + tmp_size_bytes;
468           *data_ret = (Extbyte *) xrealloc (*data_ret, *size_bytes_ret);
469         }
470       memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
471       offset += tmp_size_bytes;
472       xfree (tmp_data);
473     }
474 }
475
476
477 static Lisp_Object
478 gtk_get_window_property_as_lisp_data (struct device *d,
479                                       GtkWidget *window,
480                                       GdkAtom property,
481                                       /* next two for error messages only */
482                                       Lisp_Object target_type,
483                                       GdkAtom selection_atom)
484 {
485   /* This function can GC */
486   Atom actual_type;
487   int actual_format;
488   unsigned long actual_size;
489   Extbyte *data = NULL;
490   int bytes = 0;
491   Lisp_Object val;
492   struct device *d = get_device_from_display (display);
493
494   x_get_window_property (display, window, property, &data, &bytes,
495                          &actual_type, &actual_format, &actual_size, 1);
496   if (! data)
497     {
498       if (XGetSelectionOwner (display, selection_atom))
499         /* there is a selection owner */
500         signal_error
501           (Qselection_conversion_error,
502            Fcons (build_string ("selection owner couldn't convert"),
503                   Fcons (x_atom_to_symbol (d, selection_atom),
504                          actual_type ?
505                          list2 (target_type, x_atom_to_symbol (d, actual_type)) :
506                          list1 (target_type))));
507       else
508         signal_error (Qerror,
509                       list2 (build_string ("no selection"),
510                              x_atom_to_symbol (d, selection_atom)));
511     }
512
513   if (actual_type == DEVICE_XATOM_INCR (d))
514     {
515       /* Ok, that data wasn't *the* data, it was just the beginning. */
516
517       unsigned int min_size_bytes = * ((unsigned int *) data);
518       xfree (data);
519       receive_incremental_selection (display, window, property, target_type,
520                                      min_size_bytes, &data, &bytes,
521                                      &actual_type, &actual_format,
522                                      &actual_size);
523     }
524
525   /* It's been read.  Now convert it to a lisp object in some semi-rational
526      manner. */
527   val = selection_data_to_lisp_data (d, data, bytes,
528                                      actual_type, actual_format);
529
530   xfree (data);
531   return val;
532 }
533 #endif
534
535 \f
536 static GdkAtom
537 symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists)
538 {
539   if (NILP (sym))               return GDK_SELECTION_PRIMARY;
540   if (EQ (sym, Qt))             return GDK_SELECTION_SECONDARY;
541   if (EQ (sym, QPRIMARY))       return GDK_SELECTION_PRIMARY;
542   if (EQ (sym, QSECONDARY))     return GDK_SELECTION_SECONDARY;
543
544   {
545     const char *nameext;
546     LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), nameext, Qctext);
547     return gdk_atom_intern (nameext, only_if_exists ? TRUE : FALSE);
548   }
549 }
550
551 static Lisp_Object
552 atom_to_symbol (struct device *d, GdkAtom atom)
553 {
554   if (atom == GDK_SELECTION_PRIMARY) return (QPRIMARY);
555   if (atom == GDK_SELECTION_SECONDARY) return (QSECONDARY);
556
557   {
558     char *intstr;
559     char *str = gdk_atom_name (atom);
560
561     if (! str) return Qnil;
562
563     TO_INTERNAL_FORMAT (C_STRING, str,
564                         C_STRING_ALLOCA, intstr,
565                         Qctext);
566     g_free (str);
567     return intern (intstr);
568   }
569 }
570
571 /* #### These are going to move into Lisp code(!) with the aid of
572         some new functions I'm working on - ajh */
573
574 /* These functions convert from the selection data read from the server into
575    something that we can use from elisp, and vice versa.
576
577         Type:   Format: Size:           Elisp Type:
578         -----   ------- -----           -----------
579         *       8       *               String
580         ATOM    32      1               Symbol
581         ATOM    32      > 1             Vector of Symbols
582         *       16      1               Integer
583         *       16      > 1             Vector of Integers
584         *       32      1               if <=16 bits: Integer
585                                         if > 16 bits: Cons of top16, bot16
586         *       32      > 1             Vector of the above
587
588    When converting a Lisp number to C, it is assumed to be of format 16 if
589    it is an integer, and of format 32 if it is a cons of two integers.
590
591    When converting a vector of numbers from Elisp to C, it is assumed to be
592    of format 16 if every element in the vector is an integer, and is assumed
593    to be of format 32 if any element is a cons of two integers.
594
595    When converting an object to C, it may be of the form (SYMBOL . <data>)
596    where SYMBOL is what we should claim that the type is.  Format and
597    representation are as above.
598
599    NOTE: Under Mule, when someone shoves us a string without a type, we
600    set the type to 'COMPOUND_TEXT and automatically convert to Compound
601    Text.  If the string has a type, we assume that the user wants the
602    data sent as-is so we just do "binary" conversion.
603  */
604
605
606 static Lisp_Object
607 selection_data_to_lisp_data (struct device *d,
608                              Extbyte *data,
609                              size_t size,
610                              GdkAtom type,
611                              int format)
612 {
613   if (type == gdk_atom_intern ("NULL", 0))
614     return QNULL;
615
616   /* Convert any 8-bit data to a string, for compactness. */
617   else if (format == 8)
618     return make_ext_string (data, size,
619                             ((type == gdk_atom_intern ("TEXT", FALSE)) ||
620                              (type == gdk_atom_intern ("COMPOUND_TEXT", FALSE)))
621                             ? Qctext : Qbinary);
622
623   /* Convert a single atom to a Lisp Symbol.
624      Convert a set of atoms to a vector of symbols. */
625   else if (type == gdk_atom_intern ("ATOM", FALSE))
626     {
627       if (size == sizeof (GdkAtom))
628         return atom_to_symbol (d, *((GdkAtom *) data));
629       else
630         {
631           int i;
632           int len = size / sizeof (GdkAtom);
633           Lisp_Object v = Fmake_vector (make_int (len), Qzero);
634           for (i = 0; i < len; i++)
635             Faset (v, make_int (i), atom_to_symbol (d, ((GdkAtom *) data) [i]));
636           return v;
637         }
638     }
639
640   /* Convert a single 16 or small 32 bit number to a Lisp Int.
641      If the number is > 16 bits, convert it to a cons of integers,
642      16 bits in each half.
643    */
644   else if (format == 32 && size == sizeof (long))
645     return word_to_lisp (((unsigned long *) data) [0]);
646   else if (format == 16 && size == sizeof (short))
647     return make_int ((int) (((unsigned short *) data) [0]));
648
649   /* Convert any other kind of data to a vector of numbers, represented
650      as above (as an integer, or a cons of two 16 bit integers).
651
652      #### Perhaps we should return the actual type to lisp as well.
653
654         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
655         ==> [4 4]
656
657      and perhaps it should be
658
659         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
660         ==> (SPAN . [4 4])
661
662      Right now the fact that the return type was SPAN is discarded before
663      lisp code gets to see it.
664    */
665   else if (format == 16)
666     {
667       int i;
668       Lisp_Object v = make_vector (size / 4, Qzero);
669       for (i = 0; i < (int) size / 4; i++)
670         {
671           int j = (int) ((unsigned short *) data) [i];
672           Faset (v, make_int (i), make_int (j));
673         }
674       return v;
675     }
676   else
677     {
678       int i;
679       Lisp_Object v = make_vector (size / 4, Qzero);
680       for (i = 0; i < (int) size / 4; i++)
681         {
682           unsigned long j = ((unsigned long *) data) [i];
683           Faset (v, make_int (i), word_to_lisp (j));
684         }
685       return v;
686     }
687 }
688
689
690 static void
691 lisp_data_to_selection_data (struct device *d,
692                              Lisp_Object obj,
693                              unsigned char **data_ret,
694                              GdkAtom *type_ret,
695                              unsigned int *size_ret,
696                              int *format_ret)
697 {
698   Lisp_Object type = Qnil;
699
700   if (CONSP (obj) && SYMBOLP (XCAR (obj)))
701     {
702       type = XCAR (obj);
703       obj = XCDR (obj);
704       if (CONSP (obj) && NILP (XCDR (obj)))
705         obj = XCAR (obj);
706     }
707
708   if (EQ (obj, QNULL) || (EQ (type, QNULL)))
709     {                           /* This is not the same as declining */
710       *format_ret = 32;
711       *size_ret = 0;
712       *data_ret = 0;
713       type = QNULL;
714     }
715   else if (STRINGP (obj))
716     {
717       const Extbyte *extval;
718       Extcount extvallen;
719
720       TO_EXTERNAL_FORMAT (LISP_STRING, obj,
721                           ALLOCA, (extval, extvallen),
722                           (NILP (type) ? Qctext : Qbinary));
723       *format_ret = 8;
724       *size_ret = extvallen;
725       *data_ret = (unsigned char *) xmalloc (*size_ret);
726       memcpy (*data_ret, extval, *size_ret);
727 #ifdef MULE
728       if (NILP (type)) type = QCOMPOUND_TEXT;
729 #else
730       if (NILP (type)) type = QSTRING;
731 #endif
732     }
733   else if (CHARP (obj))
734     {
735       Bufbyte buf[MAX_EMCHAR_LEN];
736       Bytecount len;
737       const Extbyte *extval;
738       Extcount extvallen;
739
740       *format_ret = 8;
741       len = set_charptr_emchar (buf, XCHAR (obj));
742       TO_EXTERNAL_FORMAT (DATA, (buf, len),
743                           ALLOCA, (extval, extvallen),
744                           Qctext);
745       *size_ret = extvallen;
746       *data_ret = (unsigned char *) xmalloc (*size_ret);
747       memcpy (*data_ret, extval, *size_ret);
748 #ifdef MULE
749       if (NILP (type)) type = QCOMPOUND_TEXT;
750 #else
751       if (NILP (type)) type = QSTRING;
752 #endif
753     }
754   else if (SYMBOLP (obj))
755     {
756       *format_ret = 32;
757       *size_ret = 1;
758       *data_ret = (unsigned char *) xmalloc (sizeof (GdkAtom) + 1);
759       (*data_ret) [sizeof (GdkAtom)] = 0;
760       (*(GdkAtom **) data_ret) [0] = symbol_to_gtk_atom (d, obj, 0);
761       if (NILP (type)) type = QATOM;
762     }
763   else if (INTP (obj) &&
764            XINT (obj) <= 0x7FFF &&
765            XINT (obj) >= -0x8000)
766     {
767       *format_ret = 16;
768       *size_ret = 1;
769       *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
770       (*data_ret) [sizeof (short)] = 0;
771       (*(short **) data_ret) [0] = (short) XINT (obj);
772       if (NILP (type)) type = QINTEGER;
773     }
774   else if (INTP (obj) || CONSP (obj))
775     {
776       *format_ret = 32;
777       *size_ret = 1;
778       *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
779       (*data_ret) [sizeof (long)] = 0;
780       (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
781       if (NILP (type)) type = QINTEGER;
782     }
783   else if (VECTORP (obj))
784     {
785       /* Lisp Vectors may represent a set of ATOMs;
786          a set of 16 or 32 bit INTEGERs;
787          or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
788        */
789       int i;
790
791       if (SYMBOLP (XVECTOR_DATA (obj) [0]))
792         /* This vector is an ATOM set */
793         {
794           if (NILP (type)) type = QATOM;
795           *size_ret = XVECTOR_LENGTH (obj);
796           *format_ret = 32;
797           *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (GdkAtom));
798           for (i = 0; i < (int) (*size_ret); i++)
799             if (SYMBOLP (XVECTOR_DATA (obj) [i]))
800               (*(GdkAtom **) data_ret) [i] =
801                 symbol_to_gtk_atom (d, XVECTOR_DATA (obj) [i], 0);
802             else
803               signal_error (Qerror, /* Qselection_error */
804                             list2 (build_string
805                    ("all elements of the vector must be of the same type"),
806                                    obj));
807         }
808 #if 0 /* #### MULTIPLE doesn't work yet */
809       else if (VECTORP (XVECTOR_DATA (obj) [0]))
810         /* This vector is an ATOM_PAIR set */
811         {
812           if (NILP (type)) type = QATOM_PAIR;
813           *size_ret = XVECTOR_LENGTH (obj);
814           *format_ret = 32;
815           *data_ret = (unsigned char *)
816             xmalloc ((*size_ret) * sizeof (Atom) * 2);
817           for (i = 0; i < *size_ret; i++)
818             if (VECTORP (XVECTOR_DATA (obj) [i]))
819               {
820                 Lisp_Object pair = XVECTOR_DATA (obj) [i];
821                 if (XVECTOR_LENGTH (pair) != 2)
822                   signal_error (Qerror,
823                                 list2 (build_string
824        ("elements of the vector must be vectors of exactly two elements"),
825                                   pair));
826
827                 (*(GdkAtom **) data_ret) [i * 2] =
828                   symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [0], 0);
829                 (*(GdkAtom **) data_ret) [(i * 2) + 1] =
830                   symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [1], 0);
831               }
832             else
833               signal_error (Qerror,
834                             list2 (build_string
835                    ("all elements of the vector must be of the same type"),
836                                    obj));
837         }
838 #endif
839       else
840         /* This vector is an INTEGER set, or something like it */
841         {
842           *size_ret = XVECTOR_LENGTH (obj);
843           if (NILP (type)) type = QINTEGER;
844           *format_ret = 16;
845           for (i = 0; i < (int) (*size_ret); i++)
846             if (CONSP (XVECTOR_DATA (obj) [i]))
847               *format_ret = 32;
848             else if (!INTP (XVECTOR_DATA (obj) [i]))
849               signal_error (Qerror, /* Qselection_error */
850                             list2 (build_string
851         ("all elements of the vector must be integers or conses of integers"),
852                                    obj));
853
854           *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
855           for (i = 0; i < (int) (*size_ret); i++)
856             if (*format_ret == 32)
857               (*((unsigned long **) data_ret)) [i] =
858                 lisp_to_word (XVECTOR_DATA (obj) [i]);
859             else
860               (*((unsigned short **) data_ret)) [i] =
861                 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
862         }
863     }
864   else
865     signal_error (Qerror, /* Qselection_error */
866                   list2 (build_string ("unrecognized selection data"),
867                          obj));
868
869   *type_ret = symbol_to_gtk_atom (d, type, 0);
870 }
871
872 \f
873
874 static Lisp_Object
875 gtk_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
876                    Lisp_Object how_to_add, Lisp_Object selection_type)
877 {
878   struct device *d = decode_gtk_device (Qnil);
879   GtkWidget *selecting_window = GTK_WIDGET (DEVICE_GTK_APP_SHELL (d));
880   Lisp_Object selection_time;
881   /* Use the time of the last-read mouse or keyboard event.
882      For selection purposes, we use this as a sleazy way of knowing what the
883      current time is in server-time.  This assumes that the most recently read
884      mouse or keyboard event has something to do with the assertion of the
885      selection, which is probably true.
886      */
887   guint32 thyme = DEVICE_GTK_MOUSE_TIMESTAMP (d);
888   GdkAtom selection_atom;
889
890   CHECK_SYMBOL (selection_name);
891   selection_atom = symbol_to_gtk_atom (d, selection_name, 0);
892
893   gtk_selection_owner_set (selecting_window,
894                            selection_atom,
895                            thyme);
896
897   /* We do NOT use time_to_lisp() here any more, like we used to.
898      That assumed equivalence of time_t and Time, which is not
899      necessarily the case (e.g. under OSF on the Alphas, where
900      Time is a 64-bit quantity and time_t is a 32-bit quantity).
901
902      Opaque pointers are the clean way to go here.
903   */
904   selection_time = make_opaque (&thyme, sizeof (thyme));
905
906   return selection_time;
907 }
908
909 static void
910 gtk_disown_selection (Lisp_Object selection, Lisp_Object timeval)
911 {
912   struct device *d = decode_gtk_device (Qnil);
913   GdkAtom selection_atom;
914   guint32 timestamp;
915
916   CHECK_SYMBOL (selection);
917   selection_atom = symbol_to_gtk_atom (d, selection, 0);
918
919   if (NILP (timeval))
920     timestamp = DEVICE_GTK_MOUSE_TIMESTAMP (d);
921   else
922     {
923       time_t the_time;
924       lisp_to_time (timeval, &the_time);
925       timestamp = (guint32) the_time;
926     }
927
928   gtk_selection_owner_set (NULL, selection_atom, timestamp);
929 }
930
931 static Lisp_Object
932 gtk_selection_exists_p (Lisp_Object selection,
933                         Lisp_Object selection_type)
934 {
935   struct device *d = decode_gtk_device (Qnil);
936   
937   return (gdk_selection_owner_get (symbol_to_gtk_atom (d, selection, 0)) ? Qt : Qnil);
938 }
939
940
941  \f
942 /************************************************************************/
943 /*                            initialization                            */
944 /************************************************************************/
945
946 void
947 syms_of_select_gtk (void)
948 {
949 }
950
951 void
952 console_type_create_select_gtk (void)
953 {
954   CONSOLE_HAS_METHOD (gtk, own_selection);
955   CONSOLE_HAS_METHOD (gtk, disown_selection);
956   CONSOLE_HAS_METHOD (gtk, selection_exists_p);
957   CONSOLE_HAS_METHOD (gtk, get_foreign_selection);
958 }
959
960 void
961 vars_of_select_gtk (void)
962 {
963   staticpro (&Vretrieved_selection);
964   Vretrieved_selection = Qnil;
965
966   DEFVAR_LISP ("gtk-sent-selection-hooks", &Vgtk_sent_selection_hooks /*
967 A function or functions to be called after we have responded to some
968 other client's request for the value of a selection that we own.  The
969 function(s) will be called with four arguments:
970   - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);
971   - the name of the selection-type which we were requested to convert the
972     selection into before sending (for example, STRING or LENGTH);
973   - and whether we successfully transmitted the selection.
974 We might have failed (and declined the request) for any number of reasons,
975 including being asked for a selection that we no longer own, or being asked
976 to convert into a type that we don't know about or that is inappropriate.
977 This hook doesn't let you change the behavior of emacs's selection replies,
978 it merely informs you that they have happened.
979 */ );
980   Vgtk_sent_selection_hooks = Qunbound;
981 }