git.chise.org Git - chise/xemacs-chise.git.1/blob - 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 \f
 213 static GtkWidget *reading_selection_reply;
 214 static GdkAtom reading_which_selection;
 215 static int selection_reply_timed_out;
 216
 217 /* Gets the current selection owned by another application */
 218 void
 219 emacs_gtk_selection_received (GtkWidget *widget,
 220                               GtkSelectionData *selection_data,
 221                               gpointer user_data)
 222 {
 223   waiting_for_selection = FALSE;
 224   Vretrieved_selection = Qnil;
 225
 226   reading_selection_reply = NULL;
 227
 228   signal_fake_event ();
 229
 230   if (selection_data->length < 0)
 231     {
 232       return;
 233     }
 234
 235   Vretrieved_selection =
 236     selection_data_to_lisp_data (NULL,
 237                                  selection_data->data,
 238                                  selection_data->length,
 239                                  selection_data->type,
 240                                  selection_data->format);
 241 }
 242
 243 static int
 244 selection_reply_done (void *ignore)
 245 {
 246   return !reading_selection_reply;
 247 }
 248
 249 /* Do protocol to read selection-data from the server.
 250    Converts this to lisp data and returns it.
 251  */
 252 static Lisp_Object
 253 gtk_get_foreign_selection (Lisp_Object selection_symbol,
 254                            Lisp_Object target_type)
 255 {
 256   /* This function can GC */
 257   struct device *d = decode_gtk_device (Qnil);
 258   GtkWidget *requestor = DEVICE_GTK_APP_SHELL (d);
 259   guint32 requestor_time = DEVICE_GTK_MOUSE_TIMESTAMP (d);
 260   GdkAtom selection_atom = symbol_to_gtk_atom (d, selection_symbol, 0);
 261   int speccount;
 262   GdkAtom type_atom = symbol_to_gtk_atom (d, (CONSP (target_type) ?
 263                                               XCAR (target_type) : target_type), 0);
 264
 265   gtk_selection_convert (requestor, selection_atom, type_atom,
 266                          requestor_time);
 267
 268   signal_fake_event ();
 269
 270   /* Block until the reply has been read. */
 271   reading_selection_reply = requestor;
 272   reading_which_selection = selection_atom;
 273   selection_reply_timed_out = 0;
 274
 275   speccount = specpdl_depth ();
 276
 277 #if 0
 278   /* add a timeout handler */
 279   if (gtk_selection_timeout > 0)
 280     {
 281       Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout),
 282                                      Qx_selection_reply_timeout_internal,
 283                                      Qnil, Qnil);
 284       record_unwind_protect (Fdisable_timeout, id);
 285     }
 286 #endif
 287
 288   /* This is ^Gable */
 289   wait_delaying_user_input (selection_reply_done, 0);
 290
 291   if (selection_reply_timed_out)
 292     error ("timed out waiting for reply from selection owner");
 293
 294   unbind_to (speccount, Qnil);
 295
 296   /* otherwise, the selection is waiting for us on the requested property. */
 297   return select_convert_in (selection_symbol,
 298                             target_type,
 299                             Vretrieved_selection);
 300 }
 301
 302
 303 #if 0
 304 static void
 305 gtk_get_window_property (struct device *d, GtkWidget *window, GdkAtom property,
 306                          Extbyte **data_ret, int *bytes_ret,
 307                          GdkAtom *actual_type_ret, int *actual_format_ret,
 308                          unsigned long *actual_size_ret, int delete_p)
 309 {
 310   size_t total_size;
 311   unsigned long bytes_remaining;
 312   int offset = 0;
 313   unsigned char *tmp_data = 0;
 314   int result;
 315   int buffer_size = SELECTION_QUANTUM (display);
 316   if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
 317
 318   /* First probe the thing to find out how big it is. */
 319   result = XGetWindowProperty (display, window, property,
 320                                0, 0, False, AnyPropertyType,
 321                                actual_type_ret, actual_format_ret,
 322                                actual_size_ret,
 323                                &bytes_remaining, &tmp_data);
 324   if (result != Success)
 325     {
 326       *data_ret = 0;
 327       *bytes_ret = 0;
 328       return;
 329     }
 330   XFree ((char *) tmp_data);
 331
 332   if (*actual_type_ret == None || *actual_format_ret == 0)
 333     {
 334       if (delete_p) XDeleteProperty (display, window, property);
 335       *data_ret = 0;
 336       *bytes_ret = 0;
 337       return;
 338     }
 339
 340   total_size = bytes_remaining + 1;
 341   *data_ret = (Extbyte *) xmalloc (total_size);
 342
 343   /* Now read, until we've gotten it all. */
 344   while (bytes_remaining)
 345     {
 346 #if 0
 347       int last = bytes_remaining;
 348 #endif
 349       result =
 350         XGetWindowProperty (display, window, property,
 351                             offset/4, buffer_size/4,
 352                             (delete_p ? True : False),
 353                             AnyPropertyType,
 354                             actual_type_ret, actual_format_ret,
 355                             actual_size_ret, &bytes_remaining, &tmp_data);
 356 #if 0
 357       stderr_out ("<< read %d\n", last-bytes_remaining);
 358 #endif
 359       /* If this doesn't return Success at this point, it means that
 360          some clod deleted the selection while we were in the midst of
 361          reading it.  Deal with that, I guess....
 362        */
 363       if (result != Success) break;
 364       *actual_size_ret *= *actual_format_ret / 8;
 365       memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
 366       offset += *actual_size_ret;
 367       XFree ((char *) tmp_data);
 368     }
 369   *bytes_ret = offset;
 370 }
 371
 372
 373 static void
 374 receive_incremental_selection (Display *display, Window window, Atom property,
 375                                /* this one is for error messages only */
 376                                Lisp_Object target_type,
 377                                unsigned int min_size_bytes,
 378                                Extbyte **data_ret, int *size_bytes_ret,
 379                                Atom *type_ret, int *format_ret,
 380                                unsigned long *size_ret)
 381 {
 382   /* This function can GC */
 383   int offset = 0;
 384   int prop_id;
 385   *size_bytes_ret = min_size_bytes;
 386   *data_ret = (Extbyte *) xmalloc (*size_bytes_ret);
 387 #if 0
 388   stderr_out ("\nread INCR %d\n", min_size_bytes);
 389 #endif
 390   /* At this point, we have read an INCR property, and deleted it (which
 391      is how we ack its receipt: the sending window will be selecting
 392      PropertyNotify events on our window to notice this).
 393
 394      Now, we must loop, waiting for the sending window to put a value on
 395      that property, then reading the property, then deleting it to ack.
 396      We are done when the sender places a property of length 0.
 397    */
 398   prop_id = expect_property_change (display, window, property,
 399                                     PropertyNewValue);
 400   while (1)
 401     {
 402       Extbyte *tmp_data;
 403       int tmp_size_bytes;
 404       wait_for_property_change (prop_id);
 405       /* expect it again immediately, because x_get_window_property may
 406          .. no it won't, I don't get it.
 407          .. Ok, I get it now, the Xt code that implements INCR is broken.
 408        */
 409       prop_id = expect_property_change (display, window, property,
 410                                         PropertyNewValue);
 411       x_get_window_property (display, window, property,
 412                              &tmp_data, &tmp_size_bytes,
 413                              type_ret, format_ret, size_ret, 1);
 414
 415       if (tmp_size_bytes == 0) /* we're done */
 416         {
 417 #if 0
 418           stderr_out ("  read INCR done\n");
 419 #endif
 420           unexpect_property_change (prop_id);
 421           if (tmp_data) xfree (tmp_data);
 422           break;
 423         }
 424 #if 0
 425       stderr_out ("  read INCR %d\n", tmp_size_bytes);
 426 #endif
 427       if (*size_bytes_ret < offset + tmp_size_bytes)
 428         {
 429 #if 0
 430           stderr_out ("  read INCR realloc %d -> %d\n",
 431                    *size_bytes_ret, offset + tmp_size_bytes);
 432 #endif
 433           *size_bytes_ret = offset + tmp_size_bytes;
 434           *data_ret = (Extbyte *) xrealloc (*data_ret, *size_bytes_ret);
 435         }
 436       memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
 437       offset += tmp_size_bytes;
 438       xfree (tmp_data);
 439     }
 440 }
 441
 442
 443 static Lisp_Object
 444 gtk_get_window_property_as_lisp_data (struct device *d,
 445                                       GtkWidget *window,
 446                                       GdkAtom property,
 447                                       /* next two for error messages only */
 448                                       Lisp_Object target_type,
 449                                       GdkAtom selection_atom)
 450 {
 451   /* This function can GC */
 452   Atom actual_type;
 453   int actual_format;
 454   unsigned long actual_size;
 455   Extbyte *data = NULL;
 456   int bytes = 0;
 457   Lisp_Object val;
 458   struct device *d = get_device_from_display (display);
 459
 460   x_get_window_property (display, window, property, &data, &bytes,
 461                          &actual_type, &actual_format, &actual_size, 1);
 462   if (! data)
 463     {
 464       if (XGetSelectionOwner (display, selection_atom))
 465         /* there is a selection owner */
 466         signal_error
 467           (Qselection_conversion_error,
 468            Fcons (build_string ("selection owner couldn't convert"),
 469                   Fcons (x_atom_to_symbol (d, selection_atom),
 470                          actual_type ?
 471                          list2 (target_type, x_atom_to_symbol (d, actual_type)) :
 472                          list1 (target_type))));
 473       else
 474         signal_error (Qerror,
 475                       list2 (build_string ("no selection"),
 476                              x_atom_to_symbol (d, selection_atom)));
 477     }
 478
 479   if (actual_type == DEVICE_XATOM_INCR (d))
 480     {
 481       /* Ok, that data wasn't *the* data, it was just the beginning. */
 482
 483       unsigned int min_size_bytes = * ((unsigned int *) data);
 484       xfree (data);
 485       receive_incremental_selection (display, window, property, target_type,
 486                                      min_size_bytes, &data, &bytes,
 487                                      &actual_type, &actual_format,
 488                                      &actual_size);
 489     }
 490
 491   /* It's been read.  Now convert it to a lisp object in some semi-rational
 492      manner. */
 493   val = selection_data_to_lisp_data (d, data, bytes,
 494                                      actual_type, actual_format);
 495
 496   xfree (data);
 497   return val;
 498 }
 499 #endif
 500
 501 \f
 502 static GdkAtom
 503 symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists)
 504 {
 505   if (NILP (sym))               return GDK_SELECTION_PRIMARY;
 506   if (EQ (sym, Qt))             return GDK_SELECTION_SECONDARY;
 507   if (EQ (sym, QPRIMARY))       return GDK_SELECTION_PRIMARY;
 508   if (EQ (sym, QSECONDARY))     return GDK_SELECTION_SECONDARY;
 509
 510   {
 511     const char *nameext;
 512     LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), nameext, Qctext);
 513     return gdk_atom_intern (nameext, only_if_exists ? TRUE : FALSE);
 514   }
 515 }
 516
 517 static Lisp_Object
 518 atom_to_symbol (struct device *d, GdkAtom atom)
 519 {
 520   if (atom == GDK_SELECTION_PRIMARY) return (QPRIMARY);
 521   if (atom == GDK_SELECTION_SECONDARY) return (QSECONDARY);
 522
 523   {
 524     char *intstr;
 525     char *str = gdk_atom_name (atom);
 526
 527     if (! str) return Qnil;
 528
 529     TO_INTERNAL_FORMAT (C_STRING, str,
 530                         C_STRING_ALLOCA, intstr,
 531                         Qctext);
 532     g_free (str);
 533     return intern (intstr);
 534   }
 535 }
 536
 537 /* #### These are going to move into Lisp code(!) with the aid of
 538         some new functions I'm working on - ajh */
 539
 540 /* These functions convert from the selection data read from the server into
 541    something that we can use from elisp, and vice versa.
 542
 543         Type:   Format: Size:           Elisp Type:
 544         -----   ------- -----           -----------
 545         *       8       *               String
 546         ATOM    32      1               Symbol
 547         ATOM    32      > 1             Vector of Symbols
 548         *       16      1               Integer
 549         *       16      > 1             Vector of Integers
 550         *       32      1               if <=16 bits: Integer
 551                                         if > 16 bits: Cons of top16, bot16
 552         *       32      > 1             Vector of the above
 553
 554    When converting a Lisp number to C, it is assumed to be of format 16 if
 555    it is an integer, and of format 32 if it is a cons of two integers.
 556
 557    When converting a vector of numbers from Elisp to C, it is assumed to be
 558    of format 16 if every element in the vector is an integer, and is assumed
 559    to be of format 32 if any element is a cons of two integers.
 560
 561    When converting an object to C, it may be of the form (SYMBOL . <data>)
 562    where SYMBOL is what we should claim that the type is.  Format and
 563    representation are as above.
 564
 565    NOTE: Under Mule, when someone shoves us a string without a type, we
 566    set the type to 'COMPOUND_TEXT and automatically convert to Compound
 567    Text.  If the string has a type, we assume that the user wants the
 568    data sent as-is so we just do "binary" conversion.
 569  */
 570
 571
 572 static Lisp_Object
 573 selection_data_to_lisp_data (struct device *d,
 574                              Extbyte *data,
 575                              size_t size,
 576                              GdkAtom type,
 577                              int format)
 578 {
 579   if (type == gdk_atom_intern ("NULL", 0))
 580     return QNULL;
 581
 582   /* Convert any 8-bit data to a string, for compactness. */
 583   else if (format == 8)
 584     return make_ext_string (data, size,
 585                             ((type == gdk_atom_intern ("TEXT", FALSE)) ||
 586                              (type == gdk_atom_intern ("COMPOUND_TEXT", FALSE)))
 587                             ? Qctext : Qbinary);
 588
 589   /* Convert a single atom to a Lisp Symbol.
 590      Convert a set of atoms to a vector of symbols. */
 591   else if (type == gdk_atom_intern ("ATOM", FALSE))
 592     {
 593       if (size == sizeof (GdkAtom))
 594         return atom_to_symbol (d, *((GdkAtom *) data));
 595       else
 596         {
 597           int i;
 598           int len = size / sizeof (GdkAtom);
 599           Lisp_Object v = Fmake_vector (make_int (len), Qzero);
 600           for (i = 0; i < len; i++)
 601             Faset (v, make_int (i), atom_to_symbol (d, ((GdkAtom *) data) [i]));
 602           return v;
 603         }
 604     }
 605
 606   /* Convert a single 16 or small 32 bit number to a Lisp Int.
 607      If the number is > 16 bits, convert it to a cons of integers,
 608      16 bits in each half.
 609    */
 610   else if (format == 32 && size == sizeof (long))
 611     return word_to_lisp (((unsigned long *) data) [0]);
 612   else if (format == 16 && size == sizeof (short))
 613     return make_int ((int) (((unsigned short *) data) [0]));
 614
 615   /* Convert any other kind of data to a vector of numbers, represented
 616      as above (as an integer, or a cons of two 16 bit integers).
 617
 618      #### Perhaps we should return the actual type to lisp as well.
 619
 620         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
 621         ==> [4 4]
 622
 623      and perhaps it should be
 624
 625         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
 626         ==> (SPAN . [4 4])
 627
 628      Right now the fact that the return type was SPAN is discarded before
 629      lisp code gets to see it.
 630    */
 631   else if (format == 16)
 632     {
 633       int i;
 634       Lisp_Object v = make_vector (size / 4, Qzero);
 635       for (i = 0; i < (int) size / 4; i++)
 636         {
 637           int j = (int) ((unsigned short *) data) [i];
 638           Faset (v, make_int (i), make_int (j));
 639         }
 640       return v;
 641     }
 642   else
 643     {
 644       int i;
 645       Lisp_Object v = make_vector (size / 4, Qzero);
 646       for (i = 0; i < (int) size / 4; i++)
 647         {
 648           unsigned long j = ((unsigned long *) data) [i];
 649           Faset (v, make_int (i), word_to_lisp (j));
 650         }
 651       return v;
 652     }
 653 }
 654
 655
 656 static void
 657 lisp_data_to_selection_data (struct device *d,
 658                              Lisp_Object obj,
 659                              unsigned char **data_ret,
 660                              GdkAtom *type_ret,
 661                              unsigned int *size_ret,
 662                              int *format_ret)
 663 {
 664   Lisp_Object type = Qnil;
 665
 666   if (CONSP (obj) && SYMBOLP (XCAR (obj)))
 667     {
 668       type = XCAR (obj);
 669       obj = XCDR (obj);
 670       if (CONSP (obj) && NILP (XCDR (obj)))
 671         obj = XCAR (obj);
 672     }
 673
 674   if (EQ (obj, QNULL) || (EQ (type, QNULL)))
 675     {                           /* This is not the same as declining */
 676       *format_ret = 32;
 677       *size_ret = 0;
 678       *data_ret = 0;
 679       type = QNULL;
 680     }
 681   else if (STRINGP (obj))
 682     {
 683       const Extbyte *extval;
 684       Extcount extvallen;
 685
 686       TO_EXTERNAL_FORMAT (LISP_STRING, obj,
 687                           ALLOCA, (extval, extvallen),
 688                           (NILP (type) ? Qctext : Qbinary));
 689       *format_ret = 8;
 690       *size_ret = extvallen;
 691       *data_ret = (unsigned char *) xmalloc (*size_ret);
 692       memcpy (*data_ret, extval, *size_ret);
 693 #ifdef MULE
 694       if (NILP (type)) type = QCOMPOUND_TEXT;
 695 #else
 696       if (NILP (type)) type = QSTRING;
 697 #endif
 698     }
 699   else if (CHARP (obj))
 700     {
 701       Bufbyte buf[MAX_EMCHAR_LEN];
 702       Bytecount len;
 703       const Extbyte *extval;
 704       Extcount extvallen;
 705
 706       *format_ret = 8;
 707       len = set_charptr_emchar (buf, XCHAR (obj));
 708       TO_EXTERNAL_FORMAT (DATA, (buf, len),
 709                           ALLOCA, (extval, extvallen),
 710                           Qctext);
 711       *size_ret = extvallen;
 712       *data_ret = (unsigned char *) xmalloc (*size_ret);
 713       memcpy (*data_ret, extval, *size_ret);
 714 #ifdef MULE
 715       if (NILP (type)) type = QCOMPOUND_TEXT;
 716 #else
 717       if (NILP (type)) type = QSTRING;
 718 #endif
 719     }
 720   else if (SYMBOLP (obj))
 721     {
 722       *format_ret = 32;
 723       *size_ret = 1;
 724       *data_ret = (unsigned char *) xmalloc (sizeof (GdkAtom) + 1);
 725       (*data_ret) [sizeof (GdkAtom)] = 0;
 726       (*(GdkAtom **) data_ret) [0] = symbol_to_gtk_atom (d, obj, 0);
 727       if (NILP (type)) type = QATOM;
 728     }
 729   else if (INTP (obj) &&
 730            XINT (obj) <= 0x7FFF &&
 731            XINT (obj) >= -0x8000)
 732     {
 733       *format_ret = 16;
 734       *size_ret = 1;
 735       *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
 736       (*data_ret) [sizeof (short)] = 0;
 737       (*(short **) data_ret) [0] = (short) XINT (obj);
 738       if (NILP (type)) type = QINTEGER;
 739     }
 740   else if (INTP (obj) || CONSP (obj))
 741     {
 742       *format_ret = 32;
 743       *size_ret = 1;
 744       *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
 745       (*data_ret) [sizeof (long)] = 0;
 746       (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
 747       if (NILP (type)) type = QINTEGER;
 748     }
 749   else if (VECTORP (obj))
 750     {
 751       /* Lisp Vectors may represent a set of ATOMs;
 752          a set of 16 or 32 bit INTEGERs;
 753          or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
 754        */
 755       int i;
 756
 757       if (SYMBOLP (XVECTOR_DATA (obj) [0]))
 758         /* This vector is an ATOM set */
 759         {
 760           if (NILP (type)) type = QATOM;
 761           *size_ret = XVECTOR_LENGTH (obj);
 762           *format_ret = 32;
 763           *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (GdkAtom));
 764           for (i = 0; i < (int) (*size_ret); i++)
 765             if (SYMBOLP (XVECTOR_DATA (obj) [i]))
 766               (*(GdkAtom **) data_ret) [i] =
 767                 symbol_to_gtk_atom (d, XVECTOR_DATA (obj) [i], 0);
 768             else
 769               signal_error (Qerror, /* Qselection_error */
 770                             list2 (build_string
 771                    ("all elements of the vector must be of the same type"),
 772                                    obj));
 773         }
 774 #if 0 /* #### MULTIPLE doesn't work yet */
 775       else if (VECTORP (XVECTOR_DATA (obj) [0]))
 776         /* This vector is an ATOM_PAIR set */
 777         {
 778           if (NILP (type)) type = QATOM_PAIR;
 779           *size_ret = XVECTOR_LENGTH (obj);
 780           *format_ret = 32;
 781           *data_ret = (unsigned char *)
 782             xmalloc ((*size_ret) * sizeof (Atom) * 2);
 783           for (i = 0; i < *size_ret; i++)
 784             if (VECTORP (XVECTOR_DATA (obj) [i]))
 785               {
 786                 Lisp_Object pair = XVECTOR_DATA (obj) [i];
 787                 if (XVECTOR_LENGTH (pair) != 2)
 788                   signal_error (Qerror,
 789                                 list2 (build_string
 790        ("elements of the vector must be vectors of exactly two elements"),
 791                                   pair));
 792
 793                 (*(GdkAtom **) data_ret) [i * 2] =
 794                   symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [0], 0);
 795                 (*(GdkAtom **) data_ret) [(i * 2) + 1] =
 796                   symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [1], 0);
 797               }
 798             else
 799               signal_error (Qerror,
 800                             list2 (build_string
 801                    ("all elements of the vector must be of the same type"),
 802                                    obj));
 803         }
 804 #endif
 805       else
 806         /* This vector is an INTEGER set, or something like it */
 807         {
 808           *size_ret = XVECTOR_LENGTH (obj);
 809           if (NILP (type)) type = QINTEGER;
 810           *format_ret = 16;
 811           for (i = 0; i < (int) (*size_ret); i++)
 812             if (CONSP (XVECTOR_DATA (obj) [i]))
 813               *format_ret = 32;
 814             else if (!INTP (XVECTOR_DATA (obj) [i]))
 815               signal_error (Qerror, /* Qselection_error */
 816                             list2 (build_string
 817         ("all elements of the vector must be integers or conses of integers"),
 818                                    obj));
 819
 820           *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
 821           for (i = 0; i < (int) (*size_ret); i++)
 822             if (*format_ret == 32)
 823               (*((unsigned long **) data_ret)) [i] =
 824                 lisp_to_word (XVECTOR_DATA (obj) [i]);
 825             else
 826               (*((unsigned short **) data_ret)) [i] =
 827                 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
 828         }
 829     }
 830   else
 831     signal_error (Qerror, /* Qselection_error */
 832                   list2 (build_string ("unrecognized selection data"),
 833                          obj));
 834
 835   *type_ret = symbol_to_gtk_atom (d, type, 0);
 836 }
 837
 838 \f
 839
 840 static Lisp_Object
 841 gtk_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
 842                    Lisp_Object how_to_add, Lisp_Object selection_type)
 843 {
 844   struct device *d = decode_gtk_device (Qnil);
 845   GtkWidget *selecting_window = GTK_WIDGET (DEVICE_GTK_APP_SHELL (d));
 846   Lisp_Object selection_time;
 847   /* Use the time of the last-read mouse or keyboard event.
 848      For selection purposes, we use this as a sleazy way of knowing what the
 849      current time is in server-time.  This assumes that the most recently read
 850      mouse or keyboard event has something to do with the assertion of the
 851      selection, which is probably true.
 852      */
 853   guint32 thyme = DEVICE_GTK_MOUSE_TIMESTAMP (d);
 854   GdkAtom selection_atom;
 855
 856   CHECK_SYMBOL (selection_name);
 857   selection_atom = symbol_to_gtk_atom (d, selection_name, 0);
 858
 859   gtk_selection_owner_set (selecting_window,
 860                            selection_atom,
 861                            thyme);
 862
 863   /* We do NOT use time_to_lisp() here any more, like we used to.
 864      That assumed equivalence of time_t and Time, which is not
 865      necessarily the case (e.g. under OSF on the Alphas, where
 866      Time is a 64-bit quantity and time_t is a 32-bit quantity).
 867
 868      Opaque pointers are the clean way to go here.
 869   */
 870   selection_time = make_opaque (&thyme, sizeof (thyme));
 871
 872   return selection_time;
 873 }
 874
 875 static void
 876 gtk_disown_selection (Lisp_Object selection, Lisp_Object timeval)
 877 {
 878   struct device *d = decode_gtk_device (Qnil);
 879   GdkAtom selection_atom;
 880   guint32 timestamp;
 881
 882   CHECK_SYMBOL (selection);
 883   selection_atom = symbol_to_gtk_atom (d, selection, 0);
 884
 885   if (NILP (timeval))
 886     timestamp = DEVICE_GTK_MOUSE_TIMESTAMP (d);
 887   else
 888     {
 889       time_t the_time;
 890       lisp_to_time (timeval, &the_time);
 891       timestamp = (guint32) the_time;
 892     }
 893
 894   gtk_selection_owner_set (NULL, selection_atom, timestamp);
 895 }
 896
 897 static Lisp_Object
 898 gtk_selection_exists_p (Lisp_Object selection,
 899                         Lisp_Object selection_type)
 900 {
 901   struct device *d = decode_gtk_device (Qnil);
 902
 903   return (gdk_selection_owner_get (symbol_to_gtk_atom (d, selection, 0)) ? Qt : Qnil);
 904 }
 905
 906
 907  \f
 908 /************************************************************************/
 909 /*                            initialization                            */
 910 /************************************************************************/
 911
 912 void
 913 syms_of_select_gtk (void)
 914 {
 915 }
 916
 917 void
 918 console_type_create_select_gtk (void)
 919 {
 920   CONSOLE_HAS_METHOD (gtk, own_selection);
 921   CONSOLE_HAS_METHOD (gtk, disown_selection);
 922   CONSOLE_HAS_METHOD (gtk, selection_exists_p);
 923   CONSOLE_HAS_METHOD (gtk, get_foreign_selection);
 924 }
 925
 926 void
 927 vars_of_select_gtk (void)
 928 {
 929   staticpro (&Vretrieved_selection);
 930   Vretrieved_selection = Qnil;
 931
 932   DEFVAR_LISP ("gtk-sent-selection-hooks", &Vgtk_sent_selection_hooks /*
 933 A function or functions to be called after we have responded to some
 934 other client's request for the value of a selection that we own.  The
 935 function(s) will be called with four arguments:
 936   - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);
 937   - the name of the selection-type which we were requested to convert the
 938     selection into before sending (for example, STRING or LENGTH);
 939   - and whether we successfully transmitted the selection.
 940 We might have failed (and declined the request) for any number of reasons,
 941 including being asked for a selection that we no longer own, or being asked
 942 to convert into a type that we don't know about or that is inappropriate.
 943 This hook doesn't let you change the behavior of emacs's selection replies,
 944 it merely informs you that they have happened.
 945 */ );
 946   Vgtk_sent_selection_hooks = Qunbound;
 947 }