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