git.chise.org Git - chise/xemacs-chise.git.1/blob - src/select-x.c

   1 /* X 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 /* Rewritten by jwz */
  24
  25 #include <config.h>
  26 #include "lisp.h"
  27
  28 #include "buffer.h"
  29 #include "console-x.h"
  30 #include "objects-x.h"
  31
  32 #include "frame.h"
  33 #include "opaque.h"
  34 #include "systime.h"
  35 #include "select.h"
  36
  37 int lisp_to_time (Lisp_Object, time_t *);
  38 Lisp_Object time_to_lisp (time_t);
  39
  40 #ifdef LWLIB_USES_MOTIF
  41 # define MOTIF_CLIPBOARDS
  42 #endif
  43
  44 #ifdef MOTIF_CLIPBOARDS
  45 # include <Xm/CutPaste.h>
  46 static void hack_motif_clipboard_selection (Atom selection_atom,
  47                                             Lisp_Object selection_value,
  48                                             Time thyme, Display *display,
  49                                             Window selecting_window);
  50 #endif
  51
  52 #define CUT_BUFFER_SUPPORT
  53
  54 #ifdef CUT_BUFFER_SUPPORT
  55 Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
  56   QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
  57 #endif
  58
  59 Lisp_Object Vx_sent_selection_hooks;
  60
  61 /* If this is a smaller number than the max-request-size of the display,
  62    emacs will use INCR selection transfer when the selection is larger
  63    than this.  The max-request-size is usually around 64k, so if you want
  64    emacs to use incremental selection transfers when the selection is
  65    smaller than that, set this.  I added this mostly for debugging the
  66    incremental transfer stuff, but it might improve server performance.
  67  */
  68 #define MAX_SELECTION_QUANTUM 0xFFFFFF
  69
  70 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize (dpy) << 2) - 100)
  71
  72 /* If the selection owner takes too long to reply to a selection request,
  73    we give up on it.  This is in seconds (0 = no timeout).
  74  */
  75 int x_selection_timeout;
  76
  77 \f
  78 /* Utility functions */
  79
  80 static void lisp_data_to_selection_data (struct device *,
  81                                          Lisp_Object obj,
  82                                          unsigned char **data_ret,
  83                                          Atom *type_ret,
  84                                          unsigned int *size_ret,
  85                                          int *format_ret);
  86 static Lisp_Object selection_data_to_lisp_data (struct device *,
  87                                                 unsigned char *data,
  88                                                 size_t size,
  89                                                 Atom type,
  90                                                 int format);
  91 static Lisp_Object x_get_window_property_as_lisp_data (Display *,
  92                                                        Window,
  93                                                        Atom property,
  94                                                        Lisp_Object target_type,
  95                                                        Atom selection_atom);
  96
  97 static int expect_property_change (Display *, Window, Atom prop, int state);
  98 static void wait_for_property_change (long);
  99 static void unexpect_property_change (int);
 100 static int waiting_for_other_props_on_window (Display *, Window);
 101
 102 /* This converts a Lisp symbol to a server Atom, avoiding a server
 103    roundtrip whenever possible.
 104  */
 105 static Atom
 106 symbol_to_x_atom (struct device *d, Lisp_Object sym, int only_if_exists)
 107 {
 108   Display *display = DEVICE_X_DISPLAY (d);
 109
 110   if (NILP (sym))               return XA_PRIMARY;
 111   if (EQ (sym, Qt))             return XA_SECONDARY;
 112   if (EQ (sym, QPRIMARY))       return XA_PRIMARY;
 113   if (EQ (sym, QSECONDARY))     return XA_SECONDARY;
 114   if (EQ (sym, QSTRING))        return XA_STRING;
 115   if (EQ (sym, QINTEGER))       return XA_INTEGER;
 116   if (EQ (sym, QATOM))          return XA_ATOM;
 117   if (EQ (sym, QCLIPBOARD))     return DEVICE_XATOM_CLIPBOARD (d);
 118   if (EQ (sym, QTIMESTAMP))     return DEVICE_XATOM_TIMESTAMP (d);
 119   if (EQ (sym, QTEXT))          return DEVICE_XATOM_TEXT      (d);
 120   if (EQ (sym, QDELETE))        return DEVICE_XATOM_DELETE    (d);
 121   if (EQ (sym, QMULTIPLE))      return DEVICE_XATOM_MULTIPLE  (d);
 122   if (EQ (sym, QINCR))          return DEVICE_XATOM_INCR      (d);
 123   if (EQ (sym, QEMACS_TMP))     return DEVICE_XATOM_EMACS_TMP (d);
 124   if (EQ (sym, QTARGETS))       return DEVICE_XATOM_TARGETS   (d);
 125   if (EQ (sym, QNULL))          return DEVICE_XATOM_NULL      (d);
 126   if (EQ (sym, QATOM_PAIR))     return DEVICE_XATOM_ATOM_PAIR (d);
 127   if (EQ (sym, QCOMPOUND_TEXT)) return DEVICE_XATOM_COMPOUND_TEXT (d);
 128
 129 #ifdef CUT_BUFFER_SUPPORT
 130   if (EQ (sym, QCUT_BUFFER0))   return XA_CUT_BUFFER0;
 131   if (EQ (sym, QCUT_BUFFER1))   return XA_CUT_BUFFER1;
 132   if (EQ (sym, QCUT_BUFFER2))   return XA_CUT_BUFFER2;
 133   if (EQ (sym, QCUT_BUFFER3))   return XA_CUT_BUFFER3;
 134   if (EQ (sym, QCUT_BUFFER4))   return XA_CUT_BUFFER4;
 135   if (EQ (sym, QCUT_BUFFER5))   return XA_CUT_BUFFER5;
 136   if (EQ (sym, QCUT_BUFFER6))   return XA_CUT_BUFFER6;
 137   if (EQ (sym, QCUT_BUFFER7))   return XA_CUT_BUFFER7;
 138 #endif /* CUT_BUFFER_SUPPORT */
 139
 140   {
 141     const char *nameext;
 142     TO_EXTERNAL_FORMAT (LISP_STRING, Fsymbol_name (sym),
 143                         C_STRING_ALLOCA, nameext,
 144                         Qctext);
 145     return XInternAtom (display, nameext, only_if_exists ? True : False);
 146   }
 147 }
 148
 149
 150 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
 151    and calls to intern whenever possible.
 152  */
 153 static Lisp_Object
 154 x_atom_to_symbol (struct device *d, Atom atom)
 155 {
 156   Display *display = DEVICE_X_DISPLAY (d);
 157
 158   if (! atom) return Qnil;
 159   if (atom == XA_PRIMARY)       return QPRIMARY;
 160   if (atom == XA_SECONDARY)     return QSECONDARY;
 161   if (atom == XA_STRING)        return QSTRING;
 162   if (atom == XA_INTEGER)       return QINTEGER;
 163   if (atom == XA_ATOM)          return QATOM;
 164   if (atom == DEVICE_XATOM_CLIPBOARD (d)) return QCLIPBOARD;
 165   if (atom == DEVICE_XATOM_TIMESTAMP (d)) return QTIMESTAMP;
 166   if (atom == DEVICE_XATOM_TEXT      (d)) return QTEXT;
 167   if (atom == DEVICE_XATOM_DELETE    (d)) return QDELETE;
 168   if (atom == DEVICE_XATOM_MULTIPLE  (d)) return QMULTIPLE;
 169   if (atom == DEVICE_XATOM_INCR      (d)) return QINCR;
 170   if (atom == DEVICE_XATOM_EMACS_TMP (d)) return QEMACS_TMP;
 171   if (atom == DEVICE_XATOM_TARGETS   (d)) return QTARGETS;
 172   if (atom == DEVICE_XATOM_NULL      (d)) return QNULL;
 173   if (atom == DEVICE_XATOM_ATOM_PAIR (d)) return QATOM_PAIR;
 174   if (atom == DEVICE_XATOM_COMPOUND_TEXT (d)) return QCOMPOUND_TEXT;
 175
 176 #ifdef CUT_BUFFER_SUPPORT
 177   if (atom == XA_CUT_BUFFER0)   return QCUT_BUFFER0;
 178   if (atom == XA_CUT_BUFFER1)   return QCUT_BUFFER1;
 179   if (atom == XA_CUT_BUFFER2)   return QCUT_BUFFER2;
 180   if (atom == XA_CUT_BUFFER3)   return QCUT_BUFFER3;
 181   if (atom == XA_CUT_BUFFER4)   return QCUT_BUFFER4;
 182   if (atom == XA_CUT_BUFFER5)   return QCUT_BUFFER5;
 183   if (atom == XA_CUT_BUFFER6)   return QCUT_BUFFER6;
 184   if (atom == XA_CUT_BUFFER7)   return QCUT_BUFFER7;
 185 #endif
 186
 187   {
 188     char *intstr;
 189     char *str = XGetAtomName (display, atom);
 190
 191     if (! str) return Qnil;
 192
 193     TO_INTERNAL_FORMAT (C_STRING, str,
 194                         C_STRING_ALLOCA, intstr,
 195                         Qctext);
 196     XFree (str);
 197     return intern (intstr);
 198   }
 199 }
 200
 201 \f
 202 /* Do protocol to assert ourself as a selection owner.
 203  */
 204 static Lisp_Object
 205 x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
 206                  Lisp_Object how_to_add, Lisp_Object selection_type)
 207 {
 208   struct device *d = decode_x_device (Qnil);
 209   Display *display = DEVICE_X_DISPLAY (d);
 210   struct frame *sel_frame = selected_frame ();
 211   Window selecting_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
 212   Lisp_Object selection_time;
 213   /* Use the time of the last-read mouse or keyboard event.
 214      For selection purposes, we use this as a sleazy way of knowing what the
 215      current time is in server-time.  This assumes that the most recently read
 216      mouse or keyboard event has something to do with the assertion of the
 217      selection, which is probably true.
 218      */
 219   Time thyme = DEVICE_X_MOUSE_TIMESTAMP (d);
 220   Atom selection_atom;
 221
 222   CHECK_SYMBOL (selection_name);
 223   selection_atom = symbol_to_x_atom (d, selection_name, 0);
 224
 225   XSetSelectionOwner (display, selection_atom, selecting_window, thyme);
 226
 227   /* We do NOT use time_to_lisp() here any more, like we used to.
 228      That assumed equivalence of time_t and Time, which is not
 229      necessarily the case (e.g. under OSF on the Alphas, where
 230      Time is a 64-bit quantity and time_t is a 32-bit quantity).
 231
 232      Opaque pointers are the clean way to go here.
 233   */
 234   selection_time = make_opaque (&thyme, sizeof (thyme));
 235
 236 #ifdef MOTIF_CLIPBOARDS
 237   hack_motif_clipboard_selection (selection_atom, selection_value,
 238                                   thyme, display, selecting_window);
 239 #endif
 240   return selection_time;
 241 }
 242
 243 #ifdef MOTIF_CLIPBOARDS /* Bend over baby.  Take it and like it. */
 244
 245 # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
 246 static void motif_clipboard_cb ();
 247 # endif
 248
 249 static void
 250 hack_motif_clipboard_selection (Atom selection_atom,
 251                                 Lisp_Object selection_value,
 252                                 Time thyme,
 253                                 Display *display,
 254                                 Window selecting_window)
 255      /*                         Bool owned_p)*/
 256 {
 257   struct device *d = get_device_from_display (display);
 258   /* Those Motif wankers can't be bothered to follow the ICCCM, and do
 259      their own non-Xlib non-Xt clipboard processing.  So we have to do
 260      this so that linked-in Motif widgets don't get themselves wedged.
 261    */
 262   if (selection_atom == DEVICE_XATOM_CLIPBOARD (d)
 263       && STRINGP (selection_value)
 264
 265       /* If we already own the clipboard, don't own it again in the Motif
 266          way.  This might lose in some subtle way, since the timestamp won't
 267          be current, but owning the selection on the Motif way does a
 268          SHITLOAD of X protocol, and it makes killing text be incredibly
 269          slow when using an X terminal.  ARRRRGGGHHH!!!!
 270        */
 271       /* No, this is no good, because then Motif text fields don't bother
 272          to look up the new value, and you can't Copy from a buffer, Paste
 273          into a text field, then Copy something else from the buffer and
 274          paste it into the text field -- it pastes the first thing again. */
 275 /*      && !owned_p */
 276       )
 277     {
 278 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
 279       Widget widget = FRAME_X_TEXT_WIDGET (selected_frame());
 280 #endif
 281       long itemid;
 282 #if XmVersion >= 1002
 283       long dataid;
 284 #else
 285       int dataid;       /* 1.2 wants long, but 1.1.5 wants int... */
 286 #endif
 287       XmString fmh;
 288       String encoding = "STRING";
 289       const Extbyte *data  = XSTRING_DATA (selection_value);
 290       Extcount bytes = XSTRING_LENGTH (selection_value);
 291
 292 #ifdef MULE
 293       {
 294         enum { ASCII, LATIN_1, WORLD } chartypes = ASCII;
 295         const Bufbyte *ptr = data, *end = ptr + bytes;
 296         /* Optimize for the common ASCII case */
 297         while (ptr <= end)
 298           {
 299             if (BYTE_ASCII_P (*ptr))
 300               {
 301                 ptr++;
 302                 continue;
 303               }
 304
 305             if ((*ptr) == LEADING_BYTE_LATIN_ISO8859_1 ||
 306                 (*ptr) == LEADING_BYTE_CONTROL_1)
 307               {
 308                 chartypes = LATIN_1;
 309                 ptr += 2;
 310                 continue;
 311               }
 312
 313             chartypes = WORLD;
 314             break;
 315           }
 316
 317         if (chartypes == LATIN_1)
 318           TO_EXTERNAL_FORMAT (LISP_STRING, selection_value,
 319                               ALLOCA, (data, bytes),
 320                               Qbinary);
 321         else if (chartypes == WORLD)
 322           {
 323             TO_EXTERNAL_FORMAT (LISP_STRING, selection_value,
 324                                 ALLOCA, (data, bytes),
 325                                 Qctext);
 326             encoding = "COMPOUND_TEXT";
 327           }
 328       }
 329 #endif /* MULE */
 330
 331       fmh = XmStringCreateLtoR ("Clipboard", XmSTRING_DEFAULT_CHARSET);
 332       while (ClipboardSuccess !=
 333              XmClipboardStartCopy (display, selecting_window, fmh, thyme,
 334 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
 335                                    widget, motif_clipboard_cb,
 336 #else
 337                                    0, NULL,
 338 #endif
 339                                    &itemid))
 340         ;
 341       XmStringFree (fmh);
 342       while (ClipboardSuccess !=
 343              XmClipboardCopy (display, selecting_window, itemid, encoding,
 344 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
 345                               /* O'Reilly examples say size can be 0,
 346                                  but this clearly is not the case. */
 347                               0, bytes, (int) selecting_window, /* private id */
 348 #else /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
 349                               (XtPointer) data, bytes, 0,
 350 #endif /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
 351                               &dataid))
 352         ;
 353       while (ClipboardSuccess !=
 354              XmClipboardEndCopy (display, selecting_window, itemid))
 355         ;
 356     }
 357 }
 358
 359 # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
 360 /* I tried to treat the clipboard like a real selection, and not send
 361    the data until it was requested, but it looks like that just doesn't
 362    work at all unless the selection owner and requestor are in different
 363    processes.  From reading the Motif source, it looks like they never
 364    even considered having two widgets in the same application transfer
 365    data between each other using "by-name" clipboard values.  What a
 366    bunch of fuckups.
 367  */
 368 static void
 369 motif_clipboard_cb (Widget widget, int *data_id, int *private_id, int *reason)
 370 {
 371   switch (*reason)
 372     {
 373     case XmCR_CLIPBOARD_DATA_REQUEST:
 374       {
 375         Display *dpy = XtDisplay (widget);
 376         Window window = (Window) *private_id;
 377         Lisp_Object selection = select_convert_out (QCLIPBOARD, Qnil, Qnil);
 378
 379         /* Whichever lazy git wrote this originally just called abort()
 380            when anything didn't go their way... */
 381
 382         /* Try some other text types */
 383         if (NILP (selection))
 384           selection = select_convert_out (QCLIPBOARD, QSTRING, Qnil);
 385         if (NILP (selection))
 386           selection = select_convert_out (QCLIPBOARD, QTEXT, Qnil);
 387         if (NILP (selection))
 388           selection = select_convert_out (QCLIPBOARD, QCOMPOUND_TEXT, Qnil);
 389
 390         if (CONSP (selection) && SYMBOLP (XCAR (selection))
 391             && (EQ (XCAR (selection), QSTRING)
 392                 || EQ (XCAR (selection), QTEXT)
 393                 || EQ (XCAR (selection), QCOMPOUND_TEXT)))
 394           selection = XCDR (selection);
 395
 396         if (NILP (selection))
 397           signal_error (Qselection_conversion_error,
 398                         build_string ("no selection"));
 399
 400         if (!STRINGP (selection))
 401           signal_error (Qselection_conversion_error,
 402                         build_string ("couldn't convert selection to string"));
 403
 404
 405         XmClipboardCopyByName (dpy, window, *data_id,
 406                                (char *) XSTRING_DATA (selection),
 407                                XSTRING_LENGTH (selection) + 1,
 408                                0);
 409       }
 410       break;
 411     case XmCR_CLIPBOARD_DATA_DELETE:
 412     default:
 413       /* don't need to free anything */
 414       break;
 415     }
 416 }
 417 # endif /* MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
 418 #endif /* MOTIF_CLIPBOARDS */
 419
 420
 421
 422
 423 /* Send a SelectionNotify event to the requestor with property=None, meaning
 424    we were unable to do what they wanted.
 425  */
 426 static void
 427 x_decline_selection_request (XSelectionRequestEvent *event)
 428 {
 429   XSelectionEvent reply;
 430   reply.type      = SelectionNotify;
 431   reply.display   = event->display;
 432   reply.requestor = event->requestor;
 433   reply.selection = event->selection;
 434   reply.time      = event->time;
 435   reply.target    = event->target;
 436   reply.property  = None;
 437
 438   XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
 439   XFlush (reply.display);
 440 }
 441
 442
 443 /* Used as an unwind-protect clause so that, if a selection-converter signals
 444    an error, we tell the requestor that we were unable to do what they wanted
 445    before we throw to top-level or go into the debugger or whatever.
 446  */
 447 static Lisp_Object
 448 x_selection_request_lisp_error (Lisp_Object closure)
 449 {
 450   XSelectionRequestEvent *event = (XSelectionRequestEvent *)
 451     get_opaque_ptr (closure);
 452
 453   free_opaque_ptr (closure);
 454   if (event->type == 0) /* we set this to mean "completed normally" */
 455     return Qnil;
 456   x_decline_selection_request (event);
 457   return Qnil;
 458 }
 459
 460
 461 /* Convert our selection to the requested type, and put that data where the
 462    requestor wants it.  Then tell them whether we've succeeded.
 463  */
 464 static void
 465 x_reply_selection_request (XSelectionRequestEvent *event, int format,
 466                            unsigned char *data, int size, Atom type)
 467 {
 468   /* This function can GC */
 469   XSelectionEvent reply;
 470   Display *display = event->display;
 471   struct device *d = get_device_from_display (display);
 472   Window window = event->requestor;
 473   int bytes_remaining;
 474   int format_bytes = format/8;
 475   int max_bytes = SELECTION_QUANTUM (display);
 476   if (max_bytes > MAX_SELECTION_QUANTUM) max_bytes = MAX_SELECTION_QUANTUM;
 477
 478   reply.type      = SelectionNotify;
 479   reply.display   = display;
 480   reply.requestor = window;
 481   reply.selection = event->selection;
 482   reply.time      = event->time;
 483   reply.target    = event->target;
 484   reply.property  = (event->property == None ? event->target : event->property);
 485
 486   /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
 487
 488   /* Store the data on the requested property.
 489      If the selection is large, only store the first N bytes of it.
 490    */
 491   bytes_remaining = size * format_bytes;
 492   if (bytes_remaining <= max_bytes)
 493     {
 494       /* Send all the data at once, with minimal handshaking. */
 495 #if 0
 496       stderr_out ("\nStoring all %d\n", bytes_remaining);
 497 #endif
 498       XChangeProperty (display, window, reply.property, type, format,
 499                        PropModeReplace, data, size);
 500       /* At this point, the selection was successfully stored; ack it. */
 501       XSendEvent (display, window, False, 0L, (XEvent *) &reply);
 502       XFlush (display);
 503     }
 504   else
 505     {
 506       /* Send an INCR selection. */
 507       int prop_id;
 508
 509       if (x_window_to_frame (d, window)) /* #### debug */
 510         error ("attempt to transfer an INCR to ourself!");
 511 #if 0
 512       stderr_out ("\nINCR %d\n", bytes_remaining);
 513 #endif
 514       prop_id = expect_property_change (display, window, reply.property,
 515                                         PropertyDelete);
 516
 517       XChangeProperty (display, window, reply.property, DEVICE_XATOM_INCR (d),
 518                        32, PropModeReplace, (unsigned char *)
 519                        &bytes_remaining, 1);
 520       XSelectInput (display, window, PropertyChangeMask);
 521       /* Tell 'em the INCR data is there... */
 522       XSendEvent (display, window, False, 0L, (XEvent *) &reply);
 523       XFlush (display);
 524
 525       /* First, wait for the requestor to ack by deleting the property.
 526          This can run random lisp code (process handlers) or signal.
 527        */
 528       wait_for_property_change (prop_id);
 529
 530       while (bytes_remaining)
 531         {
 532           int i = ((bytes_remaining < max_bytes)
 533                    ? bytes_remaining
 534                    : max_bytes);
 535           prop_id = expect_property_change (display, window, reply.property,
 536                                             PropertyDelete);
 537 #if 0
 538           stderr_out ("  INCR adding %d\n", i);
 539 #endif
 540           /* Append the next chunk of data to the property. */
 541           XChangeProperty (display, window, reply.property, type, format,
 542                            PropModeAppend, data, i / format_bytes);
 543           bytes_remaining -= i;
 544           data += i;
 545
 546           /* Now wait for the requestor to ack this chunk by deleting the
 547              property.   This can run random lisp code or signal.
 548            */
 549           wait_for_property_change (prop_id);
 550         }
 551       /* Now write a zero-length chunk to the property to tell the requestor
 552          that we're done. */
 553 #if 0
 554       stderr_out ("  INCR done\n");
 555 #endif
 556       if (! waiting_for_other_props_on_window (display, window))
 557         XSelectInput (display, window, 0L);
 558
 559       XChangeProperty (display, window, reply.property, type, format,
 560                        PropModeReplace, data, 0);
 561     }
 562 }
 563
 564
 565
 566 /* Called from the event-loop in response to a SelectionRequest event.
 567  */
 568 void
 569 x_handle_selection_request (XSelectionRequestEvent *event)
 570 {
 571   /* This function can GC */
 572   struct gcpro gcpro1, gcpro2;
 573   Lisp_Object temp_obj;
 574   Lisp_Object selection_symbol;
 575   Lisp_Object target_symbol = Qnil;
 576   Lisp_Object converted_selection = Qnil;
 577   Time local_selection_time;
 578   Lisp_Object successful_p = Qnil;
 579   int count;
 580   struct device *d = get_device_from_display (event->display);
 581
 582   GCPRO2 (converted_selection, target_symbol);
 583
 584   selection_symbol = x_atom_to_symbol (d, event->selection);
 585   target_symbol = x_atom_to_symbol (d, event->target);
 586
 587 #if 0 /* #### MULTIPLE doesn't work yet */
 588   if (EQ (target_symbol, QMULTIPLE))
 589     target_symbol = fetch_multiple_target (event);
 590 #endif
 591
 592   temp_obj = Fget_selection_timestamp (selection_symbol);
 593
 594   if (NILP (temp_obj))
 595     {
 596       /* We don't appear to have the selection. */
 597       x_decline_selection_request (event);
 598
 599       goto DONE_LABEL;
 600     }
 601
 602   local_selection_time = * (Time *) XOPAQUE_DATA (temp_obj);
 603
 604   if (event->time != CurrentTime &&
 605       local_selection_time > event->time)
 606     {
 607       /* Someone asked for the selection, and we have one, but not the one
 608          they're looking for. */
 609       x_decline_selection_request (event);
 610       goto DONE_LABEL;
 611     }
 612
 613   converted_selection = select_convert_out (selection_symbol,
 614                                             target_symbol, Qnil);
 615
 616   /* #### Is this the right thing to do? I'm no X expert. -- ajh */
 617   if (NILP (converted_selection))
 618     {
 619       /* We don't appear to have a selection in that data type. */
 620       x_decline_selection_request (event);
 621       goto DONE_LABEL;
 622     }
 623
 624   count = specpdl_depth ();
 625   record_unwind_protect (x_selection_request_lisp_error,
 626                          make_opaque_ptr (event));
 627
 628   {
 629     unsigned char *data;
 630     unsigned int size;
 631     int format;
 632     Atom type;
 633     lisp_data_to_selection_data (d, converted_selection,
 634                                  &data, &type, &size, &format);
 635
 636     x_reply_selection_request (event, format, data, size, type);
 637     successful_p = Qt;
 638     /* Tell x_selection_request_lisp_error() it's cool. */
 639     event->type = 0;
 640     xfree (data);
 641   }
 642
 643   unbind_to (count, Qnil);
 644
 645  DONE_LABEL:
 646
 647   UNGCPRO;
 648
 649   /* Let random lisp code notice that the selection has been asked for. */
 650   {
 651     Lisp_Object val = Vx_sent_selection_hooks;
 652     if (!UNBOUNDP (val) && !NILP (val))
 653       {
 654         Lisp_Object rest;
 655         if (CONSP (val) && !EQ (XCAR (val), Qlambda))
 656           for (rest = val; !NILP (rest); rest = Fcdr (rest))
 657             call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
 658         else
 659           call3 (val, selection_symbol, target_symbol, successful_p);
 660       }
 661   }
 662 }
 663
 664
 665 /* Called from the event-loop in response to a SelectionClear event.
 666  */
 667 void
 668 x_handle_selection_clear (XSelectionClearEvent *event)
 669 {
 670   Display *display = event->display;
 671   struct device *d = get_device_from_display (display);
 672   Atom selection = event->selection;
 673   Time changed_owner_time = event->time;
 674
 675   Lisp_Object selection_symbol, local_selection_time_lisp;
 676   Time local_selection_time;
 677
 678   selection_symbol = x_atom_to_symbol (d, selection);
 679
 680   local_selection_time_lisp = Fget_selection_timestamp (selection_symbol);
 681
 682   /* We don't own the selection, so that's fine. */
 683   if (NILP (local_selection_time_lisp))
 684     return;
 685
 686   local_selection_time = * (Time *) XOPAQUE_DATA (local_selection_time_lisp);
 687
 688   /* This SelectionClear is for a selection that we no longer own, so we can
 689      disregard it.  (That is, we have reasserted the selection since this
 690      request was generated.)
 691    */
 692   if (changed_owner_time != CurrentTime &&
 693       local_selection_time > changed_owner_time)
 694     return;
 695
 696   handle_selection_clear (selection_symbol);
 697 }
 698
 699 \f
 700 /* This stuff is so that INCR selections are reentrant (that is, so we can
 701    be servicing multiple INCR selection requests simultaneously).  I haven't
 702    actually tested that yet.
 703  */
 704
 705 static int prop_location_tick;
 706
 707 static struct prop_location {
 708   int tick;
 709   Display *display;
 710   Window window;
 711   Atom property;
 712   int desired_state;
 713   struct prop_location *next;
 714 } *for_whom_the_bell_tolls;
 715
 716
 717 static int
 718 property_deleted_p (void *tick)
 719 {
 720   struct prop_location *rest = for_whom_the_bell_tolls;
 721   while (rest)
 722     if (rest->tick == (long) tick)
 723       return 0;
 724     else
 725       rest = rest->next;
 726   return 1;
 727 }
 728
 729 static int
 730 waiting_for_other_props_on_window (Display *display, Window window)
 731 {
 732   struct prop_location *rest = for_whom_the_bell_tolls;
 733   while (rest)
 734     if (rest->display == display && rest->window == window)
 735       return 1;
 736     else
 737       rest = rest->next;
 738   return 0;
 739 }
 740
 741
 742 static int
 743 expect_property_change (Display *display, Window window,
 744                         Atom property, int state)
 745 {
 746   struct prop_location *pl = xnew (struct prop_location);
 747   pl->tick = ++prop_location_tick;
 748   pl->display = display;
 749   pl->window = window;
 750   pl->property = property;
 751   pl->desired_state = state;
 752   pl->next = for_whom_the_bell_tolls;
 753   for_whom_the_bell_tolls = pl;
 754   return pl->tick;
 755 }
 756
 757 static void
 758 unexpect_property_change (int tick)
 759 {
 760   struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
 761   while (rest)
 762     {
 763       if (rest->tick == tick)
 764         {
 765           if (prev)
 766             prev->next = rest->next;
 767           else
 768             for_whom_the_bell_tolls = rest->next;
 769           xfree (rest);
 770           return;
 771         }
 772       prev = rest;
 773       rest = rest->next;
 774     }
 775 }
 776
 777 static void
 778 wait_for_property_change (long tick)
 779 {
 780   /* This function can GC */
 781   wait_delaying_user_input (property_deleted_p, (void *) tick);
 782 }
 783
 784
 785 /* Called from the event-loop in response to a PropertyNotify event.
 786  */
 787 void
 788 x_handle_property_notify (XPropertyEvent *event)
 789 {
 790   struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
 791   while (rest)
 792     {
 793       if (rest->property == event->atom &&
 794           rest->window == event->window &&
 795           rest->display == event->display &&
 796           rest->desired_state == event->state)
 797         {
 798 #if 0
 799           stderr_out ("Saw expected prop-%s on %s\n",
 800                    (event->state == PropertyDelete ? "delete" : "change"),
 801                       (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name);
 802 #endif
 803           if (prev)
 804             prev->next = rest->next;
 805           else
 806             for_whom_the_bell_tolls = rest->next;
 807           xfree (rest);
 808           return;
 809         }
 810       prev = rest;
 811       rest = rest->next;
 812     }
 813 #if 0
 814   stderr_out ("Saw UNexpected prop-%s on %s\n",
 815            (event->state == PropertyDelete ? "delete" : "change"),
 816            (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name));
 817 #endif
 818 }
 819
 820
 821 \f
 822 #if 0 /* #### MULTIPLE doesn't work yet */
 823
 824 static Lisp_Object
 825 fetch_multiple_target (XSelectionRequestEvent *event)
 826 {
 827   /* This function can GC */
 828   Display *display = event->display;
 829   Window window = event->requestor;
 830   Atom target = event->target;
 831   Atom selection_atom = event->selection;
 832   int result;
 833
 834   return
 835     Fcons (QMULTIPLE,
 836            x_get_window_property_as_lisp_data (display, window, target,
 837                                                QMULTIPLE,
 838                                                selection_atom));
 839 }
 840
 841 static Lisp_Object
 842 copy_multiple_data (Lisp_Object obj)
 843 {
 844   Lisp_Object vec;
 845   int i;
 846   int len;
 847   if (CONSP (obj))
 848     return Fcons (XCAR (obj), copy_multiple_data (XCDR (obj)));
 849
 850   CHECK_VECTOR (obj);
 851   len = XVECTOR_LENGTH (obj);
 852   vec = make_vector (len, Qnil);
 853   for (i = 0; i < len; i++)
 854     {
 855       Lisp_Object vec2 = XVECTOR_DATA (obj) [i];
 856       CHECK_VECTOR (vec2);
 857       if (XVECTOR_LENGTH (vec2) != 2)
 858         signal_error (Qerror, list2 (build_string
 859                                      ("vectors must be of length 2"),
 860                                      vec2));
 861       XVECTOR_DATA (vec) [i] = make_vector (2, Qnil);
 862       XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [0] = XVECTOR_DATA (vec2) [0];
 863       XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [1] = XVECTOR_DATA (vec2) [1];
 864     }
 865   return vec;
 866 }
 867
 868 #endif /* 0 */
 869
 870 \f
 871 static Window reading_selection_reply;
 872 static Atom reading_which_selection;
 873 static int selection_reply_timed_out;
 874
 875 static int
 876 selection_reply_done (void *ignore)
 877 {
 878   return !reading_selection_reply;
 879 }
 880
 881 static Lisp_Object Qx_selection_reply_timeout_internal;
 882
 883 DEFUN ("x-selection-reply-timeout-internal", Fx_selection_reply_timeout_internal,
 884        1, 1, 0, /*
 885 */
 886        (arg))
 887 {
 888   selection_reply_timed_out = 1;
 889   reading_selection_reply = 0;
 890   return Qnil;
 891 }
 892
 893
 894 /* Do protocol to read selection-data from the server.
 895    Converts this to lisp data and returns it.
 896  */
 897 static Lisp_Object
 898 x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
 899 {
 900   /* This function can GC */
 901   struct device *d = decode_x_device (Qnil);
 902   Display *display = DEVICE_X_DISPLAY (d);
 903   struct frame *sel_frame = selected_frame ();
 904   Window requestor_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
 905   Time requestor_time = DEVICE_X_MOUSE_TIMESTAMP (d);
 906   Atom target_property = DEVICE_XATOM_EMACS_TMP (d);
 907   Atom selection_atom = symbol_to_x_atom (d, selection_symbol, 0);
 908   int speccount;
 909   Atom type_atom = symbol_to_x_atom (d, (CONSP (target_type) ?
 910                                          XCAR (target_type) : target_type), 0);
 911
 912   XConvertSelection (display, selection_atom, type_atom, target_property,
 913                      requestor_window, requestor_time);
 914
 915   /* Block until the reply has been read. */
 916   reading_selection_reply = requestor_window;
 917   reading_which_selection = selection_atom;
 918   selection_reply_timed_out = 0;
 919
 920   speccount = specpdl_depth ();
 921
 922   /* add a timeout handler */
 923   if (x_selection_timeout > 0)
 924     {
 925       Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout),
 926                                      Qx_selection_reply_timeout_internal,
 927                                      Qnil, Qnil);
 928       record_unwind_protect (Fdisable_timeout, id);
 929     }
 930
 931   /* This is ^Gable */
 932   wait_delaying_user_input (selection_reply_done, 0);
 933
 934   if (selection_reply_timed_out)
 935     error ("timed out waiting for reply from selection owner");
 936
 937   unbind_to (speccount, Qnil);
 938
 939   /* otherwise, the selection is waiting for us on the requested property. */
 940
 941   return select_convert_in (selection_symbol,
 942                             target_type,
 943                             x_get_window_property_as_lisp_data(display,
 944                                                                requestor_window,
 945                                                                target_property,
 946                                                                target_type,
 947                                                                selection_atom));
 948 }
 949
 950
 951 static void
 952 x_get_window_property (Display *display, Window window, Atom property,
 953                        unsigned char **data_ret, int *bytes_ret,
 954                        Atom *actual_type_ret, int *actual_format_ret,
 955                        unsigned long *actual_size_ret, int delete_p)
 956 {
 957   int total_size;
 958   unsigned long bytes_remaining;
 959   int offset = 0;
 960   unsigned char *tmp_data = 0;
 961   int result;
 962   int buffer_size = SELECTION_QUANTUM (display);
 963   if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
 964
 965   /* First probe the thing to find out how big it is. */
 966   result = XGetWindowProperty (display, window, property,
 967                                0, 0, False, AnyPropertyType,
 968                                actual_type_ret, actual_format_ret,
 969                                actual_size_ret,
 970                                &bytes_remaining, &tmp_data);
 971   if (result != Success)
 972     {
 973       *data_ret = 0;
 974       *bytes_ret = 0;
 975       return;
 976     }
 977   XFree ((char *) tmp_data);
 978
 979   if (*actual_type_ret == None || *actual_format_ret == 0)
 980     {
 981       if (delete_p) XDeleteProperty (display, window, property);
 982       *data_ret = 0;
 983       *bytes_ret = 0;
 984       return;
 985     }
 986
 987   total_size = bytes_remaining + 1;
 988   *data_ret = (unsigned char *) xmalloc (total_size);
 989
 990   /* Now read, until we've gotten it all. */
 991   while (bytes_remaining)
 992     {
 993 #if 0
 994       int last = bytes_remaining;
 995 #endif
 996       result =
 997         XGetWindowProperty (display, window, property,
 998                             offset/4, buffer_size/4,
 999                             (delete_p ? True : False),
1000                             AnyPropertyType,
1001                             actual_type_ret, actual_format_ret,
1002                             actual_size_ret, &bytes_remaining, &tmp_data);
1003 #if 0
1004       stderr_out ("<< read %d\n", last-bytes_remaining);
1005 #endif
1006       /* If this doesn't return Success at this point, it means that
1007          some clod deleted the selection while we were in the midst of
1008          reading it.  Deal with that, I guess....
1009        */
1010       if (result != Success) break;
1011       *actual_size_ret *= *actual_format_ret / 8;
1012       memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
1013       offset += *actual_size_ret;
1014       XFree ((char *) tmp_data);
1015     }
1016   *bytes_ret = offset;
1017 }
1018
1019
1020 static void
1021 receive_incremental_selection (Display *display, Window window, Atom property,
1022                                /* this one is for error messages only */
1023                                Lisp_Object target_type,
1024                                unsigned int min_size_bytes,
1025                                unsigned char **data_ret, int *size_bytes_ret,
1026                                Atom *type_ret, int *format_ret,
1027                                unsigned long *size_ret)
1028 {
1029   /* This function can GC */
1030   int offset = 0;
1031   int prop_id;
1032   *size_bytes_ret = min_size_bytes;
1033   *data_ret = (unsigned char *) xmalloc (*size_bytes_ret);
1034 #if 0
1035   stderr_out ("\nread INCR %d\n", min_size_bytes);
1036 #endif
1037   /* At this point, we have read an INCR property, and deleted it (which
1038      is how we ack its receipt: the sending window will be selecting
1039      PropertyNotify events on our window to notice this).
1040
1041      Now, we must loop, waiting for the sending window to put a value on
1042      that property, then reading the property, then deleting it to ack.
1043      We are done when the sender places a property of length 0.
1044    */
1045   prop_id = expect_property_change (display, window, property,
1046                                     PropertyNewValue);
1047   while (1)
1048     {
1049       unsigned char *tmp_data;
1050       int tmp_size_bytes;
1051       wait_for_property_change (prop_id);
1052       /* expect it again immediately, because x_get_window_property may
1053          .. no it won't, I don't get it.
1054          .. Ok, I get it now, the Xt code that implements INCR is broken.
1055        */
1056       prop_id = expect_property_change (display, window, property,
1057                                         PropertyNewValue);
1058       x_get_window_property (display, window, property,
1059                              &tmp_data, &tmp_size_bytes,
1060                              type_ret, format_ret, size_ret, 1);
1061
1062       if (tmp_size_bytes == 0) /* we're done */
1063         {
1064 #if 0
1065           stderr_out ("  read INCR done\n");
1066 #endif
1067           unexpect_property_change (prop_id);
1068           if (tmp_data) xfree (tmp_data);
1069           break;
1070         }
1071 #if 0
1072       stderr_out ("  read INCR %d\n", tmp_size_bytes);
1073 #endif
1074       if (*size_bytes_ret < offset + tmp_size_bytes)
1075         {
1076 #if 0
1077           stderr_out ("  read INCR realloc %d -> %d\n",
1078                    *size_bytes_ret, offset + tmp_size_bytes);
1079 #endif
1080           *size_bytes_ret = offset + tmp_size_bytes;
1081           *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret);
1082         }
1083       memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
1084       offset += tmp_size_bytes;
1085       xfree (tmp_data);
1086     }
1087 }
1088
1089
1090 static Lisp_Object
1091 x_get_window_property_as_lisp_data (Display *display,
1092                                     Window window,
1093                                     Atom property,
1094                                     /* next two for error messages only */
1095                                     Lisp_Object target_type,
1096                                     Atom selection_atom)
1097 {
1098   /* This function can GC */
1099   Atom actual_type;
1100   int actual_format;
1101   unsigned long actual_size;
1102   unsigned char *data = NULL;
1103   int bytes = 0;
1104   Lisp_Object val;
1105   struct device *d = get_device_from_display (display);
1106
1107   x_get_window_property (display, window, property, &data, &bytes,
1108                          &actual_type, &actual_format, &actual_size, 1);
1109   if (! data)
1110     {
1111       if (XGetSelectionOwner (display, selection_atom))
1112         /* there is a selection owner */
1113         signal_error
1114           (Qselection_conversion_error,
1115            Fcons (build_string ("selection owner couldn't convert"),
1116                   Fcons (x_atom_to_symbol (d, selection_atom),
1117                          actual_type ?
1118                          list2 (target_type, x_atom_to_symbol (d, actual_type)) :
1119                          list1 (target_type))));
1120       else
1121         signal_error (Qerror,
1122                       list2 (build_string ("no selection"),
1123                              x_atom_to_symbol (d, selection_atom)));
1124     }
1125
1126   if (actual_type == DEVICE_XATOM_INCR (d))
1127     {
1128       /* Ok, that data wasn't *the* data, it was just the beginning. */
1129
1130       unsigned int min_size_bytes = * ((unsigned int *) data);
1131       xfree (data);
1132       receive_incremental_selection (display, window, property, target_type,
1133                                      min_size_bytes, &data, &bytes,
1134                                      &actual_type, &actual_format,
1135                                      &actual_size);
1136     }
1137
1138   /* It's been read.  Now convert it to a lisp object in some semi-rational
1139      manner. */
1140   val = selection_data_to_lisp_data (d, data, bytes,
1141                                      actual_type, actual_format);
1142
1143   xfree (data);
1144   return val;
1145 }
1146 \f
1147 /* #### These are going to move into Lisp code(!) with the aid of
1148         some new functions I'm working on - ajh */
1149
1150 /* These functions convert from the selection data read from the server into
1151    something that we can use from elisp, and vice versa.
1152
1153         Type:   Format: Size:           Elisp Type:
1154         -----   ------- -----           -----------
1155         *       8       *               String
1156         ATOM    32      1               Symbol
1157         ATOM    32      > 1             Vector of Symbols
1158         *       16      1               Integer
1159         *       16      > 1             Vector of Integers
1160         *       32      1               if <=16 bits: Integer
1161                                         if > 16 bits: Cons of top16, bot16
1162         *       32      > 1             Vector of the above
1163
1164    When converting a Lisp number to C, it is assumed to be of format 16 if
1165    it is an integer, and of format 32 if it is a cons of two integers.
1166
1167    When converting a vector of numbers from Elisp to C, it is assumed to be
1168    of format 16 if every element in the vector is an integer, and is assumed
1169    to be of format 32 if any element is a cons of two integers.
1170
1171    When converting an object to C, it may be of the form (SYMBOL . <data>)
1172    where SYMBOL is what we should claim that the type is.  Format and
1173    representation are as above.
1174
1175    NOTE: Under Mule, when someone shoves us a string without a type, we
1176    set the type to 'COMPOUND_TEXT and automatically convert to Compound
1177    Text.  If the string has a type, we assume that the user wants the
1178    data sent as-is so we just do "binary" conversion.
1179  */
1180
1181
1182 static Lisp_Object
1183 selection_data_to_lisp_data (struct device *d,
1184                              unsigned char *data,
1185                              size_t size,
1186                              Atom type,
1187                              int format)
1188 {
1189   if (type == DEVICE_XATOM_NULL (d))
1190     return QNULL;
1191
1192   /* Convert any 8-bit data to a string, for compactness. */
1193   else if (format == 8)
1194     return make_ext_string (data, size,
1195                             type == DEVICE_XATOM_TEXT (d) ||
1196                             type == DEVICE_XATOM_COMPOUND_TEXT (d)
1197                             ? Qctext : Qbinary);
1198
1199   /* Convert a single atom to a Lisp Symbol.
1200      Convert a set of atoms to a vector of symbols. */
1201   else if (type == XA_ATOM)
1202     {
1203       if (size == sizeof (Atom))
1204         return x_atom_to_symbol (d, *((Atom *) data));
1205       else
1206         {
1207           int i;
1208           int len = size / sizeof (Atom);
1209           Lisp_Object v = Fmake_vector (make_int (len), Qzero);
1210           for (i = 0; i < len; i++)
1211             Faset (v, make_int (i), x_atom_to_symbol (d, ((Atom *) data) [i]));
1212           return v;
1213         }
1214     }
1215
1216   /* Convert a single 16 or small 32 bit number to a Lisp Int.
1217      If the number is > 16 bits, convert it to a cons of integers,
1218      16 bits in each half.
1219    */
1220   else if (format == 32 && size == sizeof (long))
1221     return word_to_lisp (((unsigned long *) data) [0]);
1222   else if (format == 16 && size == sizeof (short))
1223     return make_int ((int) (((unsigned short *) data) [0]));
1224
1225   /* Convert any other kind of data to a vector of numbers, represented
1226      as above (as an integer, or a cons of two 16 bit integers).
1227
1228      #### Perhaps we should return the actual type to lisp as well.
1229
1230         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1231         ==> [4 4]
1232
1233      and perhaps it should be
1234
1235         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1236         ==> (SPAN . [4 4])
1237
1238      Right now the fact that the return type was SPAN is discarded before
1239      lisp code gets to see it.
1240    */
1241   else if (format == 16)
1242     {
1243       int i;
1244       Lisp_Object v = make_vector (size / 4, Qzero);
1245       for (i = 0; i < (int) size / 4; i++)
1246         {
1247           int j = (int) ((unsigned short *) data) [i];
1248           Faset (v, make_int (i), make_int (j));
1249         }
1250       return v;
1251     }
1252   else
1253     {
1254       int i;
1255       Lisp_Object v = make_vector (size / 4, Qzero);
1256       for (i = 0; i < (int) size / 4; i++)
1257         {
1258           unsigned long j = ((unsigned long *) data) [i];
1259           Faset (v, make_int (i), word_to_lisp (j));
1260         }
1261       return v;
1262     }
1263 }
1264
1265
1266 static void
1267 lisp_data_to_selection_data (struct device *d,
1268                              Lisp_Object obj,
1269                              unsigned char **data_ret,
1270                              Atom *type_ret,
1271                              unsigned int *size_ret,
1272                              int *format_ret)
1273 {
1274   Lisp_Object type = Qnil;
1275
1276   if (CONSP (obj) && SYMBOLP (XCAR (obj)))
1277     {
1278       type = XCAR (obj);
1279       obj = XCDR (obj);
1280       if (CONSP (obj) && NILP (XCDR (obj)))
1281         obj = XCAR (obj);
1282     }
1283
1284   if (EQ (obj, QNULL) || (EQ (type, QNULL)))
1285     {                           /* This is not the same as declining */
1286       *format_ret = 32;
1287       *size_ret = 0;
1288       *data_ret = 0;
1289       type = QNULL;
1290     }
1291   else if (STRINGP (obj))
1292     {
1293       const Extbyte *extval;
1294       Extcount extvallen;
1295
1296       TO_EXTERNAL_FORMAT (LISP_STRING, obj,
1297                           ALLOCA, (extval, extvallen),
1298                           (NILP (type) ? Qctext : Qbinary));
1299       *format_ret = 8;
1300       *size_ret = extvallen;
1301       *data_ret = (unsigned char *) xmalloc (*size_ret);
1302       memcpy (*data_ret, extval, *size_ret);
1303 #ifdef MULE
1304       if (NILP (type)) type = QCOMPOUND_TEXT;
1305 #else
1306       if (NILP (type)) type = QSTRING;
1307 #endif
1308     }
1309   else if (CHARP (obj))
1310     {
1311       Bufbyte buf[MAX_EMCHAR_LEN];
1312       Bytecount len;
1313       const Extbyte *extval;
1314       Extcount extvallen;
1315
1316       *format_ret = 8;
1317       len = set_charptr_emchar (buf, XCHAR (obj));
1318       TO_EXTERNAL_FORMAT (DATA, (buf, len),
1319                           ALLOCA, (extval, extvallen),
1320                           Qctext);
1321       *size_ret = extvallen;
1322       *data_ret = (unsigned char *) xmalloc (*size_ret);
1323       memcpy (*data_ret, extval, *size_ret);
1324 #ifdef MULE
1325       if (NILP (type)) type = QCOMPOUND_TEXT;
1326 #else
1327       if (NILP (type)) type = QSTRING;
1328 #endif
1329     }
1330   else if (SYMBOLP (obj))
1331     {
1332       *format_ret = 32;
1333       *size_ret = 1;
1334       *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
1335       (*data_ret) [sizeof (Atom)] = 0;
1336       (*(Atom **) data_ret) [0] = symbol_to_x_atom (d, obj, 0);
1337       if (NILP (type)) type = QATOM;
1338     }
1339   else if (INTP (obj) &&
1340            XINT (obj) <= 0x7FFF &&
1341            XINT (obj) >= -0x8000)
1342     {
1343       *format_ret = 16;
1344       *size_ret = 1;
1345       *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
1346       (*data_ret) [sizeof (short)] = 0;
1347       (*(short **) data_ret) [0] = (short) XINT (obj);
1348       if (NILP (type)) type = QINTEGER;
1349     }
1350   else if (INTP (obj) || CONSP (obj))
1351     {
1352       *format_ret = 32;
1353       *size_ret = 1;
1354       *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
1355       (*data_ret) [sizeof (long)] = 0;
1356       (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
1357       if (NILP (type)) type = QINTEGER;
1358     }
1359   else if (VECTORP (obj))
1360     {
1361       /* Lisp Vectors may represent a set of ATOMs;
1362          a set of 16 or 32 bit INTEGERs;
1363          or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1364        */
1365       int i;
1366
1367       if (SYMBOLP (XVECTOR_DATA (obj) [0]))
1368         /* This vector is an ATOM set */
1369         {
1370           if (NILP (type)) type = QATOM;
1371           *size_ret = XVECTOR_LENGTH (obj);
1372           *format_ret = 32;
1373           *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
1374           for (i = 0; i < (int) (*size_ret); i++)
1375             if (SYMBOLP (XVECTOR_DATA (obj) [i]))
1376               (*(Atom **) data_ret) [i] =
1377                 symbol_to_x_atom (d, XVECTOR_DATA (obj) [i], 0);
1378             else
1379               signal_error (Qerror, /* Qselection_error */
1380                             list2 (build_string
1381                    ("all elements of the vector must be of the same type"),
1382                                    obj));
1383         }
1384 #if 0 /* #### MULTIPLE doesn't work yet */
1385       else if (VECTORP (XVECTOR_DATA (obj) [0]))
1386         /* This vector is an ATOM_PAIR set */
1387         {
1388           if (NILP (type)) type = QATOM_PAIR;
1389           *size_ret = XVECTOR_LENGTH (obj);
1390           *format_ret = 32;
1391           *data_ret = (unsigned char *)
1392             xmalloc ((*size_ret) * sizeof (Atom) * 2);
1393           for (i = 0; i < *size_ret; i++)
1394             if (VECTORP (XVECTOR_DATA (obj) [i]))
1395               {
1396                 Lisp_Object pair = XVECTOR_DATA (obj) [i];
1397                 if (XVECTOR_LENGTH (pair) != 2)
1398                   signal_error (Qerror,
1399                                 list2 (build_string
1400        ("elements of the vector must be vectors of exactly two elements"),
1401                                   pair));
1402
1403                 (*(Atom **) data_ret) [i * 2] =
1404                   symbol_to_x_atom (d, XVECTOR_DATA (pair) [0], 0);
1405                 (*(Atom **) data_ret) [(i * 2) + 1] =
1406                   symbol_to_x_atom (d, XVECTOR_DATA (pair) [1], 0);
1407               }
1408             else
1409               signal_error (Qerror,
1410                             list2 (build_string
1411                    ("all elements of the vector must be of the same type"),
1412                                    obj));
1413         }
1414 #endif
1415       else
1416         /* This vector is an INTEGER set, or something like it */
1417         {
1418           *size_ret = XVECTOR_LENGTH (obj);
1419           if (NILP (type)) type = QINTEGER;
1420           *format_ret = 16;
1421           for (i = 0; i < (int) (*size_ret); i++)
1422             if (CONSP (XVECTOR_DATA (obj) [i]))
1423               *format_ret = 32;
1424             else if (!INTP (XVECTOR_DATA (obj) [i]))
1425               signal_error (Qerror, /* Qselection_error */
1426                             list2 (build_string
1427         ("all elements of the vector must be integers or conses of integers"),
1428                                    obj));
1429
1430           *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
1431           for (i = 0; i < (int) (*size_ret); i++)
1432             if (*format_ret == 32)
1433               (*((unsigned long **) data_ret)) [i] =
1434                 lisp_to_word (XVECTOR_DATA (obj) [i]);
1435             else
1436               (*((unsigned short **) data_ret)) [i] =
1437                 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
1438         }
1439     }
1440   else
1441     signal_error (Qerror, /* Qselection_error */
1442                   list2 (build_string ("unrecognized selection data"),
1443                          obj));
1444
1445   *type_ret = symbol_to_x_atom (d, type, 0);
1446 }
1447
1448
1449 \f
1450 /* Called from the event loop to handle SelectionNotify events.
1451    I don't think this needs to be reentrant.
1452  */
1453 void
1454 x_handle_selection_notify (XSelectionEvent *event)
1455 {
1456   if (! reading_selection_reply)
1457     message ("received an unexpected SelectionNotify event");
1458   else if (event->requestor != reading_selection_reply)
1459     message ("received a SelectionNotify event for the wrong window");
1460   else if (event->selection != reading_which_selection)
1461     message ("received the wrong selection type in SelectionNotify!");
1462   else
1463     reading_selection_reply = 0; /* we're done now. */
1464 }
1465
1466 static void
1467 x_disown_selection (Lisp_Object selection, Lisp_Object timeval)
1468 {
1469   struct device *d = decode_x_device (Qnil);
1470   Display *display = DEVICE_X_DISPLAY (d);
1471   Time timestamp;
1472   Atom selection_atom;
1473
1474   CHECK_SYMBOL (selection);
1475   if (NILP (timeval))
1476     timestamp = DEVICE_X_MOUSE_TIMESTAMP (d);
1477   else
1478     {
1479       /* #### This is bogus.  See the comment above about problems
1480          on OSF/1 and DEC Alphas.  Yet another reason why it sucks
1481          to have the implementation (i.e. cons of two 16-bit
1482          integers) exposed. */
1483       time_t the_time;
1484       lisp_to_time (timeval, &the_time);
1485       timestamp = (Time) the_time;
1486     }
1487
1488   selection_atom = symbol_to_x_atom (d, selection, 0);
1489
1490   XSetSelectionOwner (display, selection_atom, None, timestamp);
1491 }
1492
1493 static Lisp_Object
1494 x_selection_exists_p (Lisp_Object selection,
1495                       Lisp_Object selection_type)
1496 {
1497   struct device *d = decode_x_device (Qnil);
1498   Display *dpy = DEVICE_X_DISPLAY (d);
1499   return XGetSelectionOwner (dpy, symbol_to_x_atom (d, selection, 0)) != None ?
1500     Qt : Qnil;
1501 }
1502
1503 \f
1504 #ifdef CUT_BUFFER_SUPPORT
1505
1506 static int cut_buffers_initialized; /* Whether we're sure they all exist */
1507
1508 /* Ensure that all 8 cut buffers exist.  ICCCM says we gotta... */
1509 static void
1510 initialize_cut_buffers (Display *display, Window window)
1511 {
1512   static unsigned const char * const data = (unsigned const char *) "";
1513 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1514                                     PropModeAppend, data, 0)
1515   FROB (XA_CUT_BUFFER0);
1516   FROB (XA_CUT_BUFFER1);
1517   FROB (XA_CUT_BUFFER2);
1518   FROB (XA_CUT_BUFFER3);
1519   FROB (XA_CUT_BUFFER4);
1520   FROB (XA_CUT_BUFFER5);
1521   FROB (XA_CUT_BUFFER6);
1522   FROB (XA_CUT_BUFFER7);
1523 #undef FROB
1524   cut_buffers_initialized = 1;
1525 }
1526
1527 #define CHECK_CUTBUFFER(symbol) do {                            \
1528   CHECK_SYMBOL (symbol);                                        \
1529   if (! (EQ (symbol, QCUT_BUFFER0) ||                           \
1530          EQ (symbol, QCUT_BUFFER1) ||                           \
1531          EQ (symbol, QCUT_BUFFER2) ||                           \
1532          EQ (symbol, QCUT_BUFFER3) ||                           \
1533          EQ (symbol, QCUT_BUFFER4) ||                           \
1534          EQ (symbol, QCUT_BUFFER5) ||                           \
1535          EQ (symbol, QCUT_BUFFER6) ||                           \
1536          EQ (symbol, QCUT_BUFFER7)))                            \
1537     signal_simple_error ("Doesn't name a cutbuffer", symbol);   \
1538 } while (0)
1539
1540 DEFUN ("x-get-cutbuffer-internal", Fx_get_cutbuffer_internal, 1, 1, 0, /*
1541 Return the value of the named CUTBUFFER (typically CUT_BUFFER0).
1542 */
1543        (cutbuffer))
1544 {
1545   struct device *d = decode_x_device (Qnil);
1546   Display *display = DEVICE_X_DISPLAY (d);
1547   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1548   Atom cut_buffer_atom;
1549   unsigned char *data;
1550   int bytes;
1551   Atom type;
1552   int format;
1553   unsigned long size;
1554   Lisp_Object ret;
1555
1556   CHECK_CUTBUFFER (cutbuffer);
1557   cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1558
1559   x_get_window_property (display, window, cut_buffer_atom, &data, &bytes,
1560                          &type, &format, &size, 0);
1561   if (!data) return Qnil;
1562
1563   if (format != 8 || type != XA_STRING)
1564     signal_simple_error_2 ("Cut buffer doesn't contain 8-bit STRING data",
1565                            x_atom_to_symbol (d, type),
1566                            make_int (format));
1567
1568   /* We cheat - if the string contains an ESC character, that's
1569      technically not allowed in a STRING, so we assume it's
1570      COMPOUND_TEXT that we stored there ourselves earlier,
1571      in x-store-cutbuffer-internal  */
1572   ret = (bytes ?
1573          make_ext_string (data, bytes,
1574                           memchr (data, 0x1b, bytes) ?
1575                           Qctext : Qbinary)
1576          : Qnil);
1577   xfree (data);
1578   return ret;
1579 }
1580
1581
1582 DEFUN ("x-store-cutbuffer-internal", Fx_store_cutbuffer_internal, 2, 2, 0, /*
1583 Set the value of the named CUTBUFFER (typically CUT_BUFFER0) to STRING.
1584 */
1585        (cutbuffer, string))
1586 {
1587   struct device *d = decode_x_device (Qnil);
1588   Display *display = DEVICE_X_DISPLAY (d);
1589   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1590   Atom cut_buffer_atom;
1591   const Extbyte *data  = XSTRING_DATA (string);
1592   Extcount bytes = XSTRING_LENGTH (string);
1593   Extcount bytes_remaining;
1594   int max_bytes = SELECTION_QUANTUM (display);
1595 #ifdef MULE
1596   const Bufbyte *ptr, *end;
1597   enum { ASCII, LATIN_1, WORLD } chartypes = ASCII;
1598 #endif
1599
1600   if (max_bytes > MAX_SELECTION_QUANTUM)
1601     max_bytes = MAX_SELECTION_QUANTUM;
1602
1603   CHECK_CUTBUFFER (cutbuffer);
1604   CHECK_STRING (string);
1605   cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1606
1607   if (! cut_buffers_initialized)
1608     initialize_cut_buffers (display, window);
1609
1610   /* We use the STRING encoding (Latin-1 only) if we can, else COMPOUND_TEXT.
1611      We cheat and use type = `STRING' even when using COMPOUND_TEXT.
1612      The ICCCM requires that this be so, and other clients assume it,
1613      as we do ourselves in initialize_cut_buffers.  */
1614
1615 #ifdef MULE
1616   /* Optimize for the common ASCII case */
1617   for (ptr = data, end = ptr + bytes; ptr <= end; )
1618     {
1619       if (BYTE_ASCII_P (*ptr))
1620         {
1621           ptr++;
1622           continue;
1623         }
1624
1625       if ((*ptr) == LEADING_BYTE_LATIN_ISO8859_1 ||
1626           (*ptr) == LEADING_BYTE_CONTROL_1)
1627         {
1628           chartypes = LATIN_1;
1629           ptr += 2;
1630           continue;
1631         }
1632
1633       chartypes = WORLD;
1634       break;
1635     }
1636
1637   if (chartypes == LATIN_1)
1638     TO_EXTERNAL_FORMAT (LISP_STRING, string,
1639                         ALLOCA, (data, bytes),
1640                         Qbinary);
1641   else if (chartypes == WORLD)
1642     TO_EXTERNAL_FORMAT (LISP_STRING, string,
1643                         ALLOCA, (data, bytes),
1644                         Qctext);
1645 #endif /* MULE */
1646
1647   bytes_remaining = bytes;
1648
1649   while (bytes_remaining)
1650     {
1651       int chunk = bytes_remaining < max_bytes ? bytes_remaining : max_bytes;
1652       XChangeProperty (display, window, cut_buffer_atom, XA_STRING, 8,
1653                        (bytes_remaining == bytes
1654                         ? PropModeReplace : PropModeAppend),
1655                        data, chunk);
1656       data += chunk;
1657       bytes_remaining -= chunk;
1658     }
1659   return string;
1660 }
1661
1662
1663 DEFUN ("x-rotate-cutbuffers-internal", Fx_rotate_cutbuffers_internal, 1, 1, 0, /*
1664 Rotate the values of the cutbuffers by the given number of steps;
1665 positive means move values forward, negative means backward.
1666 */
1667        (n))
1668 {
1669   struct device *d = decode_x_device (Qnil);
1670   Display *display = DEVICE_X_DISPLAY (d);
1671   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1672   Atom props [8];
1673
1674   CHECK_INT (n);
1675   if (XINT (n) == 0)
1676     return n;
1677   if (! cut_buffers_initialized)
1678     initialize_cut_buffers (display, window);
1679   props[0] = XA_CUT_BUFFER0;
1680   props[1] = XA_CUT_BUFFER1;
1681   props[2] = XA_CUT_BUFFER2;
1682   props[3] = XA_CUT_BUFFER3;
1683   props[4] = XA_CUT_BUFFER4;
1684   props[5] = XA_CUT_BUFFER5;
1685   props[6] = XA_CUT_BUFFER6;
1686   props[7] = XA_CUT_BUFFER7;
1687   XRotateWindowProperties (display, window, props, 8, XINT (n));
1688   return n;
1689 }
1690
1691 #endif /* CUT_BUFFER_SUPPORT */
1692
1693
1694 \f
1695 /************************************************************************/
1696 /*                            initialization                            */
1697 /************************************************************************/
1698
1699 void
1700 syms_of_select_x (void)
1701 {
1702
1703 #ifdef CUT_BUFFER_SUPPORT
1704   DEFSUBR (Fx_get_cutbuffer_internal);
1705   DEFSUBR (Fx_store_cutbuffer_internal);
1706   DEFSUBR (Fx_rotate_cutbuffers_internal);
1707 #endif /* CUT_BUFFER_SUPPORT */
1708
1709   /* Unfortunately, timeout handlers must be lisp functions. */
1710   defsymbol (&Qx_selection_reply_timeout_internal,
1711              "x-selection-reply-timeout-internal");
1712   DEFSUBR (Fx_selection_reply_timeout_internal);
1713
1714 #ifdef CUT_BUFFER_SUPPORT
1715   defsymbol (&QCUT_BUFFER0, "CUT_BUFFER0");
1716   defsymbol (&QCUT_BUFFER1, "CUT_BUFFER1");
1717   defsymbol (&QCUT_BUFFER2, "CUT_BUFFER2");
1718   defsymbol (&QCUT_BUFFER3, "CUT_BUFFER3");
1719   defsymbol (&QCUT_BUFFER4, "CUT_BUFFER4");
1720   defsymbol (&QCUT_BUFFER5, "CUT_BUFFER5");
1721   defsymbol (&QCUT_BUFFER6, "CUT_BUFFER6");
1722   defsymbol (&QCUT_BUFFER7, "CUT_BUFFER7");
1723 #endif /* CUT_BUFFER_SUPPORT */
1724 }
1725
1726 void
1727 console_type_create_select_x (void)
1728 {
1729   CONSOLE_HAS_METHOD (x, own_selection);
1730   CONSOLE_HAS_METHOD (x, disown_selection);
1731   CONSOLE_HAS_METHOD (x, get_foreign_selection);
1732   CONSOLE_HAS_METHOD (x, selection_exists_p);
1733 }
1734
1735 void
1736 reinit_vars_of_select_x (void)
1737 {
1738   reading_selection_reply = 0;
1739   reading_which_selection = 0;
1740   selection_reply_timed_out = 0;
1741   for_whom_the_bell_tolls = 0;
1742   prop_location_tick = 0;
1743 }
1744
1745 void
1746 vars_of_select_x (void)
1747 {
1748   reinit_vars_of_select_x ();
1749
1750 #ifdef CUT_BUFFER_SUPPORT
1751   cut_buffers_initialized = 0;
1752   Fprovide (intern ("cut-buffer"));
1753 #endif
1754
1755   DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks /*
1756 A function or functions to be called after we have responded to some
1757 other client's request for the value of a selection that we own.  The
1758 function(s) will be called with four arguments:
1759   - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);
1760   - the name of the selection-type which we were requested to convert the
1761     selection into before sending (for example, STRING or LENGTH);
1762   - and whether we successfully transmitted the selection.
1763 We might have failed (and declined the request) for any number of reasons,
1764 including being asked for a selection that we no longer own, or being asked
1765 to convert into a type that we don't know about or that is inappropriate.
1766 This hook doesn't let you change the behavior of emacs's selection replies,
1767 it merely informs you that they have happened.
1768 */ );
1769   Vx_sent_selection_hooks = Qunbound;
1770
1771   DEFVAR_INT ("x-selection-timeout", &x_selection_timeout /*
1772 If the selection owner doesn't reply in this many seconds, we give up.
1773 A value of 0 means wait as long as necessary.  This is initialized from the
1774 \"*selectionTimeout\" resource (which is expressed in milliseconds).
1775 */ );
1776   x_selection_timeout = 0;
1777 }
1778
1779 void
1780 Xatoms_of_select_x (struct device *d)
1781 {
1782   Display *D = DEVICE_X_DISPLAY (d);
1783
1784   /* Non-predefined atoms that we might end up using a lot */
1785   DEVICE_XATOM_CLIPBOARD     (d) = XInternAtom (D, "CLIPBOARD",     False);
1786   DEVICE_XATOM_TIMESTAMP     (d) = XInternAtom (D, "TIMESTAMP",     False);
1787   DEVICE_XATOM_TEXT          (d) = XInternAtom (D, "TEXT",          False);
1788   DEVICE_XATOM_DELETE        (d) = XInternAtom (D, "DELETE",        False);
1789   DEVICE_XATOM_MULTIPLE      (d) = XInternAtom (D, "MULTIPLE",      False);
1790   DEVICE_XATOM_INCR          (d) = XInternAtom (D, "INCR",          False);
1791   DEVICE_XATOM_TARGETS       (d) = XInternAtom (D, "TARGETS",       False);
1792   DEVICE_XATOM_NULL          (d) = XInternAtom (D, "NULL",          False);
1793   DEVICE_XATOM_ATOM_PAIR     (d) = XInternAtom (D, "ATOM_PAIR",     False);
1794   DEVICE_XATOM_COMPOUND_TEXT (d) = XInternAtom (D, "COMPOUND_TEXT", False);
1795
1796   /* #### I don't like the looks of this... what is it for? - ajh */
1797   DEVICE_XATOM_EMACS_TMP     (d) = XInternAtom (D, "_EMACS_TMP_",   False);
1798 }