xselect.c 61.1 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1
/* X Selection processing for emacs
Karl Heuer's avatar
Karl Heuer committed
2
   Copyright (C) 1993, 1994 Free Software Foundation.
Richard M. Stallman's avatar
Richard M. Stallman committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

Jim Blandy's avatar
Jim Blandy committed
20
/* x_handle_selection_notify
21 22
x_reply_selection_request  */

Jim Blandy's avatar
Jim Blandy committed
23

Richard M. Stallman's avatar
Richard M. Stallman committed
24 25
/* Rewritten by jwz */

26
#include <config.h>
Richard M. Stallman's avatar
Richard M. Stallman committed
27
#include "lisp.h"
28 29 30 31
#if 0
#include <stdio.h>	/* termhooks.h needs this */
#include "termhooks.h"
#endif
Richard M. Stallman's avatar
Richard M. Stallman committed
32
#include "xterm.h"	/* for all of the X includes */
33 34
#include "dispextern.h"	/* frame.h seems to want this */
#include "frame.h"	/* Need this to get the X window of selected_frame */
35
#include "blockinput.h"
36 37

#define xfree free
Richard M. Stallman's avatar
Richard M. Stallman committed
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65

#define CUT_BUFFER_SUPPORT

static Atom Xatom_CLIPBOARD, Xatom_TIMESTAMP, Xatom_TEXT, Xatom_DELETE,
  Xatom_MULTIPLE, Xatom_INCR, Xatom_EMACS_TMP, Xatom_TARGETS, Xatom_NULL,
  Xatom_ATOM_PAIR;

Lisp_Object QPRIMARY, QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP,
  QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL,
  QATOM_PAIR;

#ifdef CUT_BUFFER_SUPPORT
Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
  QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
#endif

Lisp_Object Vx_lost_selection_hooks;
Lisp_Object Vx_sent_selection_hooks;

/* If this is a smaller number than the max-request-size of the display,
   emacs will use INCR selection transfer when the selection is larger
   than this.  The max-request-size is usually around 64k, so if you want
   emacs to use incremental selection transfers when the selection is 
   smaller than that, set this.  I added this mostly for debugging the
   incremental transfer stuff, but it might improve server performance.
 */
#define MAX_SELECTION_QUANTUM 0xFFFFFF

66 67 68 69 70
#ifdef HAVE_X11R4
#define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
#else
#define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
#endif
Richard M. Stallman's avatar
Richard M. Stallman committed
71

72 73
/* The timestamp of the last input event Emacs received from the X server.  */
unsigned long last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97

/* This is an association list whose elements are of the form
     ( selection-name selection-value selection-timestamp )
   selection-name is a lisp symbol, whose name is the name of an X Atom.
   selection-value is the value that emacs owns for that selection.
     It may be any kind of Lisp object.
   selection-timestamp is the time at which emacs began owning this selection,
     as a cons of two 16-bit numbers (making a 32 bit time.)
   If there is an entry in this alist, then it can be assumed that emacs owns
    that selection.
   The only (eq) parts of this list that are visible from Lisp are the
    selection-values.
 */
Lisp_Object Vselection_alist;

/* This is an alist whose CARs are selection-types (whose names are the same
   as the names of X Atoms) and whose CDRs are the names of Lisp functions to
   call to convert the given Emacs selection value to a string representing 
   the given selection type.  This is for Lisp-level extension of the emacs
   selection handling.
 */
Lisp_Object Vselection_converter_alist;

/* If the selection owner takes too long to reply to a selection request,
98
   we give up on it.  This is in milliseconds (0 = no timeout.)
Richard M. Stallman's avatar
Richard M. Stallman committed
99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
 */
int x_selection_timeout;


/* Utility functions */

static void lisp_data_to_selection_data ();
static Lisp_Object selection_data_to_lisp_data ();
static Lisp_Object x_get_window_property_as_lisp_data ();

/* This converts a Lisp symbol to a server Atom, avoiding a server 
   roundtrip whenever possible.  */

static Atom
symbol_to_x_atom (display, sym)
     Display *display;
     Lisp_Object sym;
{
  Atom val;
  if (NILP (sym))	    return 0;
  if (EQ (sym, QPRIMARY))   return XA_PRIMARY;
  if (EQ (sym, QSECONDARY)) return XA_SECONDARY;
  if (EQ (sym, QSTRING))    return XA_STRING;
  if (EQ (sym, QINTEGER))   return XA_INTEGER;
  if (EQ (sym, QATOM))	    return XA_ATOM;
  if (EQ (sym, QCLIPBOARD)) return Xatom_CLIPBOARD;
  if (EQ (sym, QTIMESTAMP)) return Xatom_TIMESTAMP;
  if (EQ (sym, QTEXT))	    return Xatom_TEXT;
  if (EQ (sym, QDELETE))    return Xatom_DELETE;
  if (EQ (sym, QMULTIPLE))  return Xatom_MULTIPLE;
  if (EQ (sym, QINCR))	    return Xatom_INCR;
  if (EQ (sym, QEMACS_TMP)) return Xatom_EMACS_TMP;
  if (EQ (sym, QTARGETS))   return Xatom_TARGETS;
  if (EQ (sym, QNULL))	    return Xatom_NULL;
#ifdef CUT_BUFFER_SUPPORT
  if (EQ (sym, QCUT_BUFFER0)) return XA_CUT_BUFFER0;
  if (EQ (sym, QCUT_BUFFER1)) return XA_CUT_BUFFER1;
  if (EQ (sym, QCUT_BUFFER2)) return XA_CUT_BUFFER2;
  if (EQ (sym, QCUT_BUFFER3)) return XA_CUT_BUFFER3;
  if (EQ (sym, QCUT_BUFFER4)) return XA_CUT_BUFFER4;
  if (EQ (sym, QCUT_BUFFER5)) return XA_CUT_BUFFER5;
  if (EQ (sym, QCUT_BUFFER6)) return XA_CUT_BUFFER6;
  if (EQ (sym, QCUT_BUFFER7)) return XA_CUT_BUFFER7;
#endif
  if (!SYMBOLP (sym)) abort ();

#if 0
  fprintf (stderr, " XInternAtom %s\n", (char *) XSYMBOL (sym)->name->data);
#endif
  BLOCK_INPUT;
  val = XInternAtom (display, (char *) XSYMBOL (sym)->name->data, False);
  UNBLOCK_INPUT;
  return val;
}


/* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
   and calls to intern whenever possible.  */

static Lisp_Object
x_atom_to_symbol (display, atom)
     Display *display;
     Atom atom;
{
  char *str;
  Lisp_Object val;
  if (! atom) return Qnil;
166 167 168 169 170 171 172 173 174 175 176 177
  switch (atom)
    {
    case XA_PRIMARY:
      return QPRIMARY;
    case XA_SECONDARY:
      return QSECONDARY;
    case XA_STRING:
      return QSTRING;
    case XA_INTEGER:
      return QINTEGER;
    case XA_ATOM:
      return QATOM;
Richard M. Stallman's avatar
Richard M. Stallman committed
178
#ifdef CUT_BUFFER_SUPPORT
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
    case XA_CUT_BUFFER0:
      return QCUT_BUFFER0;
    case XA_CUT_BUFFER1:
      return QCUT_BUFFER1;
    case XA_CUT_BUFFER2:
      return QCUT_BUFFER2;
    case XA_CUT_BUFFER3:
      return QCUT_BUFFER3;
    case XA_CUT_BUFFER4:
      return QCUT_BUFFER4;
    case XA_CUT_BUFFER5:
      return QCUT_BUFFER5;
    case XA_CUT_BUFFER6:
      return QCUT_BUFFER6;
    case XA_CUT_BUFFER7:
      return QCUT_BUFFER7;
Richard M. Stallman's avatar
Richard M. Stallman committed
195
#endif
196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
    }

  if (atom == Xatom_CLIPBOARD)
    return QCLIPBOARD;
  if (atom == Xatom_TIMESTAMP)
    return QTIMESTAMP;
  if (atom == Xatom_TEXT)
    return QTEXT;
  if (atom == Xatom_DELETE)
    return QDELETE;
  if (atom == Xatom_MULTIPLE)
    return QMULTIPLE;
  if (atom == Xatom_INCR)
    return QINCR;
  if (atom == Xatom_EMACS_TMP)
    return QEMACS_TMP;
  if (atom == Xatom_TARGETS)
    return QTARGETS;
  if (atom == Xatom_NULL)
    return QNULL;
Richard M. Stallman's avatar
Richard M. Stallman committed
216 217 218 219 220 221 222 223 224 225 226 227 228 229

  BLOCK_INPUT;
  str = XGetAtomName (display, atom);
  UNBLOCK_INPUT;
#if 0
  fprintf (stderr, " XGetAtomName --> %s\n", str);
#endif
  if (! str) return Qnil;
  val = intern (str);
  BLOCK_INPUT;
  XFree (str);
  UNBLOCK_INPUT;
  return val;
}
230

Richard M. Stallman's avatar
Richard M. Stallman committed
231 232 233 234 235 236 237 238 239 240 241 242 243 244
/* Do protocol to assert ourself as a selection owner.
   Update the Vselection_alist so that we can reply to later requests for 
   our selection.  */

static void
x_own_selection (selection_name, selection_value)
     Lisp_Object selection_name, selection_value;
{
  Display *display = x_current_display;
#ifdef X_TOOLKIT
  Window selecting_window = XtWindow (selected_screen->display.x->edit_widget);
#else
  Window selecting_window = FRAME_X_WINDOW (selected_frame);
#endif
245
  Time time = last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
246 247 248 249 250 251
  Atom selection_atom;

  CHECK_SYMBOL (selection_name, 0);
  selection_atom = symbol_to_x_atom (display, selection_name);

  BLOCK_INPUT;
252
  x_catch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
253
  XSetSelectionOwner (display, selection_atom, selecting_window, time);
254 255
  x_check_errors ("Can't set selection: %s");
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291
  UNBLOCK_INPUT;

  /* Now update the local cache */
  {
    Lisp_Object selection_time;
    Lisp_Object selection_data;
    Lisp_Object prev_value;

    selection_time = long_to_cons ((unsigned long) time);
    selection_data = Fcons (selection_name,
			    Fcons (selection_value,
				   Fcons (selection_time, Qnil)));
    prev_value = assq_no_quit (selection_name, Vselection_alist);

    Vselection_alist = Fcons (selection_data, Vselection_alist);

    /* If we already owned the selection, remove the old selection data.
       Perhaps we should destructively modify it instead.
       Don't use Fdelq as that may QUIT.  */
    if (!NILP (prev_value))
      {
	Lisp_Object rest;	/* we know it's not the CAR, so it's easy.  */
	for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
	  if (EQ (prev_value, Fcar (XCONS (rest)->cdr)))
	    {
	      XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr);
	      break;
	    }
      }
  }
}

/* Given a selection-name and desired type, look up our local copy of
   the selection value and convert it to the type.
   The value is nil or a string.
   This function is used both for remote requests
292
   and for local x-get-selection-internal.
Richard M. Stallman's avatar
Richard M. Stallman committed
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328

   This calls random Lisp code, and may signal or gc.  */

static Lisp_Object
x_get_local_selection (selection_symbol, target_type)
     Lisp_Object selection_symbol, target_type;
{
  Lisp_Object local_value;
  Lisp_Object handler_fn, value, type, check;
  int count;

  local_value = assq_no_quit (selection_symbol, Vselection_alist);

  if (NILP (local_value)) return Qnil;

  /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest.  */
  if (EQ (target_type, QTIMESTAMP))
    {
      handler_fn = Qnil;
      value = XCONS (XCONS (XCONS (local_value)->cdr)->cdr)->car;
    }
#if 0
  else if (EQ (target_type, QDELETE))
    {
      handler_fn = Qnil;
      Fx_disown_selection_internal
	(selection_symbol,
	 XCONS (XCONS (XCONS (local_value)->cdr)->cdr)->car);
      value = QNULL;
    }
#endif

#if 0 /* #### MULTIPLE doesn't work yet */
  else if (CONSP (target_type)
	   && XCONS (target_type)->car == QMULTIPLE)
    {
329 330
      Lisp_Object pairs;
      int size;
Richard M. Stallman's avatar
Richard M. Stallman committed
331
      int i;
332 333
      pairs = XCONS (target_type)->cdr;
      size = XVECTOR (pairs)->size;
Richard M. Stallman's avatar
Richard M. Stallman committed
334 335 336 337 338 339 340
      /* If the target is MULTIPLE, then target_type looks like
	  (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
	 We modify the second element of each pair in the vector and
	 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
       */
      for (i = 0; i < size; i++)
	{
341 342
	  Lisp_Object pair;
	  pair = XVECTOR (pairs)->contents [i];
Richard M. Stallman's avatar
Richard M. Stallman committed
343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359
	  XVECTOR (pair)->contents [1]
	    = x_get_local_selection (XVECTOR (pair)->contents [0],
				     XVECTOR (pair)->contents [1]);
	}
      return pairs;
    }
#endif
  else
    {
      /* Don't allow a quit within the converter.
	 When the user types C-g, he would be surprised
	 if by luck it came during a converter.  */
      count = specpdl_ptr - specpdl;
      specbind (Qinhibit_quit, Qt);

      CHECK_SYMBOL (target_type, 0);
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
360 361 362 363 364 365
      if (!NILP (handler_fn))
	value = call3 (handler_fn,
		       selection_symbol, target_type,
		       XCONS (XCONS (local_value)->cdr)->car);
      else
	value = Qnil;
Richard M. Stallman's avatar
Richard M. Stallman committed
366 367 368 369 370
      unbind_to (count, Qnil);
    }

  /* Make sure this value is of a type that we could transmit
     to another X client.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
371

Richard M. Stallman's avatar
Richard M. Stallman committed
372 373 374 375 376 377 378 379 380
  check = value;
  if (CONSP (value)
      && SYMBOLP (XCONS (value)->car))
    type = XCONS (value)->car,
    check = XCONS (value)->cdr;
  
  if (STRINGP (check)
      || VECTORP (check)
      || SYMBOLP (check)
381
      || INTEGERP (check)
Richard M. Stallman's avatar
Richard M. Stallman committed
382 383
      || NILP (value))
    return value;
Richard M. Stallman's avatar
Richard M. Stallman committed
384
  /* Check for a value that cons_to_long could handle.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
385
  else if (CONSP (check)
386 387
	   && INTEGERP (XCONS (check)->car)
	   && (INTEGERP (XCONS (check)->cdr)
Richard M. Stallman's avatar
Richard M. Stallman committed
388 389
	       ||
	       (CONSP (XCONS (check)->cdr)
390
		&& INTEGERP (XCONS (XCONS (check)->cdr)->car)
Richard M. Stallman's avatar
Richard M. Stallman committed
391 392 393 394 395
		&& NILP (XCONS (XCONS (check)->cdr)->cdr))))
    return value;
  else
    return
      Fsignal (Qerror,
Richard M. Stallman's avatar
Richard M. Stallman committed
396
	       Fcons (build_string ("invalid data returned by selection-conversion function"),
Richard M. Stallman's avatar
Richard M. Stallman committed
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
		      Fcons (handler_fn, Fcons (value, Qnil))));
}

/* Subroutines of x_reply_selection_request.  */

/* Send a SelectionNotify event to the requestor with property=None,
   meaning we were unable to do what they wanted.  */

static void
x_decline_selection_request (event)
     struct input_event *event;
{
  XSelectionEvent reply;
  reply.type = SelectionNotify;
  reply.display = SELECTION_EVENT_DISPLAY (event);
  reply.requestor = SELECTION_EVENT_REQUESTOR (event);
  reply.selection = SELECTION_EVENT_SELECTION (event);
  reply.time = SELECTION_EVENT_TIME (event);
  reply.target = SELECTION_EVENT_TARGET (event);
  reply.property = None;

  BLOCK_INPUT;
419 420 421
  XSendEvent (reply.display, reply.requestor, False, 0L,
	      (XEvent *) &reply);
  XFlushQueue ();
Richard M. Stallman's avatar
Richard M. Stallman committed
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441
  UNBLOCK_INPUT;
}

/* This is the selection request currently being processed.
   It is set to zero when the request is fully processed.  */
static struct input_event *x_selection_current_request;

/* Used as an unwind-protect clause so that, if a selection-converter signals
   an error, we tell the requestor that we were unable to do what they wanted
   before we throw to top-level or go into the debugger or whatever.  */

static Lisp_Object
x_selection_request_lisp_error (ignore)
     Lisp_Object ignore;
{
  if (x_selection_current_request != 0)
    x_decline_selection_request (x_selection_current_request);
  return Qnil;
}

442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472

/* This stuff is so that INCR selections are reentrant (that is, so we can
   be servicing multiple INCR selection requests simultaneously.)  I haven't
   actually tested that yet.  */

/* Keep a list of the property changes that are awaited.  */

struct prop_location
{
  int identifier;
  Display *display;
  Window window;
  Atom property;
  int desired_state;
  int arrived;
  struct prop_location *next;
};

static struct prop_location *expect_property_change ();
static void wait_for_property_change ();
static void unexpect_property_change ();
static int waiting_for_other_props_on_window ();

static int prop_location_identifier;

static Lisp_Object property_change_reply;

static struct prop_location *property_change_reply_object;

static struct prop_location *property_change_wait_list;

Richard M. Stallman's avatar
Richard M. Stallman committed
473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
/* Send the reply to a selection request event EVENT.
   TYPE is the type of selection data requested.
   DATA and SIZE describe the data to send, already converted.
   FORMAT is the unit-size (in bits) of the data to be transmitted.  */

static void
x_reply_selection_request (event, format, data, size, type)
     struct input_event *event;
     int format, size;
     unsigned char *data;
     Atom type;
{
  XSelectionEvent reply;
  Display *display = SELECTION_EVENT_DISPLAY (event);
  Window window = SELECTION_EVENT_REQUESTOR (event);
  int bytes_remaining;
  int format_bytes = format/8;
  int max_bytes = SELECTION_QUANTUM (display);

  if (max_bytes > MAX_SELECTION_QUANTUM)
    max_bytes = MAX_SELECTION_QUANTUM;

  reply.type = SelectionNotify;
  reply.display = display;
  reply.requestor = window;
  reply.selection = SELECTION_EVENT_SELECTION (event);
  reply.time = SELECTION_EVENT_TIME (event);
  reply.target = SELECTION_EVENT_TARGET (event);
  reply.property = SELECTION_EVENT_PROPERTY (event);
  if (reply.property == None)
    reply.property = reply.target;

  /* #### XChangeProperty can generate BadAlloc, and we must handle it! */

  /* Store the data on the requested property.
     If the selection is large, only store the first N bytes of it.
   */
  bytes_remaining = size * format_bytes;
  if (bytes_remaining <= max_bytes)
    {
      /* Send all the data at once, with minimal handshaking.  */
#if 0
      fprintf (stderr,"\nStoring all %d\n", bytes_remaining);
#endif
517
      BLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
518 519 520
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, size);
      /* At this point, the selection was successfully stored; ack it.  */
521 522 523
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
      XFlushQueue ();
      UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
524 525 526 527
    }
  else
    {
      /* Send an INCR selection.  */
528
      struct prop_location *wait_object;
Richard M. Stallman's avatar
Richard M. Stallman committed
529

530 531
      BLOCK_INPUT;

532
      if (x_window_to_frame (window)) /* #### debug */
Richard M. Stallman's avatar
Richard M. Stallman committed
533 534 535 536
	error ("attempt to transfer an INCR to ourself!");
#if 0
      fprintf (stderr, "\nINCR %d\n", bytes_remaining);
#endif
537 538
      wait_object = expect_property_change (display, window, reply.property,
					    PropertyDelete);
Richard M. Stallman's avatar
Richard M. Stallman committed
539 540 541 542 543 544 545

      XChangeProperty (display, window, reply.property, Xatom_INCR,
		       32, PropModeReplace, (unsigned char *)
		       &bytes_remaining, 1);
      XSelectInput (display, window, PropertyChangeMask);
      /* Tell 'em the INCR data is there...  */
      (void) XSendEvent (display, window, False, 0L, (XEvent *) &reply);
546 547
      XFlushQueue ();
      UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
548 549 550

      /* First, wait for the requestor to ack by deleting the property.
	 This can run random lisp code (process handlers) or signal.  */
551
      wait_for_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
552 553 554 555 556 557

      while (bytes_remaining)
	{
	  int i = ((bytes_remaining < max_bytes)
		   ? bytes_remaining
		   : max_bytes);
558 559 560

	  BLOCK_INPUT;

561 562 563
	  wait_object
	    = expect_property_change (display, window, reply.property,
				      PropertyDelete);
Richard M. Stallman's avatar
Richard M. Stallman committed
564 565 566 567 568 569 570 571
#if 0
	  fprintf (stderr,"  INCR adding %d\n", i);
#endif
	  /* Append the next chunk of data to the property.  */
	  XChangeProperty (display, window, reply.property, type, format,
			   PropModeAppend, data, i / format_bytes);
	  bytes_remaining -= i;
	  data += i;
572 573
	  XFlushQueue ();
	  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
574 575 576 577

	  /* Now wait for the requestor to ack this chunk by deleting the
	     property.	 This can run random lisp code or signal.
	   */
578
	  wait_for_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
579 580 581 582 583 584
	}
      /* Now write a zero-length chunk to the property to tell the requestor
	 that we're done.  */
#if 0
      fprintf (stderr,"  INCR done\n");
#endif
585
      BLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
586 587 588 589 590
      if (! waiting_for_other_props_on_window (display, window))
	XSelectInput (display, window, 0L);

      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, 0);
591 592
      XFlushQueue ();
      UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
593 594 595 596 597 598 599 600 601 602 603
    }
}

/* Handle a SelectionRequest event EVENT.
   This is called from keyboard.c when such an event is found in the queue.  */

void
x_handle_selection_request (event)
     struct input_event *event;
{
  struct gcpro gcpro1, gcpro2, gcpro3;
604
  Lisp_Object local_selection_data;
Richard M. Stallman's avatar
Richard M. Stallman committed
605
  Lisp_Object selection_symbol;
606 607
  Lisp_Object target_symbol;
  Lisp_Object converted_selection;
Richard M. Stallman's avatar
Richard M. Stallman committed
608
  Time local_selection_time;
609
  Lisp_Object successful_p;
Richard M. Stallman's avatar
Richard M. Stallman committed
610 611
  int count;

612 613 614 615 616
  local_selection_data = Qnil;
  target_symbol = Qnil;
  converted_selection = Qnil;
  successful_p = Qnil;

Richard M. Stallman's avatar
Richard M. Stallman committed
617 618
  GCPRO3 (local_selection_data, converted_selection, target_symbol);

619
  selection_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635
				       SELECTION_EVENT_SELECTION (event));

  local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);

  if (NILP (local_selection_data))
    {
      /* Someone asked for the selection, but we don't have it any more.
       */
      x_decline_selection_request (event);
      goto DONE;
    }

  local_selection_time = (Time)
    cons_to_long (XCONS (XCONS (XCONS (local_selection_data)->cdr)->cdr)->car);

  if (SELECTION_EVENT_TIME (event) != CurrentTime
636
      && local_selection_time > SELECTION_EVENT_TIME (event))
Richard M. Stallman's avatar
Richard M. Stallman committed
637 638 639 640 641 642 643 644 645 646 647 648
    {
      /* Someone asked for the selection, and we have one, but not the one
	 they're looking for.
       */
      x_decline_selection_request (event);
      goto DONE;
    }

  count = specpdl_ptr - specpdl;
  x_selection_current_request = event;
  record_unwind_protect (x_selection_request_lisp_error, Qnil);

649
  target_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667
				    SELECTION_EVENT_TARGET (event));

#if 0 /* #### MULTIPLE doesn't work yet */
  if (EQ (target_symbol, QMULTIPLE))
    target_symbol = fetch_multiple_target (event);
#endif
  
  /* Convert lisp objects back into binary data */
  
  converted_selection
    = x_get_local_selection (selection_symbol, target_symbol);
  
  if (! NILP (converted_selection))
    {
      unsigned char *data;
      unsigned int size;
      int format;
      Atom type;
668 669
      int nofree;

670 671
      lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event),
				   converted_selection,
672
				   &data, &type, &size, &format, &nofree);
Richard M. Stallman's avatar
Richard M. Stallman committed
673 674 675 676 677
      
      x_reply_selection_request (event, format, data, size, type);
      successful_p = Qt;

      /* Indicate we have successfully processed this event.  */
678
      x_selection_current_request = 0;
Richard M. Stallman's avatar
Richard M. Stallman committed
679

680 681
      if (!nofree)
	xfree (data);
Richard M. Stallman's avatar
Richard M. Stallman committed
682 683 684 685 686 687 688 689 690
    }
  unbind_to (count, Qnil);

 DONE:

  UNGCPRO;

  /* Let random lisp code notice that the selection has been asked for.  */
  {
691 692
    Lisp_Object rest;
    rest = Vx_sent_selection_hooks;
Richard M. Stallman's avatar
Richard M. Stallman committed
693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750
    if (!EQ (rest, Qunbound))
      for (; CONSP (rest); rest = Fcdr (rest))
	call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
  }
}

/* Handle a SelectionClear event EVENT, which indicates that some other
   client cleared out our previously asserted selection.
   This is called from keyboard.c when such an event is found in the queue.  */

void
x_handle_selection_clear (event)
     struct input_event *event;
{
  Display *display = SELECTION_EVENT_DISPLAY (event);
  Atom selection = SELECTION_EVENT_SELECTION (event);
  Time changed_owner_time = SELECTION_EVENT_TIME (event);
  
  Lisp_Object selection_symbol, local_selection_data;
  Time local_selection_time;

  selection_symbol = x_atom_to_symbol (display, selection);

  local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);

  /* Well, we already believe that we don't own it, so that's just fine.  */
  if (NILP (local_selection_data)) return;

  local_selection_time = (Time)
    cons_to_long (XCONS (XCONS (XCONS (local_selection_data)->cdr)->cdr)->car);

  /* This SelectionClear is for a selection that we no longer own, so we can
     disregard it.  (That is, we have reasserted the selection since this
     request was generated.)  */

  if (changed_owner_time != CurrentTime
      && local_selection_time > changed_owner_time)
    return;

  /* Otherwise, we're really honest and truly being told to drop it.
     Don't use Fdelq as that may QUIT;.  */

  if (EQ (local_selection_data, Fcar (Vselection_alist)))
    Vselection_alist = Fcdr (Vselection_alist);
  else
    {
      Lisp_Object rest;
      for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
	if (EQ (local_selection_data, Fcar (XCONS (rest)->cdr)))
	  {
	    XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr);
	    break;
	  }
    }

  /* Let random lisp code notice that the selection has been stolen.  */

  {
751 752
    Lisp_Object rest;
    rest = Vx_lost_selection_hooks;
Richard M. Stallman's avatar
Richard M. Stallman committed
753
    if (!EQ (rest, Qunbound))
754 755 756
      {
	for (; CONSP (rest); rest = Fcdr (rest))
	  call1 (Fcar (rest), selection_symbol);
757
	prepare_menu_bars ();
758 759
	redisplay_preserve_echo_area ();
      }
Richard M. Stallman's avatar
Richard M. Stallman committed
760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785
  }
}


/* Nonzero if any properties for DISPLAY and WINDOW
   are on the list of what we are waiting for.  */

static int
waiting_for_other_props_on_window (display, window)
     Display *display;
     Window window;
{
  struct prop_location *rest = property_change_wait_list;
  while (rest)
    if (rest->display == display && rest->window == window)
      return 1;
    else
      rest = rest->next;
  return 0;
}

/* Add an entry to the list of property changes we are waiting for.
   DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
   The return value is a number that uniquely identifies
   this awaited property change.  */

786
static struct prop_location *
Richard M. Stallman's avatar
Richard M. Stallman committed
787 788 789 790 791 792 793 794
expect_property_change (display, window, property, state)
     Display *display;
     Window window;
     Lisp_Object property;
     int state;
{
  struct prop_location *pl
    = (struct prop_location *) xmalloc (sizeof (struct prop_location));
795
  pl->identifier = ++prop_location_identifier;
Richard M. Stallman's avatar
Richard M. Stallman committed
796 797 798 799 800
  pl->display = display;
  pl->window = window;
  pl->property = property;
  pl->desired_state = state;
  pl->next = property_change_wait_list;
801
  pl->arrived = 0;
Richard M. Stallman's avatar
Richard M. Stallman committed
802
  property_change_wait_list = pl;
803
  return pl;
Richard M. Stallman's avatar
Richard M. Stallman committed
804 805 806
}

/* Delete an entry from the list of property changes we are waiting for.
807
   IDENTIFIER is the number that uniquely identifies the entry.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
808 809

static void
810 811
unexpect_property_change (location)
     struct prop_location *location;
Richard M. Stallman's avatar
Richard M. Stallman committed
812 813 814 815
{
  struct prop_location *prev = 0, *rest = property_change_wait_list;
  while (rest)
    {
816
      if (rest == location)
Richard M. Stallman's avatar
Richard M. Stallman committed
817 818 819 820 821 822 823 824 825 826 827 828 829
	{
	  if (prev)
	    prev->next = rest->next;
	  else
	    property_change_wait_list = rest->next;
	  xfree (rest);
	  return;
	}
      prev = rest;
      rest = rest->next;
    }
}

830 831 832 833 834 835
/* Remove the property change expectation element for IDENTIFIER.  */

static Lisp_Object
wait_for_property_change_unwind (identifierval)
     Lisp_Object identifierval;
{
836
  unexpect_property_change (XPNTR (identifierval));
837 838
}

Richard M. Stallman's avatar
Richard M. Stallman committed
839
/* Actually wait for a property change.
840
   IDENTIFIER should be the value that expect_property_change returned.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
841 842

static void
843 844
wait_for_property_change (location)
     struct prop_location *location;
Richard M. Stallman's avatar
Richard M. Stallman committed
845
{
846 847
  int secs, usecs;
  int count = specpdl_ptr - specpdl;
848 849 850
  Lisp_Object tem;

  XSET (tem, Lisp_Cons, location);
851 852

  /* Make sure to do unexpect_property_change if we quit or err.  */
853
  record_unwind_protect (wait_for_property_change_unwind, tem);
854

Richard M. Stallman's avatar
Richard M. Stallman committed
855
  XCONS (property_change_reply)->car = Qnil;
856

857 858 859 860 861 862 863 864 865 866
  if (! location->arrived)
    {
      property_change_reply_object = location;
      secs = x_selection_timeout / 1000;
      usecs = (x_selection_timeout % 1000) * 1000;
      wait_reading_process_input (secs, usecs, property_change_reply, 0);

      if (NILP (XCONS (property_change_reply)->car))
	error ("timed out waiting for property-notify event");
    }
867 868

  unbind_to (count, Qnil);
Richard M. Stallman's avatar
Richard M. Stallman committed
869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892
}

/* Called from XTread_socket in response to a PropertyNotify event.  */

void
x_handle_property_notify (event)
     XPropertyEvent *event;
{
  struct prop_location *prev = 0, *rest = property_change_wait_list;
  while (rest)
    {
      if (rest->property == event->atom
	  && rest->window == event->window
	  && rest->display == event->display
	  && rest->desired_state == event->state)
	{
#if 0
	  fprintf (stderr, "Saw expected prop-%s on %s\n",
		   (event->state == PropertyDelete ? "delete" : "change"),
		   (char *) XSYMBOL (x_atom_to_symbol (event->display,
						       event->atom))
		   ->name->data);
#endif

893 894
	  rest->arrived = 1;

Richard M. Stallman's avatar
Richard M. Stallman committed
895 896
	  /* If this is the one wait_for_property_change is waiting for,
	     tell it to wake up.  */
897
	  if (rest == property_change_reply_object)
Richard M. Stallman's avatar
Richard M. Stallman committed
898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983
	    XCONS (property_change_reply)->car = Qt;

	  if (prev)
	    prev->next = rest->next;
	  else
	    property_change_wait_list = rest->next;
	  xfree (rest);
	  return;
	}
      prev = rest;
      rest = rest->next;
    }
#if 0
  fprintf (stderr, "Saw UNexpected prop-%s on %s\n",
	   (event->state == PropertyDelete ? "delete" : "change"),
	   (char *) XSYMBOL (x_atom_to_symbol (event->display, event->atom))
	   ->name->data);
#endif
}



#if 0 /* #### MULTIPLE doesn't work yet */

static Lisp_Object
fetch_multiple_target (event)
     XSelectionRequestEvent *event;
{
  Display *display = event->display;
  Window window = event->requestor;
  Atom target = event->target;
  Atom selection_atom = event->selection;
  int result;

  return
    Fcons (QMULTIPLE,
	   x_get_window_property_as_lisp_data (display, window, target,
					       QMULTIPLE, selection_atom));
}

static Lisp_Object
copy_multiple_data (obj)
     Lisp_Object obj;
{
  Lisp_Object vec;
  int i;
  int size;
  if (CONSP (obj))
    return Fcons (XCONS (obj)->car, copy_multiple_data (XCONS (obj)->cdr));
    
  CHECK_VECTOR (obj, 0);
  vec = Fmake_vector (size = XVECTOR (obj)->size, Qnil);
  for (i = 0; i < size; i++)
    {
      Lisp_Object vec2 = XVECTOR (obj)->contents [i];
      CHECK_VECTOR (vec2, 0);
      if (XVECTOR (vec2)->size != 2)
	/* ??? Confusing error message */
	Fsignal (Qerror, Fcons (build_string ("vectors must be of length 2"),
				Fcons (vec2, Qnil)));
      XVECTOR (vec)->contents [i] = Fmake_vector (2, Qnil);
      XVECTOR (XVECTOR (vec)->contents [i])->contents [0]
	= XVECTOR (vec2)->contents [0];
      XVECTOR (XVECTOR (vec)->contents [i])->contents [1]
	= XVECTOR (vec2)->contents [1];
    }
  return vec;
}

#endif


/* Variables for communication with x_handle_selection_notify.  */
static Atom reading_which_selection;
static Lisp_Object reading_selection_reply;
static Window reading_selection_window;

/* Do protocol to read selection-data from the server.
   Converts this to Lisp data and returns it.  */

static Lisp_Object
x_get_foreign_selection (selection_symbol, target_type)
     Lisp_Object selection_symbol, target_type;
{
  Display *display = x_current_display;
#ifdef X_TOOLKIT
984
  Window requestor_window = XtWindow (selected_screen->display.x->edit_widget);
Richard M. Stallman's avatar
Richard M. Stallman committed
985
#else
986
  Window requestor_window = FRAME_X_WINDOW (selected_frame);
Richard M. Stallman's avatar
Richard M. Stallman committed
987
#endif
988
  Time requestor_time = last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
989 990 991
  Atom target_property = Xatom_EMACS_TMP;
  Atom selection_atom = symbol_to_x_atom (display, selection_symbol);
  Atom type_atom;
992
  int secs, usecs;
Richard M. Stallman's avatar
Richard M. Stallman committed
993 994 995 996 997 998 999

  if (CONSP (target_type))
    type_atom = symbol_to_x_atom (display, XCONS (target_type)->car);
  else
    type_atom = symbol_to_x_atom (display, target_type);

  BLOCK_INPUT;
1000
  x_catch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
1001 1002
  XConvertSelection (display, selection_atom, type_atom, target_property,
		     requestor_window, requestor_time);
Richard M. Stallman's avatar
Richard M. Stallman committed
1003
  XFlushQueue ();
Richard M. Stallman's avatar
Richard M. Stallman committed
1004 1005 1006 1007 1008 1009 1010

  /* Prepare to block until the reply has been read.  */
  reading_selection_window = requestor_window;
  reading_which_selection = selection_atom;
  XCONS (reading_selection_reply)->car = Qnil;
  UNBLOCK_INPUT;

1011 1012 1013 1014
  /* This allows quits.  Also, don't wait forever.  */
  secs = x_selection_timeout / 1000;
  usecs = (x_selection_timeout % 1000) * 1000;
  wait_reading_process_input (secs, usecs, reading_selection_reply, 0);
Richard M. Stallman's avatar
Richard M. Stallman committed
1015

1016 1017 1018 1019 1020
  BLOCK_INPUT;
  x_check_errors ("Cannot get selection: %s");
  x_uncatch_errors ();
  UNBLOCK_INPUT;

Richard M. Stallman's avatar
Richard M. Stallman committed
1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063
  if (NILP (XCONS (reading_selection_reply)->car))
    error ("timed out waiting for reply from selection owner");

  /* Otherwise, the selection is waiting for us on the requested property.  */
  return
    x_get_window_property_as_lisp_data (display, requestor_window,
					target_property, target_type,
					selection_atom);
}

/* Subroutines of x_get_window_property_as_lisp_data */

static void
x_get_window_property (display, window, property, data_ret, bytes_ret,
		       actual_type_ret, actual_format_ret, actual_size_ret,
		       delete_p)
     Display *display;
     Window window;
     Atom property;
     unsigned char **data_ret;
     int *bytes_ret;
     Atom *actual_type_ret;
     int *actual_format_ret;
     unsigned long *actual_size_ret;
     int delete_p;
{
  int total_size;
  unsigned long bytes_remaining;
  int offset = 0;
  unsigned char *tmp_data = 0;
  int result;
  int buffer_size = SELECTION_QUANTUM (display);
  if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
  
  BLOCK_INPUT;
  /* First probe the thing to find out how big it is.  */
  result = XGetWindowProperty (display, window, property,
			       0, 0, False, AnyPropertyType,
			       actual_type_ret, actual_format_ret,
			       actual_size_ret,
			       &bytes_remaining, &tmp_data);
  if (result != Success)
    {
1064
      UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
1065 1066 1067 1068
      *data_ret = 0;
      *bytes_ret = 0;
      return;
    }
1069
  xfree ((char *) tmp_data);
Richard M. Stallman's avatar
Richard M. Stallman committed
1070 1071 1072
  
  if (*actual_type_ret == None || *actual_format_ret == 0)
    {
1073
      UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088
      return;
    }

  total_size = bytes_remaining + 1;
  *data_ret = (unsigned char *) xmalloc (total_size);
  
  /* Now read, until weve gotten it all.  */
  while (bytes_remaining)
    {
#if 0
      int last = bytes_remaining;
#endif
      result
	= XGetWindowProperty (display, window, property,
			      offset/4, buffer_size/4,
1089
			      False,
Richard M. Stallman's avatar
Richard M. Stallman committed
1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103
			      AnyPropertyType,
			      actual_type_ret, actual_format_ret,
			      actual_size_ret, &bytes_remaining, &tmp_data);
#if 0
      fprintf (stderr, "<< read %d\n", last-bytes_remaining);
#endif
      /* If this doesn't return Success at this point, it means that
	 some clod deleted the selection while we were in the midst of
	 reading it.  Deal with that, I guess....
       */
      if (result != Success) break;
      *actual_size_ret *= *actual_format_ret / 8;
      bcopy (tmp_data, (*data_ret) + offset, *actual_size_ret);
      offset += *actual_size_ret;
1104
      xfree ((char *) tmp_data);
Richard M. Stallman's avatar
Richard M. Stallman committed
1105
    }
1106 1107

  XFlushQueue ();
Richard M. Stallman's avatar
Richard M. Stallman committed
1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127
  UNBLOCK_INPUT;
  *bytes_ret = offset;
}

static void
receive_incremental_selection (display, window, property, target_type,
			       min_size_bytes, data_ret, size_bytes_ret,
			       type_ret, format_ret, size_ret)
     Display *display;
     Window window;
     Atom property;
     Lisp_Object target_type; /* for error messages only */
     unsigned int min_size_bytes;
     unsigned char **data_ret;
     int *size_bytes_ret;
     Atom *type_ret;
     unsigned long *size_ret;
     int *format_ret;
{
  int offset = 0;
1128
  struct prop_location *wait_object;
Richard M. Stallman's avatar
Richard M. Stallman committed
1129 1130 1131 1132 1133
  *size_bytes_ret = min_size_bytes;
  *data_ret = (unsigned char *) xmalloc (*size_bytes_ret);
#if 0
  fprintf (stderr, "\nread INCR %d\n", min_size_bytes);
#endif
1134 1135 1136 1137

  /* At this point, we have read an INCR property.
     Delete the property to ack it.
     (But first, prepare to receive the next event in this handshake.)
Richard M. Stallman's avatar
Richard M. Stallman committed
1138 1139 1140 1141 1142

     Now, we must loop, waiting for the sending window to put a value on
     that property, then reading the property, then deleting it to ack.
     We are done when the sender places a property of length 0.
   */
1143 1144 1145
  BLOCK_INPUT;
  XSelectInput (display, window, STANDARD_EVENT_SET | PropertyChangeMask);
  XDeleteProperty (display, window, property);
1146 1147
  wait_object = expect_property_change (display, window, property,
					PropertyNewValue);
1148 1149 1150
  XFlushQueue ();
  UNBLOCK_INPUT;

Richard M. Stallman's avatar
Richard M. Stallman committed
1151 1152 1153 1154
  while (1)
    {
      unsigned char *tmp_data;
      int tmp_size_bytes;
1155
      wait_for_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168
      /* expect it again immediately, because x_get_window_property may
	 .. no it wont, I dont get it.
	 .. Ok, I get it now, the Xt code that implements INCR is broken.
       */
      x_get_window_property (display, window, property,
			     &tmp_data, &tmp_size_bytes,
			     type_ret, format_ret, size_ret, 1);

      if (tmp_size_bytes == 0) /* we're done */
	{
#if 0
	  fprintf (stderr, "  read INCR done\n");
#endif
1169 1170
	  if (! waiting_for_other_props_on_window (display, window))
	    XSelectInput (display, window, STANDARD_EVENT_SET);
1171
	  unexpect_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
1172 1173 1174
	  if (tmp_data) xfree (tmp_data);
	  break;
	}
1175 1176 1177

      BLOCK_INPUT;
      XDeleteProperty (display, window, property);
1178 1179
      wait_object = expect_property_change (display, window, property,
					    PropertyNewValue);
1180 1181 1182
      XFlushQueue ();
      UNBLOCK_INPUT;

Richard M. Stallman's avatar
Richard M. Stallman committed
1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194
#if 0
      fprintf (stderr, "  read INCR %d\n", tmp_size_bytes);
#endif
      if (*size_bytes_ret < offset + tmp_size_bytes)
	{
#if 0
	  fprintf (stderr, "  read INCR realloc %d -> %d\n",
		   *size_bytes_ret, offset + tmp_size_bytes);
#endif
	  *size_bytes_ret = offset + tmp_size_bytes;
	  *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret);
	}
1195
      bcopy (tmp_data, (*data_ret) + offset, tmp_size_bytes);
Richard M. Stallman's avatar
Richard M. Stallman committed
1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257
      offset += tmp_size_bytes;
      xfree (tmp_data);
    }
}

/* Once a requested selection is "ready" (we got a SelectionNotify event),
   fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
   TARGET_TYPE and SELECTION_ATOM are used in error message if this fails.  */

static Lisp_Object
x_get_window_property_as_lisp_data (display, window, property, target_type,
				    selection_atom)
     Display *display;
     Window window;
     Atom property;
     Lisp_Object target_type;	/* for error messages only */
     Atom selection_atom;	/* for error messages only */
{
  Atom actual_type;
  int actual_format;
  unsigned long actual_size;
  unsigned char *data = 0;
  int bytes = 0;
  Lisp_Object val;

  x_get_window_property (display, window, property, &data, &bytes,
			 &actual_type, &actual_format, &actual_size, 1);
  if (! data)
    {
      int there_is_a_selection_owner;
      BLOCK_INPUT;
      there_is_a_selection_owner
	= XGetSelectionOwner (display, selection_atom);
      UNBLOCK_INPUT;
      while (1) /* Note debugger can no longer return, so this is obsolete */
	Fsignal (Qerror,
		 there_is_a_selection_owner ?
		 Fcons (build_string ("selection owner couldn't convert"),
			actual_type
			? Fcons (target_type,
				 Fcons (x_atom_to_symbol (display, actual_type),
					Qnil))
			: Fcons (target_type, Qnil))
		 : Fcons (build_string ("no selection"),
			  Fcons (x_atom_to_symbol (display, selection_atom),
				 Qnil)));
    }
  
  if (actual_type == Xatom_INCR)
    {
      /* That wasn't really the data, just the beginning.  */

      unsigned int min_size_bytes = * ((unsigned int *) data);
      BLOCK_INPUT;
      XFree ((char *) data);
      UNBLOCK_INPUT;
      receive_incremental_selection (display, window, property, target_type,
				     min_size_bytes, &data, &bytes,
				     &actual_type, &actual_format,
				     &actual_size);
    }

1258 1259 1260 1261 1262
  BLOCK_INPUT;
  XDeleteProperty (display, window, property);
  XFlushQueue ();
  UNBLOCK_INPUT;

Richard M. Stallman's avatar
Richard M. Stallman committed
1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369
  /* It's been read.  Now convert it to a lisp object in some semi-rational
     manner.  */
  val = selection_data_to_lisp_data (display, data, bytes,
				     actual_type, actual_format);
  
  xfree ((char *) data);
  return val;
}

/* These functions convert from the selection data read from the server into
   something that we can use from Lisp, and vice versa.

	Type:	Format:	Size:		Lisp Type:
	-----	-------	-----		-----------
	*	8	*		String
	ATOM	32	1		Symbol
	ATOM	32	> 1		Vector of Symbols
	*	16	1		Integer
	*	16	> 1		Vector of Integers
	*	32	1		if <=16 bits: Integer
					if > 16 bits: Cons of top16, bot16
	*	32	> 1		Vector of the above

   When converting a Lisp number to C, it is assumed to be of format 16 if
   it is an integer, and of format 32 if it is a cons of two integers.

   When converting a vector of numbers from Lisp to C, it is assumed to be
   of format 16 if every element in the vector is an integer, and is assumed
   to be of format 32 if any element is a cons of two integers.

   When converting an object to C, it may be of the form (SYMBOL . <data>)
   where SYMBOL is what we should claim that the type is.  Format and
   representation are as above.  */



static Lisp_Object
selection_data_to_lisp_data (display, data, size, type, format)
     Display *display;
     unsigned char *data;
     Atom type;
     int size, format;
{

  if (type == Xatom_NULL)
    return QNULL;

  /* Convert any 8-bit data to a string, for compactness.  */
  else if (format == 8)
    return make_string ((char *) data, size);

  /* Convert a single atom to a Lisp_Symbol.  Convert a set of atoms to
     a vector of symbols.
   */
  else if (type == XA_ATOM)
    {
      int i;
      if (size == sizeof (Atom))
	return x_atom_to_symbol (display, *((Atom *) data));
      else
	{
	  Lisp_Object v = Fmake_vector (size / sizeof (Atom), 0);
	  for (i = 0; i < size / sizeof (Atom); i++)
	    Faset (v, i, x_atom_to_symbol (display, ((Atom *) data) [i]));
	  return v;
	}
    }

  /* Convert a single 16 or small 32 bit number to a Lisp_Int.
     If the number is > 16 bits, convert it to a cons of integers,
     16 bits in each half.
   */
  else if (format == 32 && size == sizeof (long))
    return long_to_cons (((unsigned long *) data) [0]);
  else if (format == 16 && size == sizeof (short))
    return make_number ((int) (((unsigned short *) data) [0]));

  /* Convert any other kind of data to a vector of numbers, represented
     as above (as an integer, or a cons of two 16 bit integers.)
   */
  else if (format == 16)
    {
      int i;
      Lisp_Object v = Fmake_vector (size / 4, 0);
      for (i = 0; i < size / 4; i++)
	{
	  int j = (int) ((unsigned short *) data) [i];
	  Faset (v, i, make_number (j));
	}
      return v;
    }
  else
    {
      int i;
      Lisp_Object v = Fmake_vector (size / 4, 0);
      for (i = 0; i < size / 4; i++)
	{
	  unsigned long j = ((unsigned long *) data) [i];
	  Faset (v, i, long_to_cons (j));
	}
      return v;
    }
}


static void
lisp_data_to_selection_data (display, obj,
1370 1371
			     data_ret, type_ret, size_ret,
			     format_ret, nofree_ret)
Richard M. Stallman's avatar
Richard M. Stallman committed
1372 1373 1374 1375 1376 1377
     Display *display;
     Lisp_Object obj;
     unsigned char **data_ret;
     Atom *type_ret;
     unsigned int *size_ret;
     int *format_ret;
1378
     int *nofree_ret;
Richard M. Stallman's avatar
Richard M. Stallman committed
1379 1380
{
  Lisp_Object type = Qnil;
1381 1382 1383

  *nofree_ret = 0;

Richard M. Stallman's avatar
Richard M. Stallman committed
1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402
  if (CONSP (obj) && SYMBOLP (XCONS (obj)->car))
    {
      type = XCONS (obj)->car;
      obj = XCONS (obj)->cdr;
      if (CONSP (obj) && NILP (XCONS (obj)->cdr))
	obj = XCONS (obj)->car;
    }

  if (EQ (obj, QNULL) || (EQ (type, QNULL)))
    {				/* This is not the same as declining */
      *format_ret = 32;
      *size_ret = 0;
      *data_ret = 0;
      type = QNULL;
    }
  else if (STRINGP (obj))
    {
      *format_ret = 8;
      *size_ret = XSTRING (obj)->size;
1403 1404
      *data_ret = XSTRING (obj)->data;
      *nofree_ret = 1;
Richard M. Stallman's avatar
Richard M. Stallman committed
1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415
      if (NILP (type)) type = QSTRING;
    }
  else if (SYMBOLP (obj))
    {
      *format_ret = 32;
      *size_ret = 1;
      *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
      (*data_ret) [sizeof (Atom)] = 0;
      (*(Atom **) data_ret) [0] = symbol_to_x_atom (display, obj);
      if (NILP (type)) type = QATOM;
    }
1416
  else if (INTEGERP (obj)
Richard M. Stallman's avatar
Richard M. Stallman committed
1417 1418 1419 1420 1421 1422 1423 1424 1425 1426
	   && XINT (obj) < 0xFFFF
	   && XINT (obj) > -0xFFFF)
    {
      *format_ret = 16;
      *size_ret = 1;
      *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
      (*data_ret) [sizeof (short)] = 0;
      (*(short **) data_ret) [0] = (short) XINT (obj);
      if (NILP (type)) type = QINTEGER;
    }
Richard M. Stallman's avatar
Richard M. Stallman committed
1427 1428 1429 1430 1431
  else if (INTEGERP (obj)
	   || (CONSP (obj) && INTEGERP (XCONS (obj)->car)
	       && (INTEGERP (XCONS (obj)->cdr)
		   || (CONSP (XCONS (obj)->cdr)
		       && INTEGERP (XCONS (XCONS (obj)->cdr)->car)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505
    {
      *format_ret = 32;
      *size_ret = 1;
      *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
      (*data_ret) [sizeof (long)] = 0;
      (*(unsigned long **) data_ret) [0] = cons_to_long (obj);
      if (NILP (type)) type = QINTEGER;
    }
  else if (VECTORP (obj))
    {
      /* Lisp_Vectors may represent a set of ATOMs;
	 a set of 16 or 32 bit INTEGERs;
	 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
       */
      int i;

      if (SYMBOLP (XVECTOR (obj)->contents [0]))
	/* This vector is an ATOM set */
	{
	  if (NILP (type)) type = QATOM;
	  *size_ret = XVECTOR (obj)->size;
	  *format_ret = 32;
	  *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
	  for (i = 0; i < *size_ret; i++)
	    if (SYMBOLP (XVECTOR (obj)->contents [i]))
	      (*(Atom **) data_ret) [i]
		= symbol_to_x_atom (display, XVECTOR (obj)->contents [i]);
	    else
	      Fsignal (Qerror, /* Qselection_error */
		       Fcons (build_string
		   ("all elements of selection vector must have same type"),
			      Fcons (obj, Qnil)));
	}
#if 0 /* #### MULTIPLE doesn't work yet */
      else if (VECTORP (XVECTOR (obj)->contents [0]))
	/* This vector is an ATOM_PAIR set */
	{
	  if (NILP (type)) type = QATOM_PAIR;
	  *size_ret = XVECTOR (obj)->size;
	  *format_ret = 32;
	  *data_ret = (unsigned char *)
	    xmalloc ((*size_ret) * sizeof (Atom) * 2);
	  for (i = 0; i < *size_ret; i++)
	    if (VECTORP (XVECTOR (obj)->contents [i]))
	      {
		Lisp_Object pair = XVECTOR (obj)->contents [i];
		if (XVECTOR (pair)->size != 2)
		  Fsignal (Qerror,
			   Fcons (build_string 
       ("elements of the vector must be vectors of exactly two elements"),
				  Fcons (pair, Qnil)));
		
		(*(Atom **) data_ret) [i * 2]
		  = symbol_to_x_atom (display, XVECTOR (pair)->contents [0]);
		(*(Atom **) data_ret) [(i * 2) + 1]
		  = symbol_to_x_atom (display, XVECTOR (pair)->contents [1]);
	      }
	    else
	      Fsignal (Qerror,
		       Fcons (build_string
		   ("all elements of the vector must be of the same type"),
			      Fcons (obj, Qnil)));
	  
	}
#endif
      else
	/* This vector is an INTEGER set, or something like it */
	{
	  *size_ret = XVECTOR (obj)->size;
	  if (NILP (type)) type = QINTEGER;
	  *format_ret = 16;
	  for (i = 0; i < *size_ret; i++)
	    if (CONSP (XVECTOR (obj)->contents [i]))
	      *format_ret = 32;
1506
	    else if (!INTEGERP (XVECTOR (obj)->contents [i]))
Richard M. Stallman's avatar
Richard M. Stallman committed