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