xselect.c 85.2 KB
Newer Older
1
/* X Selection processing for Emacs.
2
   Copyright (C) 1993, 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
Glenn Morris's avatar
Glenn Morris committed
3
                 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4 5 6

This file is part of GNU Emacs.

7
GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
8
it under the terms of the GNU General Public License as published by
9 10
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
11 12 13 14 15 16 17

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

Jim Blandy's avatar
Jim Blandy committed
20

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

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

#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

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

#include <X11/Xproto.h>
45

46 47
struct prop_location;

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 77 78
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);
79 80
static Lisp_Object selection_data_to_lisp_data (Display *,
						const unsigned char *,
81 82 83 84 85
                                                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);
86 87 88 89 90 91 92 93 94 95

/* 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)
96 97
#define TRACE3(fmt, a0, a1, a2) \
  fprintf (stderr, "%d: " fmt "\n", getpid (), a0, a1, a2)
98 99 100 101
#else
#define TRACE0(fmt)		(void) 0
#define TRACE1(fmt, a0)		(void) 0
#define TRACE2(fmt, a0, a1)	(void) 0
102
#define TRACE3(fmt, a0, a1)	(void) 0
103 104 105
#endif


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

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

113
Lisp_Object Qcompound_text_with_extensions;
114

115 116
static Lisp_Object Vx_lost_selection_functions;
static Lisp_Object Vx_sent_selection_functions;
117 118
static Lisp_Object Qforeign_selection;

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

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

129
/* The timestamp of the last input event Emacs received from the X server.  */
130 131
/* Defined in keyboard.c.  */
extern unsigned long last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
132 133

/* This is an association list whose elements are of the form
134 135 136
     ( SELECTION-NAME SELECTION-VALUE SELECTION-TIMESTAMP FRAME)
   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.
Richard M. Stallman's avatar
Richard M. Stallman committed
137
     It may be any kind of Lisp object.
138
   SELECTION-TIMESTAMP is the time at which emacs began owning this selection,
Richard M. Stallman's avatar
Richard M. Stallman committed
139
     as a cons of two 16-bit numbers (making a 32 bit time.)
140 141
   FRAME is the frame for which we made the selection.
   If there is an entry in this alist, then it can be assumed that Emacs owns
Richard M. Stallman's avatar
Richard M. Stallman committed
142 143
    that selection.
   The only (eq) parts of this list that are visible from Lisp are the
144 145
    selection-values.  */
static Lisp_Object Vselection_alist;
Richard M. Stallman's avatar
Richard M. Stallman committed
146 147 148

/* 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
149
   call to convert the given Emacs selection value to a string representing
Richard M. Stallman's avatar
Richard M. Stallman committed
150
   the given selection type.  This is for Lisp-level extension of the emacs
151 152
   selection handling.  */
static Lisp_Object Vselection_converter_alist;
Richard M. Stallman's avatar
Richard M. Stallman committed
153 154

/* If the selection owner takes too long to reply to a selection request,
155
   we give up on it.  This is in milliseconds (0 = no timeout.)  */
156
static EMACS_INT x_selection_timeout;
Richard M. Stallman's avatar
Richard M. Stallman committed
157

158 159


160 161
/* Define a queue to save up SELECTION_REQUEST_EVENT events for later
   handling.  */
162 163 164 165 166 167 168 169 170

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

static struct selection_event_queue *selection_queue;

171
/* Nonzero means queue up SELECTION_REQUEST_EVENT events.  */
172 173 174

static int x_queue_selection_requests;

175
/* Queue up an SELECTION_REQUEST_EVENT *EVENT, to be processed later.  */
176 177

static void
178
x_queue_event (struct input_event *event)
179 180 181
{
  struct selection_event_queue *queue_tmp;

182 183
  /* Don't queue repeated requests.
     This only happens for large requests which uses the incremental protocol.  */
184 185
  for (queue_tmp = selection_queue; queue_tmp; queue_tmp = queue_tmp->next)
    {
186
      if (!memcmp (&queue_tmp->event, event, sizeof (*event)))
187
	{
188 189
	  TRACE1 ("DECLINE DUP SELECTION EVENT %08lx", (unsigned long)queue_tmp);
	  x_decline_selection_request (event);
190 191 192 193 194 195 196 197 198
	  return;
	}
    }

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

  if (queue_tmp != NULL)
    {
199
      TRACE1 ("QUEUE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
200 201 202 203 204 205
      queue_tmp->event = *event;
      queue_tmp->next = selection_queue;
      selection_queue = queue_tmp;
    }
}

206
/* Start queuing SELECTION_REQUEST_EVENT events.  */
207 208

static void
209
x_start_queuing_selection_requests (void)
210 211 212 213 214 215 216 217
{
  if (x_queue_selection_requests)
    abort ();

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

218
/* Stop queuing SELECTION_REQUEST_EVENT events.  */
219 220

static void
221
x_stop_queuing_selection_requests (void)
222 223 224 225 226 227 228 229 230 231
{
  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;
232
      TRACE1 ("RESTORE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
233 234 235 236 237 238 239
      kbd_buffer_unget_event (&queue_tmp->event);
      selection_queue = queue_tmp->next;
      xfree ((char *)queue_tmp);
    }
}


240
/* This converts a Lisp symbol to a server Atom, avoiding a server
Richard M. Stallman's avatar
Richard M. Stallman committed
241 242 243
   roundtrip whenever possible.  */

static Atom
244
symbol_to_x_atom (struct x_display_info *dpyinfo, Display *display, Lisp_Object sym)
Richard M. Stallman's avatar
Richard M. Stallman committed
245 246 247 248 249 250 251 252
{
  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;
253 254 255
  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
256
  if (EQ (sym, QCOMPOUND_TEXT)) return dpyinfo->Xatom_COMPOUND_TEXT;
Kenichi Handa's avatar
Kenichi Handa committed
257
  if (EQ (sym, QUTF8_STRING)) return dpyinfo->Xatom_UTF8_STRING;
258 259 260 261 262 263
  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
264 265
  if (!SYMBOLP (sym)) abort ();

266
  TRACE1 (" XInternAtom %s", (char *) SDATA (SYMBOL_NAME (sym)));
Richard M. Stallman's avatar
Richard M. Stallman committed
267
  BLOCK_INPUT;
268
  val = XInternAtom (display, (char *) SDATA (SYMBOL_NAME (sym)), False);
Richard M. Stallman's avatar
Richard M. Stallman committed
269 270 271 272 273 274 275 276 277
  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
278
x_atom_to_symbol (Display *dpy, Atom atom)
Richard M. Stallman's avatar
Richard M. Stallman committed
279
{
280
  struct x_display_info *dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
281 282
  char *str;
  Lisp_Object val;
283

284 285
  if (! atom)
    return Qnil;
286

287 288 289 290 291 292 293 294 295 296 297 298 299 300
  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;
    }

301
  dpyinfo = x_display_info_for_display (dpy);
302
  if (atom == dpyinfo->Xatom_CLIPBOARD)
303
    return QCLIPBOARD;
304
  if (atom == dpyinfo->Xatom_TIMESTAMP)
305
    return QTIMESTAMP;
306
  if (atom == dpyinfo->Xatom_TEXT)
307
    return QTEXT;
Karl Heuer's avatar
Karl Heuer committed
308 309
  if (atom == dpyinfo->Xatom_COMPOUND_TEXT)
    return QCOMPOUND_TEXT;
Kenichi Handa's avatar
Kenichi Handa committed
310 311
  if (atom == dpyinfo->Xatom_UTF8_STRING)
    return QUTF8_STRING;
312
  if (atom == dpyinfo->Xatom_DELETE)
313
    return QDELETE;
314
  if (atom == dpyinfo->Xatom_MULTIPLE)
315
    return QMULTIPLE;
316
  if (atom == dpyinfo->Xatom_INCR)
317
    return QINCR;
318
  if (atom == dpyinfo->Xatom_EMACS_TMP)
319
    return QEMACS_TMP;
320
  if (atom == dpyinfo->Xatom_TARGETS)
321
    return QTARGETS;
322
  if (atom == dpyinfo->Xatom_NULL)
323
    return QNULL;
Richard M. Stallman's avatar
Richard M. Stallman committed
324 325

  BLOCK_INPUT;
326
  str = XGetAtomName (dpy, atom);
Richard M. Stallman's avatar
Richard M. Stallman committed
327
  UNBLOCK_INPUT;
328
  TRACE1 ("XGetAtomName --> %s", str);
Richard M. Stallman's avatar
Richard M. Stallman committed
329 330 331
  if (! str) return Qnil;
  val = intern (str);
  BLOCK_INPUT;
332
  /* This was allocated by Xlib, so use XFree.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
333 334 335 336
  XFree (str);
  UNBLOCK_INPUT;
  return val;
}
337

Richard M. Stallman's avatar
Richard M. Stallman committed
338
/* Do protocol to assert ourself as a selection owner.
339
   Update the Vselection_alist so that we can reply to later requests for
Richard M. Stallman's avatar
Richard M. Stallman committed
340 341 342
   our selection.  */

static void
343
x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value)
Richard M. Stallman's avatar
Richard M. Stallman committed
344
{
345
  struct frame *sf = SELECTED_FRAME ();
346 347
  Window selecting_window;
  Display *display;
348
  Time time = last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
349
  Atom selection_atom;
350
  struct x_display_info *dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
351

352 353 354 355 356 357
  if (! FRAME_X_P (sf))
    return;

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

359
  CHECK_SYMBOL (selection_name);
360
  selection_atom = symbol_to_x_atom (dpyinfo, display, selection_name);
Richard M. Stallman's avatar
Richard M. Stallman committed
361 362

  BLOCK_INPUT;
363
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
364
  XSetSelectionOwner (display, selection_atom, selecting_window, time);
365
  x_check_errors (display, "Can't set selection: %s");
366
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
367 368 369 370 371 372 373 374 375
  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);
376 377
    selection_data = list4 (selection_name, selection_value,
			    selection_time, selected_frame);
Richard M. Stallman's avatar
Richard M. Stallman committed
378 379 380 381 382 383 384 385 386 387
    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.  */
388
	for (rest = Vselection_alist; CONSP (rest); rest = XCDR (rest))
389
	  if (EQ (prev_value, Fcar (XCDR (rest))))
Richard M. Stallman's avatar
Richard M. Stallman committed
390
	    {
391
	      XSETCDR (rest, Fcdr (XCDR (rest)));
Richard M. Stallman's avatar
Richard M. Stallman committed
392 393 394 395 396 397 398 399 400
	      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
401 402
   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
403 404 405 406

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

static Lisp_Object
407
x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type, int local_request)
Richard M. Stallman's avatar
Richard M. Stallman committed
408 409 410 411 412 413 414 415 416 417 418 419 420
{
  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;
421
      value = XCAR (XCDR (XCDR (local_value)));
Richard M. Stallman's avatar
Richard M. Stallman committed
422 423 424 425 426 427 428
    }
#if 0
  else if (EQ (target_type, QDELETE))
    {
      handler_fn = Qnil;
      Fx_disown_selection_internal
	(selection_symbol,
429
	 XCAR (XCDR (XCDR (local_value))));
Richard M. Stallman's avatar
Richard M. Stallman committed
430 431 432 433 434 435
      value = QNULL;
    }
#endif

#if 0 /* #### MULTIPLE doesn't work yet */
  else if (CONSP (target_type)
436
	   && XCAR (target_type) == QMULTIPLE)
Richard M. Stallman's avatar
Richard M. Stallman committed
437
    {
438 439
      Lisp_Object pairs;
      int size;
Richard M. Stallman's avatar
Richard M. Stallman committed
440
      int i;
441
      pairs = XCDR (target_type);
442
      size = XVECTOR (pairs)->size;
Richard M. Stallman's avatar
Richard M. Stallman committed
443 444 445 446 447 448 449
      /* 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++)
	{
450 451
	  Lisp_Object pair;
	  pair = XVECTOR (pairs)->contents [i];
Richard M. Stallman's avatar
Richard M. Stallman committed
452 453
	  XVECTOR (pair)->contents [1]
	    = x_get_local_selection (XVECTOR (pair)->contents [0],
Kenichi Handa's avatar
Kenichi Handa committed
454 455
				     XVECTOR (pair)->contents [1],
				     local_request);
Richard M. Stallman's avatar
Richard M. Stallman committed
456 457 458 459 460 461 462 463 464
	}
      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
465
      count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
466 467
      specbind (Qinhibit_quit, Qt);

468
      CHECK_SYMBOL (target_type);
Richard M. Stallman's avatar
Richard M. Stallman committed
469
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
470 471 472
      /* gcpro is not needed here since nothing but HANDLER_FN
	 is live, and that ought to be a symbol.  */

473 474
      if (!NILP (handler_fn))
	value = call3 (handler_fn,
Kenichi Handa's avatar
Kenichi Handa committed
475
		       selection_symbol, (local_request ? Qnil : target_type),
476
		       XCAR (XCDR (local_value)));
477 478
      else
	value = Qnil;
Richard M. Stallman's avatar
Richard M. Stallman committed
479 480 481 482 483
      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
484

Richard M. Stallman's avatar
Richard M. Stallman committed
485 486
  check = value;
  if (CONSP (value)
487 488 489
      && SYMBOLP (XCAR (value)))
    type = XCAR (value),
    check = XCDR (value);
490

Richard M. Stallman's avatar
Richard M. Stallman committed
491 492 493
  if (STRINGP (check)
      || VECTORP (check)
      || SYMBOLP (check)
494
      || INTEGERP (check)
Richard M. Stallman's avatar
Richard M. Stallman committed
495 496
      || NILP (value))
    return value;
Richard M. Stallman's avatar
Richard M. Stallman committed
497
  /* Check for a value that cons_to_long could handle.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
498
  else if (CONSP (check)
499 500
	   && INTEGERP (XCAR (check))
	   && (INTEGERP (XCDR (check))
Richard M. Stallman's avatar
Richard M. Stallman committed
501
	       ||
502 503 504
	       (CONSP (XCDR (check))
		&& INTEGERP (XCAR (XCDR (check)))
		&& NILP (XCDR (XCDR (check))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
505
    return value;
506 507 508

  signal_error ("Invalid data returned by selection-conversion function",
		list2 (handler_fn, value));
Richard M. Stallman's avatar
Richard M. Stallman committed
509 510 511 512
}

/* Subroutines of x_reply_selection_request.  */

513
/* Send a SelectionNotify event to the requestor with property=None,
Richard M. Stallman's avatar
Richard M. Stallman committed
514 515 516
   meaning we were unable to do what they wanted.  */

static void
517
x_decline_selection_request (struct input_event *event)
Richard M. Stallman's avatar
Richard M. Stallman committed
518 519
{
  XSelectionEvent reply;
520

Richard M. Stallman's avatar
Richard M. Stallman committed
521 522
  reply.type = SelectionNotify;
  reply.display = SELECTION_EVENT_DISPLAY (event);
523
  reply.requestor = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
524 525 526 527 528
  reply.selection = SELECTION_EVENT_SELECTION (event);
  reply.time = SELECTION_EVENT_TIME (event);
  reply.target = SELECTION_EVENT_TARGET (event);
  reply.property = None;

529 530
  /* 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
531
  BLOCK_INPUT;
532
  x_catch_errors (reply.display);
533
  XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
534
  XFlush (reply.display);
535
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
536 537 538 539 540 541 542
  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;

543 544 545 546
/* Display info in x_selection_request.  */

static struct x_display_info *selection_request_dpyinfo;

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

static Lisp_Object
552
x_selection_request_lisp_error (Lisp_Object ignore)
Richard M. Stallman's avatar
Richard M. Stallman committed
553
{
554 555
  if (x_selection_current_request != 0
      && selection_request_dpyinfo->display)
Richard M. Stallman's avatar
Richard M. Stallman committed
556 557 558
    x_decline_selection_request (x_selection_current_request);
  return Qnil;
}
559 560

static Lisp_Object
561
x_catch_errors_unwind (Lisp_Object dummy)
562 563 564 565
{
  BLOCK_INPUT;
  x_uncatch_errors ();
  UNBLOCK_INPUT;
566
  return Qnil;
567
}
Richard M. Stallman's avatar
Richard M. Stallman committed
568

569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586

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

587 588 589 590
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);
591 592 593 594 595 596 597 598

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;
599 600

static Lisp_Object
601
queue_selection_requests_unwind (Lisp_Object tem)
602
{
603
  x_stop_queuing_selection_requests ();
604
  return Qnil;
605 606 607 608 609 610
}

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

static Lisp_Object
611
some_frame_on_display (struct x_display_info *dpyinfo)
612 613 614 615 616
{
  Lisp_Object list, frame;

  FOR_EACH_FRAME (list, frame)
    {
617 618
      if (FRAME_X_P (XFRAME (frame))
          && FRAME_X_DISPLAY_INFO (XFRAME (frame)) == dpyinfo)
619 620 621 622 623
	return frame;
    }

  return Qnil;
}
624

Richard M. Stallman's avatar
Richard M. Stallman committed
625 626 627 628 629
/* 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.  */

630
#ifdef TRACE_SELECTION
631
static int x_reply_selection_request_cnt;
632 633
#endif  /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
634
static void
635
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
636 637 638
{
  XSelectionEvent reply;
  Display *display = SELECTION_EVENT_DISPLAY (event);
639
  Window window = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
640 641 642
  int bytes_remaining;
  int format_bytes = format/8;
  int max_bytes = SELECTION_QUANTUM (display);
643
  struct x_display_info *dpyinfo = x_display_info_for_display (display);
644
  int count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
645 646 647 648 649 650

  if (max_bytes > MAX_SELECTION_QUANTUM)
    max_bytes = MAX_SELECTION_QUANTUM;

  reply.type = SelectionNotify;
  reply.display = display;
651
  reply.requestor = window;
Richard M. Stallman's avatar
Richard M. Stallman committed
652 653 654 655 656 657 658
  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;

659
  BLOCK_INPUT;
660 661 662 663
  /* 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);
664
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
665

666 667 668 669
#ifdef TRACE_SELECTION
  {
    char *sel = XGetAtomName (display, reply.selection);
    char *tgt = XGetAtomName (display, reply.target);
670
    TRACE3 ("%s, target %s (%d)", sel, tgt, ++x_reply_selection_request_cnt);
671 672 673 674 675
    if (sel) XFree (sel);
    if (tgt) XFree (tgt);
  }
#endif /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
676 677 678 679 680 681 682
  /* 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.  */
683
      TRACE1 ("Sending all %d bytes", bytes_remaining);
Richard M. Stallman's avatar
Richard M. Stallman committed
684 685 686
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, size);
      /* At this point, the selection was successfully stored; ack it.  */
687
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
Richard M. Stallman's avatar
Richard M. Stallman committed
688 689 690 691
    }
  else
    {
      /* Send an INCR selection.  */
692
      struct prop_location *wait_object;
693
      int had_errors;
694
      Lisp_Object frame;
Richard M. Stallman's avatar
Richard M. Stallman committed
695

696 697 698 699 700 701 702
      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))
	{
703
	  x_start_queuing_selection_requests ();
704 705

	  record_unwind_protect (queue_selection_requests_unwind,
706
				 Qnil);
707
	}
708

709
      if (x_window_to_frame (dpyinfo, window)) /* #### debug */
710
	error ("Attempt to transfer an INCR to ourself!");
711

712 713
      TRACE2 ("Start sending %d bytes incrementally (%s)",
	      bytes_remaining,  XGetAtomName (display, reply.property));
714 715
      wait_object = expect_property_change (display, window, reply.property,
					    PropertyDelete);
Richard M. Stallman's avatar
Richard M. Stallman committed
716

717 718
      TRACE1 ("Set %s to number of bytes to send",
	      XGetAtomName (display, reply.property));
719 720 721 722 723 724 725 726 727 728 729
      {
        /* 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
730
      XSelectInput (display, window, PropertyChangeMask);
731

Richard M. Stallman's avatar
Richard M. Stallman committed
732
      /* Tell 'em the INCR data is there...  */
733
      TRACE0 ("Send SelectionNotify event");
734
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
735
      XFlush (display);
736 737

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

740
      /* First, wait for the requester to ack by deleting the property.
Richard M. Stallman's avatar
Richard M. Stallman committed
741
	 This can run random lisp code (process handlers) or signal.  */
742
      if (! had_errors)
743 744 745 746 747
	{
	  TRACE1 ("Waiting for ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
	  wait_for_property_change (wait_object);
	}
748 749
      else
	unexpect_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
750

751
      TRACE0 ("Got ACK");
Richard M. Stallman's avatar
Richard M. Stallman committed
752 753
      while (bytes_remaining)
	{
754 755
          int i = ((bytes_remaining < max_bytes)
                   ? bytes_remaining
756
                   : max_bytes) / format_bytes;
757 758 759

	  BLOCK_INPUT;

760 761 762
	  wait_object
	    = expect_property_change (display, window, reply.property,
				      PropertyDelete);
763

764
	  TRACE1 ("Sending increment of %d elements", i);
765 766
	  TRACE1 ("Set %s to increment data",
		  XGetAtomName (display, reply.property));
767

Richard M. Stallman's avatar
Richard M. Stallman committed
768 769
	  /* Append the next chunk of data to the property.  */
	  XChangeProperty (display, window, reply.property, type, format,
770 771 772 773 774 775
			   PropModeAppend, data, i);
	  bytes_remaining -= i * format_bytes;
	  if (format == 32)
	    data += i * sizeof (long);
	  else
	    data += i * format_bytes;
776
	  XFlush (display);
777
	  had_errors = x_had_errors_p (display);
778
	  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
779

780 781 782
	  if (had_errors)
	    break;

783
	  /* Now wait for the requester to ack this chunk by deleting the
Juanma Barranquero's avatar
Juanma Barranquero committed
784
	     property.  This can run random lisp code or signal.  */
785 786
	  TRACE1 ("Waiting for increment ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
787
	  wait_for_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
788
	}
789

790 791
      /* Now write a zero-length chunk to the property to tell the
	 requester that we're done.  */
792
      BLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
793 794 795
      if (! waiting_for_other_props_on_window (display, window))
	XSelectInput (display, window, 0L);

796 797
      TRACE1 ("Set %s to a 0-length chunk to indicate EOF",
	      XGetAtomName (display, reply.property));
Richard M. Stallman's avatar
Richard M. Stallman committed
798 799
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, 0);
800
      TRACE0 ("Done sending incrementally");
Richard M. Stallman's avatar
Richard M. Stallman committed
801
    }
802

Richard M. Stallman's avatar
Richard M. Stallman committed
803
  /* rms, 2003-01-03: I think I have fixed this bug.  */
804 805 806 807 808 809
  /* 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.   */
810 811 812
  /* 2004-09-10: XSync and UNBLOCK so that possible protocol errors are
     delivered before uncatch errors.  */
  XSync (display, False);
813
  UNBLOCK_INPUT;
814 815 816 817 818

  /* 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;
819
  /* This calls x_uncatch_errors.  */
820
  unbind_to (count, Qnil);
821
  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
822 823 824 825 826
}

/* Handle a SelectionRequest event EVENT.
   This is called from keyboard.c when such an event is found in the queue.  */

827
static void
828
x_handle_selection_request (struct input_event *event)
Richard M. Stallman's avatar
Richard M. Stallman committed
829 830
{
  struct gcpro gcpro1, gcpro2, gcpro3;
831
  Lisp_Object local_selection_data;
Richard M. Stallman's avatar
Richard M. Stallman committed
832
  Lisp_Object selection_symbol;
833 834
  Lisp_Object target_symbol;
  Lisp_Object converted_selection;
Richard M. Stallman's avatar
Richard M. Stallman committed
835
  Time local_selection_time;
836
  Lisp_Object successful_p;
Richard M. Stallman's avatar
Richard M. Stallman committed
837
  int count;
838 839
  struct x_display_info *dpyinfo
    = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));
Richard M. Stallman's avatar
Richard M. Stallman committed
840

841 842 843
  TRACE2 ("x_handle_selection_request, from=0x%08lx time=%lu",
	  (unsigned long) SELECTION_EVENT_REQUESTOR (event),
	  (unsigned long) SELECTION_EVENT_TIME (event));
844

845 846 847 848 849
  local_selection_data = Qnil;
  target_symbol = Qnil;
  converted_selection = Qnil;
  successful_p = Qnil;

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

852
  selection_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
853 854 855 856 857 858 859 860 861 862 863 864 865
				       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)
866
    cons_to_long (XCAR (XCDR (XCDR (local_selection_data))));
Richard M. Stallman's avatar
Richard M. Stallman committed
867 868

  if (SELECTION_EVENT_TIME (event) != CurrentTime
869
      && local_selection_time > SELECTION_EVENT_TIME (event))
Richard M. Stallman's avatar
Richard M. Stallman committed
870 871 872 873 874 875 876 877 878
    {
      /* 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;
879
  count = SPECPDL_INDEX ();
880
  selection_request_dpyinfo = dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
881 882
  record_unwind_protect (x_selection_request_lisp_error, Qnil);

883
  target_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
884 885 886 887 888 889
				    SELECTION_EVENT_TARGET (event));

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

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

Richard M. Stallman's avatar
Richard M. Stallman committed
893
  converted_selection
Kenichi Handa's avatar
Kenichi Handa committed
894
    = x_get_local_selection (selection_symbol, target_symbol, 0);
895

Richard M. Stallman's avatar
Richard M. Stallman committed
896 897 898 899 900 901
  if (! NILP (converted_selection))
    {
      unsigned char *data;
      unsigned int size;
      int format;
      Atom type;
902 903
      int nofree;

904 905 906 907 908 909
      if (CONSP (converted_selection) && NILP (XCDR (converted_selection)))
        {
          x_decline_selection_request (event);
          goto DONE2;
        }

910 911
      lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event),
				   converted_selection,
Richard M. Stallman's avatar