xselect.c 83.8 KB
Newer Older
1
/* X Selection processing for Emacs.
2
   Copyright (C) 1993-1997, 2000-2011 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
3 4 5

This file is part of GNU Emacs.

6
GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
7
it under the terms of the GNU General Public License as published by
8 9
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
10 11 12 13 14 15 16

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
17
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
18

Jim Blandy's avatar
Jim Blandy committed
19

Richard M. Stallman's avatar
Richard M. Stallman committed
20 21
/* Rewritten by jwz */

22
#include <config.h>
Jan Djärv's avatar
Jan Djärv committed
23
#include <stdio.h>      /* termhooks.h needs this */
24
#include <setjmp.h>
25 26 27 28

#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
Paul Eggert's avatar
Paul Eggert committed
29

30 31
#include <unistd.h>

Richard M. Stallman's avatar
Richard M. Stallman committed
32 33
#include "lisp.h"
#include "xterm.h"	/* for all of the X includes */
34 35
#include "dispextern.h"	/* frame.h seems to want this */
#include "frame.h"	/* Need this to get the X window of selected_frame */
36
#include "blockinput.h"
Kenichi Handa's avatar
Kenichi Handa committed
37
#include "buffer.h"
Andreas Schwab's avatar
Andreas Schwab committed
38
#include "process.h"
39
#include "termhooks.h"
40
#include "keyboard.h"
41 42

#include <X11/Xproto.h>
43

44 45
struct prop_location;

46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
static Lisp_Object x_atom_to_symbol (Display *dpy, Atom atom);
static Atom symbol_to_x_atom (struct x_display_info *, Display *,
                              Lisp_Object);
static void x_own_selection (Lisp_Object, Lisp_Object);
static Lisp_Object x_get_local_selection (Lisp_Object, Lisp_Object, int);
static void x_decline_selection_request (struct input_event *);
static Lisp_Object x_selection_request_lisp_error (Lisp_Object);
static Lisp_Object queue_selection_requests_unwind (Lisp_Object);
static Lisp_Object some_frame_on_display (struct x_display_info *);
static Lisp_Object x_catch_errors_unwind (Lisp_Object);
static void x_reply_selection_request (struct input_event *, int,
                                       unsigned char *, int, Atom);
static int waiting_for_other_props_on_window (Display *, Window);
static struct prop_location *expect_property_change (Display *, Window,
                                                     Atom, int);
static void unexpect_property_change (struct prop_location *);
static Lisp_Object wait_for_property_change_unwind (Lisp_Object);
static void wait_for_property_change (struct prop_location *);
static Lisp_Object x_get_foreign_selection (Lisp_Object,
                                            Lisp_Object,
                                            Lisp_Object);
static void x_get_window_property (Display *, Window, Atom,
                                   unsigned char **, int *,
                                   Atom *, int *, unsigned long *, int);
static void receive_incremental_selection (Display *, Window, Atom,
                                           Lisp_Object, unsigned,
                                           unsigned char **, int *,
                                           Atom *, int *, unsigned long *);
static Lisp_Object x_get_window_property_as_lisp_data (Display *,
                                                       Window, Atom,
                                                       Lisp_Object, Atom);
77 78
static Lisp_Object selection_data_to_lisp_data (Display *,
						const unsigned char *,
79 80 81 82 83
                                                int, Atom, int);
static void lisp_data_to_selection_data (Display *, Lisp_Object,
                                         unsigned char **, Atom *,
                                         unsigned *, int *, int *);
static Lisp_Object clean_local_selection_data (Lisp_Object);
84 85 86 87 88 89 90 91 92 93

/* Printing traces to stderr.  */

#ifdef TRACE_SELECTION
#define TRACE0(fmt) \
  fprintf (stderr, "%d: " fmt "\n", getpid ())
#define TRACE1(fmt, a0) \
  fprintf (stderr, "%d: " fmt "\n", getpid (), a0)
#define TRACE2(fmt, a0, a1) \
  fprintf (stderr, "%d: " fmt "\n", getpid (), a0, a1)
94 95
#define TRACE3(fmt, a0, a1, a2) \
  fprintf (stderr, "%d: " fmt "\n", getpid (), a0, a1, a2)
96 97 98 99
#else
#define TRACE0(fmt)		(void) 0
#define TRACE1(fmt, a0)		(void) 0
#define TRACE2(fmt, a0, a1)	(void) 0
100
#define TRACE3(fmt, a0, a1)	(void) 0
101 102 103
#endif


Jan Djärv's avatar
Jan Djärv committed
104
Lisp_Object QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP,
Richard M. Stallman's avatar
Richard M. Stallman committed
105 106 107
  QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL,
  QATOM_PAIR;

Karl Heuer's avatar
Karl Heuer committed
108
Lisp_Object QCOMPOUND_TEXT;	/* This is a type of selection.  */
Kenichi Handa's avatar
Kenichi Handa committed
109
Lisp_Object QUTF8_STRING;	/* This is a type of selection.  */
Karl Heuer's avatar
Karl Heuer committed
110

111
Lisp_Object Qcompound_text_with_extensions;
112

113 114
static Lisp_Object Qforeign_selection;

Richard M. Stallman's avatar
Richard M. Stallman committed
115 116 117
/* 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
118
   emacs to use incremental selection transfers when the selection is
Richard M. Stallman's avatar
Richard M. Stallman committed
119
   smaller than that, set this.  I added this mostly for debugging the
120
   incremental transfer stuff, but it might improve server performance.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
121 122
#define MAX_SELECTION_QUANTUM 0xFFFFFF

123
#define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
Richard M. Stallman's avatar
Richard M. Stallman committed
124

125
/* The timestamp of the last input event Emacs received from the X server.  */
126 127
/* Defined in keyboard.c.  */
extern unsigned long last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
128

129 130


131 132
/* Define a queue to save up SELECTION_REQUEST_EVENT events for later
   handling.  */
133 134 135 136 137 138 139 140 141

struct selection_event_queue
  {
    struct input_event event;
    struct selection_event_queue *next;
  };

static struct selection_event_queue *selection_queue;

142
/* Nonzero means queue up SELECTION_REQUEST_EVENT events.  */
143 144 145

static int x_queue_selection_requests;

146
/* Queue up an SELECTION_REQUEST_EVENT *EVENT, to be processed later.  */
147 148

static void
149
x_queue_event (struct input_event *event)
150 151 152
{
  struct selection_event_queue *queue_tmp;

153 154
  /* Don't queue repeated requests.
     This only happens for large requests which uses the incremental protocol.  */
155 156
  for (queue_tmp = selection_queue; queue_tmp; queue_tmp = queue_tmp->next)
    {
157
      if (!memcmp (&queue_tmp->event, event, sizeof (*event)))
158
	{
159 160
	  TRACE1 ("DECLINE DUP SELECTION EVENT %08lx", (unsigned long)queue_tmp);
	  x_decline_selection_request (event);
161 162 163 164 165 166 167 168 169
	  return;
	}
    }

  queue_tmp
    = (struct selection_event_queue *) xmalloc (sizeof (struct selection_event_queue));

  if (queue_tmp != NULL)
    {
170
      TRACE1 ("QUEUE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
171 172 173 174 175 176
      queue_tmp->event = *event;
      queue_tmp->next = selection_queue;
      selection_queue = queue_tmp;
    }
}

177
/* Start queuing SELECTION_REQUEST_EVENT events.  */
178 179

static void
180
x_start_queuing_selection_requests (void)
181 182 183 184 185 186 187 188
{
  if (x_queue_selection_requests)
    abort ();

  x_queue_selection_requests++;
  TRACE1 ("x_start_queuing_selection_requests %d", x_queue_selection_requests);
}

189
/* Stop queuing SELECTION_REQUEST_EVENT events.  */
190 191

static void
192
x_stop_queuing_selection_requests (void)
193 194 195 196 197 198 199 200 201 202
{
  TRACE1 ("x_stop_queuing_selection_requests %d", x_queue_selection_requests);
  --x_queue_selection_requests;

  /* Take all the queued events and put them back
     so that they get processed afresh.  */

  while (selection_queue != NULL)
    {
      struct selection_event_queue *queue_tmp = selection_queue;
203
      TRACE1 ("RESTORE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
204 205 206 207 208 209 210
      kbd_buffer_unget_event (&queue_tmp->event);
      selection_queue = queue_tmp->next;
      xfree ((char *)queue_tmp);
    }
}


211
/* This converts a Lisp symbol to a server Atom, avoiding a server
Richard M. Stallman's avatar
Richard M. Stallman committed
212 213 214
   roundtrip whenever possible.  */

static Atom
215
symbol_to_x_atom (struct x_display_info *dpyinfo, Display *display, Lisp_Object sym)
Richard M. Stallman's avatar
Richard M. Stallman committed
216 217 218 219 220 221 222 223
{
  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;
224 225 226
  if (EQ (sym, QCLIPBOARD)) return dpyinfo->Xatom_CLIPBOARD;
  if (EQ (sym, QTIMESTAMP)) return dpyinfo->Xatom_TIMESTAMP;
  if (EQ (sym, QTEXT))	    return dpyinfo->Xatom_TEXT;
Karl Heuer's avatar
Karl Heuer committed
227
  if (EQ (sym, QCOMPOUND_TEXT)) return dpyinfo->Xatom_COMPOUND_TEXT;
Kenichi Handa's avatar
Kenichi Handa committed
228
  if (EQ (sym, QUTF8_STRING)) return dpyinfo->Xatom_UTF8_STRING;
229 230 231 232 233 234
  if (EQ (sym, QDELETE))    return dpyinfo->Xatom_DELETE;
  if (EQ (sym, QMULTIPLE))  return dpyinfo->Xatom_MULTIPLE;
  if (EQ (sym, QINCR))	    return dpyinfo->Xatom_INCR;
  if (EQ (sym, QEMACS_TMP)) return dpyinfo->Xatom_EMACS_TMP;
  if (EQ (sym, QTARGETS))   return dpyinfo->Xatom_TARGETS;
  if (EQ (sym, QNULL))	    return dpyinfo->Xatom_NULL;
Richard M. Stallman's avatar
Richard M. Stallman committed
235 236
  if (!SYMBOLP (sym)) abort ();

237
  TRACE1 (" XInternAtom %s", SSDATA (SYMBOL_NAME (sym)));
Richard M. Stallman's avatar
Richard M. Stallman committed
238
  BLOCK_INPUT;
239
  val = XInternAtom (display, SSDATA (SYMBOL_NAME (sym)), False);
Richard M. Stallman's avatar
Richard M. Stallman committed
240 241 242 243 244 245 246 247 248
  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
249
x_atom_to_symbol (Display *dpy, Atom atom)
Richard M. Stallman's avatar
Richard M. Stallman committed
250
{
251
  struct x_display_info *dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
252 253
  char *str;
  Lisp_Object val;
254

255 256
  if (! atom)
    return Qnil;
257

258 259 260 261 262 263 264 265 266 267 268 269 270 271
  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;
    }

272
  dpyinfo = x_display_info_for_display (dpy);
273
  if (atom == dpyinfo->Xatom_CLIPBOARD)
274
    return QCLIPBOARD;
275
  if (atom == dpyinfo->Xatom_TIMESTAMP)
276
    return QTIMESTAMP;
277
  if (atom == dpyinfo->Xatom_TEXT)
278
    return QTEXT;
Karl Heuer's avatar
Karl Heuer committed
279 280
  if (atom == dpyinfo->Xatom_COMPOUND_TEXT)
    return QCOMPOUND_TEXT;
Kenichi Handa's avatar
Kenichi Handa committed
281 282
  if (atom == dpyinfo->Xatom_UTF8_STRING)
    return QUTF8_STRING;
283
  if (atom == dpyinfo->Xatom_DELETE)
284
    return QDELETE;
285
  if (atom == dpyinfo->Xatom_MULTIPLE)
286
    return QMULTIPLE;
287
  if (atom == dpyinfo->Xatom_INCR)
288
    return QINCR;
289
  if (atom == dpyinfo->Xatom_EMACS_TMP)
290
    return QEMACS_TMP;
291
  if (atom == dpyinfo->Xatom_TARGETS)
292
    return QTARGETS;
293
  if (atom == dpyinfo->Xatom_NULL)
294
    return QNULL;
Richard M. Stallman's avatar
Richard M. Stallman committed
295 296

  BLOCK_INPUT;
297
  str = XGetAtomName (dpy, atom);
Richard M. Stallman's avatar
Richard M. Stallman committed
298
  UNBLOCK_INPUT;
299
  TRACE1 ("XGetAtomName --> %s", str);
Richard M. Stallman's avatar
Richard M. Stallman committed
300 301 302
  if (! str) return Qnil;
  val = intern (str);
  BLOCK_INPUT;
303
  /* This was allocated by Xlib, so use XFree.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
304 305 306 307
  XFree (str);
  UNBLOCK_INPUT;
  return val;
}
308

Richard M. Stallman's avatar
Richard M. Stallman committed
309
/* Do protocol to assert ourself as a selection owner.
310
   Update the Vselection_alist so that we can reply to later requests for
Richard M. Stallman's avatar
Richard M. Stallman committed
311 312 313
   our selection.  */

static void
314
x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value)
Richard M. Stallman's avatar
Richard M. Stallman committed
315
{
316
  struct frame *sf = SELECTED_FRAME ();
317 318
  Window selecting_window;
  Display *display;
319
  Time time = last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
320
  Atom selection_atom;
321
  struct x_display_info *dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
322

323 324 325 326 327 328
  if (! FRAME_X_P (sf))
    return;

  selecting_window = FRAME_X_WINDOW (sf);
  display = FRAME_X_DISPLAY (sf);
  dpyinfo = FRAME_X_DISPLAY_INFO (sf);
329

330
  CHECK_SYMBOL (selection_name);
331
  selection_atom = symbol_to_x_atom (dpyinfo, display, selection_name);
Richard M. Stallman's avatar
Richard M. Stallman committed
332 333

  BLOCK_INPUT;
334
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
335
  XSetSelectionOwner (display, selection_atom, selecting_window, time);
336
  x_check_errors (display, "Can't set selection: %s");
337
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
338 339 340 341 342 343 344 345 346
  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);
347 348
    selection_data = list4 (selection_name, selection_value,
			    selection_time, selected_frame);
Richard M. Stallman's avatar
Richard M. Stallman committed
349 350 351 352 353 354 355 356 357 358
    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.  */
359
	for (rest = Vselection_alist; CONSP (rest); rest = XCDR (rest))
360
	  if (EQ (prev_value, Fcar (XCDR (rest))))
Richard M. Stallman's avatar
Richard M. Stallman committed
361
	    {
362
	      XSETCDR (rest, Fcdr (XCDR (rest)));
Richard M. Stallman's avatar
Richard M. Stallman committed
363 364 365 366 367 368 369 370 371
	      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.
Kenichi Handa's avatar
Kenichi Handa committed
372 373
   This function is used both for remote requests (LOCAL_REQUEST is zero)
   and for local x-get-selection-internal (LOCAL_REQUEST is nonzero).
Richard M. Stallman's avatar
Richard M. Stallman committed
374 375 376 377

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

static Lisp_Object
378
x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type, int local_request)
Richard M. Stallman's avatar
Richard M. Stallman committed
379 380 381 382 383 384 385 386 387 388 389 390 391
{
  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;
392
      value = XCAR (XCDR (XCDR (local_value)));
Richard M. Stallman's avatar
Richard M. Stallman committed
393 394 395 396 397 398 399
    }
#if 0
  else if (EQ (target_type, QDELETE))
    {
      handler_fn = Qnil;
      Fx_disown_selection_internal
	(selection_symbol,
400
	 XCAR (XCDR (XCDR (local_value))));
Richard M. Stallman's avatar
Richard M. Stallman committed
401 402 403 404 405 406
      value = QNULL;
    }
#endif

#if 0 /* #### MULTIPLE doesn't work yet */
  else if (CONSP (target_type)
407
	   && XCAR (target_type) == QMULTIPLE)
Richard M. Stallman's avatar
Richard M. Stallman committed
408
    {
409 410
      Lisp_Object pairs;
      int size;
Richard M. Stallman's avatar
Richard M. Stallman committed
411
      int i;
412
      pairs = XCDR (target_type);
413
      size = XVECTOR (pairs)->size;
Richard M. Stallman's avatar
Richard M. Stallman committed
414 415 416 417 418 419 420
      /* 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++)
	{
421 422
	  Lisp_Object pair;
	  pair = XVECTOR (pairs)->contents [i];
Richard M. Stallman's avatar
Richard M. Stallman committed
423 424
	  XVECTOR (pair)->contents [1]
	    = x_get_local_selection (XVECTOR (pair)->contents [0],
Kenichi Handa's avatar
Kenichi Handa committed
425 426
				     XVECTOR (pair)->contents [1],
				     local_request);
Richard M. Stallman's avatar
Richard M. Stallman committed
427 428 429 430 431 432 433 434 435
	}
      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.  */
Juanma Barranquero's avatar
Juanma Barranquero committed
436
      count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
437 438
      specbind (Qinhibit_quit, Qt);

439
      CHECK_SYMBOL (target_type);
Richard M. Stallman's avatar
Richard M. Stallman committed
440
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
441 442 443
      /* gcpro is not needed here since nothing but HANDLER_FN
	 is live, and that ought to be a symbol.  */

444 445
      if (!NILP (handler_fn))
	value = call3 (handler_fn,
Kenichi Handa's avatar
Kenichi Handa committed
446
		       selection_symbol, (local_request ? Qnil : target_type),
447
		       XCAR (XCDR (local_value)));
448 449
      else
	value = Qnil;
Richard M. Stallman's avatar
Richard M. Stallman committed
450 451 452 453 454
      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
455

Richard M. Stallman's avatar
Richard M. Stallman committed
456 457
  check = value;
  if (CONSP (value)
458 459 460
      && SYMBOLP (XCAR (value)))
    type = XCAR (value),
    check = XCDR (value);
461

Richard M. Stallman's avatar
Richard M. Stallman committed
462 463 464
  if (STRINGP (check)
      || VECTORP (check)
      || SYMBOLP (check)
465
      || INTEGERP (check)
Richard M. Stallman's avatar
Richard M. Stallman committed
466 467
      || NILP (value))
    return value;
Richard M. Stallman's avatar
Richard M. Stallman committed
468
  /* Check for a value that cons_to_long could handle.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
469
  else if (CONSP (check)
470 471
	   && INTEGERP (XCAR (check))
	   && (INTEGERP (XCDR (check))
Richard M. Stallman's avatar
Richard M. Stallman committed
472
	       ||
473 474 475
	       (CONSP (XCDR (check))
		&& INTEGERP (XCAR (XCDR (check)))
		&& NILP (XCDR (XCDR (check))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
476
    return value;
477 478 479

  signal_error ("Invalid data returned by selection-conversion function",
		list2 (handler_fn, value));
Richard M. Stallman's avatar
Richard M. Stallman committed
480 481 482 483
}

/* Subroutines of x_reply_selection_request.  */

484
/* Send a SelectionNotify event to the requestor with property=None,
Richard M. Stallman's avatar
Richard M. Stallman committed
485 486 487
   meaning we were unable to do what they wanted.  */

static void
488
x_decline_selection_request (struct input_event *event)
Richard M. Stallman's avatar
Richard M. Stallman committed
489 490
{
  XSelectionEvent reply;
491

Richard M. Stallman's avatar
Richard M. Stallman committed
492 493
  reply.type = SelectionNotify;
  reply.display = SELECTION_EVENT_DISPLAY (event);
494
  reply.requestor = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
495 496 497 498 499
  reply.selection = SELECTION_EVENT_SELECTION (event);
  reply.time = SELECTION_EVENT_TIME (event);
  reply.target = SELECTION_EVENT_TARGET (event);
  reply.property = None;

500 501
  /* The reason for the error may be that the receiver has
     died in the meantime.  Handle that case.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
502
  BLOCK_INPUT;
503
  x_catch_errors (reply.display);
504
  XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
505
  XFlush (reply.display);
506
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
507 508 509 510 511 512 513
  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;

514 515 516 517
/* Display info in x_selection_request.  */

static struct x_display_info *selection_request_dpyinfo;

Richard M. Stallman's avatar
Richard M. Stallman committed
518
/* Used as an unwind-protect clause so that, if a selection-converter signals
519
   an error, we tell the requester that we were unable to do what they wanted
Richard M. Stallman's avatar
Richard M. Stallman committed
520 521 522
   before we throw to top-level or go into the debugger or whatever.  */

static Lisp_Object
523
x_selection_request_lisp_error (Lisp_Object ignore)
Richard M. Stallman's avatar
Richard M. Stallman committed
524
{
525 526
  if (x_selection_current_request != 0
      && selection_request_dpyinfo->display)
Richard M. Stallman's avatar
Richard M. Stallman committed
527 528 529
    x_decline_selection_request (x_selection_current_request);
  return Qnil;
}
530 531

static Lisp_Object
532
x_catch_errors_unwind (Lisp_Object dummy)
533 534 535 536
{
  BLOCK_INPUT;
  x_uncatch_errors ();
  UNBLOCK_INPUT;
537
  return Qnil;
538
}
Richard M. Stallman's avatar
Richard M. Stallman committed
539

540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557

/* 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;
};

558 559 560 561
static struct prop_location *expect_property_change (Display *display, Window window, Atom property, int state);
static void wait_for_property_change (struct prop_location *location);
static void unexpect_property_change (struct prop_location *location);
static int waiting_for_other_props_on_window (Display *display, Window window);
562 563 564 565 566 567 568 569

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;
570 571

static Lisp_Object
572
queue_selection_requests_unwind (Lisp_Object tem)
573
{
574
  x_stop_queuing_selection_requests ();
575
  return Qnil;
576 577 578 579 580 581
}

/* Return some frame whose display info is DPYINFO.
   Return nil if there is none.  */

static Lisp_Object
582
some_frame_on_display (struct x_display_info *dpyinfo)
583 584 585 586 587
{
  Lisp_Object list, frame;

  FOR_EACH_FRAME (list, frame)
    {
588 589
      if (FRAME_X_P (XFRAME (frame))
          && FRAME_X_DISPLAY_INFO (XFRAME (frame)) == dpyinfo)
590 591 592 593 594
	return frame;
    }

  return Qnil;
}
595

Richard M. Stallman's avatar
Richard M. Stallman committed
596 597 598 599 600
/* 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.  */

601
#ifdef TRACE_SELECTION
602
static int x_reply_selection_request_cnt;
603 604
#endif  /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
605
static void
606
x_reply_selection_request (struct input_event *event, int format, unsigned char *data, int size, Atom type)
Richard M. Stallman's avatar
Richard M. Stallman committed
607 608 609
{
  XSelectionEvent reply;
  Display *display = SELECTION_EVENT_DISPLAY (event);
610
  Window window = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
611 612 613
  int bytes_remaining;
  int format_bytes = format/8;
  int max_bytes = SELECTION_QUANTUM (display);
614
  struct x_display_info *dpyinfo = x_display_info_for_display (display);
615
  int count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
616 617 618 619 620 621

  if (max_bytes > MAX_SELECTION_QUANTUM)
    max_bytes = MAX_SELECTION_QUANTUM;

  reply.type = SelectionNotify;
  reply.display = display;
622
  reply.requestor = window;
Richard M. Stallman's avatar
Richard M. Stallman committed
623 624 625 626 627 628 629
  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;

630
  BLOCK_INPUT;
631 632 633 634
  /* The protected block contains wait_for_property_change, which can
     run random lisp code (process handlers) or signal.  Therefore, we
     put the x_uncatch_errors call in an unwind.  */
  record_unwind_protect (x_catch_errors_unwind, Qnil);
635
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
636

637 638 639 640
#ifdef TRACE_SELECTION
  {
    char *sel = XGetAtomName (display, reply.selection);
    char *tgt = XGetAtomName (display, reply.target);
641
    TRACE3 ("%s, target %s (%d)", sel, tgt, ++x_reply_selection_request_cnt);
642 643 644 645 646
    if (sel) XFree (sel);
    if (tgt) XFree (tgt);
  }
#endif /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
647 648 649 650 651 652 653
  /* 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.  */
654
      TRACE1 ("Sending all %d bytes", bytes_remaining);
Richard M. Stallman's avatar
Richard M. Stallman committed
655 656 657
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, size);
      /* At this point, the selection was successfully stored; ack it.  */
658
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
Richard M. Stallman's avatar
Richard M. Stallman committed
659 660 661 662
    }
  else
    {
      /* Send an INCR selection.  */
663
      struct prop_location *wait_object;
664
      int had_errors;
665
      Lisp_Object frame;
Richard M. Stallman's avatar
Richard M. Stallman committed
666

667 668 669 670 671 672 673
      frame = some_frame_on_display (dpyinfo);

      /* If the display no longer has frames, we can't expect
	 to get many more selection requests from it, so don't
	 bother trying to queue them.  */
      if (!NILP (frame))
	{
674
	  x_start_queuing_selection_requests ();
675 676

	  record_unwind_protect (queue_selection_requests_unwind,
677
				 Qnil);
678
	}
679

680
      if (x_window_to_frame (dpyinfo, window)) /* #### debug */
681
	error ("Attempt to transfer an INCR to ourself!");
682

683 684
      TRACE2 ("Start sending %d bytes incrementally (%s)",
	      bytes_remaining,  XGetAtomName (display, reply.property));
685 686
      wait_object = expect_property_change (display, window, reply.property,
					    PropertyDelete);
Richard M. Stallman's avatar
Richard M. Stallman committed
687

688 689
      TRACE1 ("Set %s to number of bytes to send",
	      XGetAtomName (display, reply.property));
690 691 692 693 694 695 696 697 698 699 700
      {
        /* XChangeProperty expects an array of long even if long is more than
           32 bits.  */
        long value[1];

        value[0] = bytes_remaining;
        XChangeProperty (display, window, reply.property, dpyinfo->Xatom_INCR,
                         32, PropModeReplace,
                         (unsigned char *) value, 1);
      }

Richard M. Stallman's avatar
Richard M. Stallman committed
701
      XSelectInput (display, window, PropertyChangeMask);
702

Richard M. Stallman's avatar
Richard M. Stallman committed
703
      /* Tell 'em the INCR data is there...  */
704
      TRACE0 ("Send SelectionNotify event");
705
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
706
      XFlush (display);
707 708

      had_errors = x_had_errors_p (display);
709
      UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
710

711
      /* First, wait for the requester to ack by deleting the property.
Richard M. Stallman's avatar
Richard M. Stallman committed
712
	 This can run random lisp code (process handlers) or signal.  */
713
      if (! had_errors)
714 715 716 717 718
	{
	  TRACE1 ("Waiting for ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
	  wait_for_property_change (wait_object);
	}
719 720
      else
	unexpect_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
721

722
      TRACE0 ("Got ACK");
Richard M. Stallman's avatar
Richard M. Stallman committed
723 724
      while (bytes_remaining)
	{
725 726
          int i = ((bytes_remaining < max_bytes)
                   ? bytes_remaining
727
                   : max_bytes) / format_bytes;
728 729 730

	  BLOCK_INPUT;

731 732 733
	  wait_object
	    = expect_property_change (display, window, reply.property,
				      PropertyDelete);
734

735
	  TRACE1 ("Sending increment of %d elements", i);
736 737
	  TRACE1 ("Set %s to increment data",
		  XGetAtomName (display, reply.property));
738

Richard M. Stallman's avatar
Richard M. Stallman committed
739 740
	  /* Append the next chunk of data to the property.  */
	  XChangeProperty (display, window, reply.property, type, format,
741 742 743 744 745 746
			   PropModeAppend, data, i);
	  bytes_remaining -= i * format_bytes;
	  if (format == 32)
	    data += i * sizeof (long);
	  else
	    data += i * format_bytes;
747
	  XFlush (display);
748
	  had_errors = x_had_errors_p (display);
749
	  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
750

751 752 753
	  if (had_errors)
	    break;

754
	  /* Now wait for the requester to ack this chunk by deleting the
Juanma Barranquero's avatar
Juanma Barranquero committed
755
	     property.  This can run random lisp code or signal.  */
756 757
	  TRACE1 ("Waiting for increment ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
758
	  wait_for_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
759
	}
760

761 762
      /* Now write a zero-length chunk to the property to tell the
	 requester that we're done.  */
763
      BLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
764 765 766
      if (! waiting_for_other_props_on_window (display, window))
	XSelectInput (display, window, 0L);

767 768
      TRACE1 ("Set %s to a 0-length chunk to indicate EOF",
	      XGetAtomName (display, reply.property));
Richard M. Stallman's avatar
Richard M. Stallman committed
769 770
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, 0);
771
      TRACE0 ("Done sending incrementally");
Richard M. Stallman's avatar
Richard M. Stallman committed
772
    }
773

Richard M. Stallman's avatar
Richard M. Stallman committed
774
  /* rms, 2003-01-03: I think I have fixed this bug.  */
775 776 777 778 779 780
  /* The window we're communicating with may have been deleted
     in the meantime (that's a real situation from a bug report).
     In this case, there may be events in the event queue still
     refering to the deleted window, and we'll get a BadWindow error
     in XTread_socket when processing the events.  I don't have
     an idea how to fix that.  gerd, 2001-01-98.   */
781 782 783
  /* 2004-09-10: XSync and UNBLOCK so that possible protocol errors are
     delivered before uncatch errors.  */
  XSync (display, False);
784
  UNBLOCK_INPUT;
785 786 787 788 789

  /* GTK queues events in addition to the queue in Xlib.  So we
     UNBLOCK to enter the event loop and get possible errors delivered,
     and then BLOCK again because x_uncatch_errors requires it.  */
  BLOCK_INPUT;
790
  /* This calls x_uncatch_errors.  */
791
  unbind_to (count, Qnil);
792
  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
793 794 795 796 797
}

/* Handle a SelectionRequest event EVENT.
   This is called from keyboard.c when such an event is found in the queue.  */

798
static void
799
x_handle_selection_request (struct input_event *event)
Richard M. Stallman's avatar
Richard M. Stallman committed
800 801
{
  struct gcpro gcpro1, gcpro2, gcpro3;
802
  Lisp_Object local_selection_data;
Richard M. Stallman's avatar
Richard M. Stallman committed
803
  Lisp_Object selection_symbol;
804 805
  Lisp_Object target_symbol;
  Lisp_Object converted_selection;
Richard M. Stallman's avatar
Richard M. Stallman committed
806
  Time local_selection_time;
807
  Lisp_Object successful_p;
Richard M. Stallman's avatar
Richard M. Stallman committed
808
  int count;
809 810
  struct x_display_info *dpyinfo
    = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));
Richard M. Stallman's avatar
Richard M. Stallman committed
811

812 813 814
  TRACE2 ("x_handle_selection_request, from=0x%08lx time=%lu",
	  (unsigned long) SELECTION_EVENT_REQUESTOR (event),
	  (unsigned long) SELECTION_EVENT_TIME (event));
815

816 817 818 819 820
  local_selection_data = Qnil;
  target_symbol = Qnil;
  converted_selection = Qnil;
  successful_p = Qnil;

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

823
  selection_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
824 825 826 827 828 829 830 831 832 833 834 835 836
				       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)
837
    cons_to_long (XCAR (XCDR (XCDR (local_selection_data))));
Richard M. Stallman's avatar
Richard M. Stallman committed
838 839

  if (SELECTION_EVENT_TIME (event) != CurrentTime
840
      && local_selection_time > SELECTION_EVENT_TIME (event))
Richard M. Stallman's avatar
Richard M. Stallman committed
841 842 843 844 845 846 847 848 849
    {
      /* Someone asked for the selection, and we have one, but not the one
	 they're looking for.
       */
      x_decline_selection_request (event);
      goto DONE;
    }

  x_selection_current_request = event;
850
  count = SPECPDL_INDEX ();
851
  selection_request_dpyinfo = dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
852 853
  record_unwind_protect (x_selection_request_lisp_error, Qnil);

854
  target_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
855 856 857 858 859 860
				    SELECTION_EVENT_TARGET (event));

#if 0 /* #### MULTIPLE doesn't work yet */
  if (EQ (target_symbol, QMULTIPLE))
    target_symbol = fetch_multiple_target (event);
#endif
861

Richard M. Stallman's avatar
Richard M. Stallman committed
862
  /* Convert lisp objects back into binary data */
863

Richard M. Stallman's avatar
Richard M. Stallman committed
864
  converted_selection
Kenichi Handa's avatar
Kenichi Handa committed
865
    = x_get_local_selection (selection_symbol, target_symbol, 0);
866

Richard M. Stallman's avatar
Richard M. Stallman committed
867 868 869 870 871 872
  if (! NILP (converted_selection))
    {
      unsigned char *data;
      unsigned int size;
      int format;
      Atom type;
873 874
      int nofree;

875 876 877 878 879 880
      if (CONSP (converted_selection) && NILP (XCDR (converted_selection)))
        {
          x_decline_selection_request (event);
          goto DONE2;
        }

881 882
      lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event),
				   converted_selection,
883
				   &data, &type, &size, &format, &nofree);
884

Richard M. Stallman's avatar
Richard M. Stallman committed
885 886 887 888
      x_reply_selection_request (event, format, data, size, type);
      successful_p = Qt;

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

891
      /* Use xfree, not XFree, because lisp_data_to_selection_data
892
	 calls xmalloc itself.  */
893
      if (!nofree)
894
	xfree (data);
Richard M. Stallman's avatar
Richard M. Stallman committed
895
    }
896 897

 DONE2:
Richard M. Stallman's avatar
Richard M. Stallman committed
898 899 900 901 902 903
  unbind_to (count, Qnil);

 DONE:

  /* Let random lisp code notice that the selection has been asked for.  */
  {
904
    Lisp_Object rest;
905
    rest = Vx_sent_selection_functions;
Richard M. Stallman's avatar
Richard M. Stallman committed
906 907 908 909
    if (!EQ (rest, Qunbound))
      for (; CONSP (rest); rest = Fcdr (rest))
	call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
  }