xselect.c 92 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 86
                                                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);
static void initialize_cut_buffers (Display *, Window);
87 88 89 90 91 92 93 94 95 96 97


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


Richard M. Stallman's avatar
Richard M. Stallman committed
108 109 110 111 112 113
#define CUT_BUFFER_SUPPORT

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

Karl Heuer's avatar
Karl Heuer committed
114
Lisp_Object QCOMPOUND_TEXT;	/* This is a type of selection.  */
Kenichi Handa's avatar
Kenichi Handa committed
115
Lisp_Object QUTF8_STRING;	/* This is a type of selection.  */
Karl Heuer's avatar
Karl Heuer committed
116

117
Lisp_Object Qcompound_text_with_extensions;
118

Richard M. Stallman's avatar
Richard M. Stallman committed
119 120 121 122 123
#ifdef CUT_BUFFER_SUPPORT
Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
  QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
#endif

124 125
static Lisp_Object Vx_lost_selection_functions;
static Lisp_Object Vx_sent_selection_functions;
126 127
static Lisp_Object Qforeign_selection;

Richard M. Stallman's avatar
Richard M. Stallman committed
128 129 130
/* 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
131
   emacs to use incremental selection transfers when the selection is
Richard M. Stallman's avatar
Richard M. Stallman committed
132
   smaller than that, set this.  I added this mostly for debugging the
133
   incremental transfer stuff, but it might improve server performance.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
134 135
#define MAX_SELECTION_QUANTUM 0xFFFFFF

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

138
/* The timestamp of the last input event Emacs received from the X server.  */
139 140
/* Defined in keyboard.c.  */
extern unsigned long last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
141 142

/* This is an association list whose elements are of the form
143 144 145
     ( 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
146
     It may be any kind of Lisp object.
147
   SELECTION-TIMESTAMP is the time at which emacs began owning this selection,
Richard M. Stallman's avatar
Richard M. Stallman committed
148
     as a cons of two 16-bit numbers (making a 32 bit time.)
149 150
   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
151 152
    that selection.
   The only (eq) parts of this list that are visible from Lisp are the
153 154
    selection-values.  */
static Lisp_Object Vselection_alist;
Richard M. Stallman's avatar
Richard M. Stallman committed
155 156 157

/* 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
158
   call to convert the given Emacs selection value to a string representing
Richard M. Stallman's avatar
Richard M. Stallman committed
159
   the given selection type.  This is for Lisp-level extension of the emacs
160 161
   selection handling.  */
static Lisp_Object Vselection_converter_alist;
Richard M. Stallman's avatar
Richard M. Stallman committed
162 163

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

167 168


169 170
/* Define a queue to save up SELECTION_REQUEST_EVENT events for later
   handling.  */
171 172 173 174 175 176 177 178 179

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

static struct selection_event_queue *selection_queue;

180
/* Nonzero means queue up SELECTION_REQUEST_EVENT events.  */
181 182 183

static int x_queue_selection_requests;

184
/* Queue up an SELECTION_REQUEST_EVENT *EVENT, to be processed later.  */
185 186

static void
187
x_queue_event (struct input_event *event)
188 189 190
{
  struct selection_event_queue *queue_tmp;

191 192
  /* Don't queue repeated requests.
     This only happens for large requests which uses the incremental protocol.  */
193 194
  for (queue_tmp = selection_queue; queue_tmp; queue_tmp = queue_tmp->next)
    {
195
      if (!memcmp (&queue_tmp->event, event, sizeof (*event)))
196
	{
197 198
	  TRACE1 ("DECLINE DUP SELECTION EVENT %08lx", (unsigned long)queue_tmp);
	  x_decline_selection_request (event);
199 200 201 202 203 204 205 206 207
	  return;
	}
    }

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

  if (queue_tmp != NULL)
    {
208
      TRACE1 ("QUEUE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
209 210 211 212 213 214
      queue_tmp->event = *event;
      queue_tmp->next = selection_queue;
      selection_queue = queue_tmp;
    }
}

215
/* Start queuing SELECTION_REQUEST_EVENT events.  */
216 217

static void
218
x_start_queuing_selection_requests (void)
219 220 221 222 223 224 225 226
{
  if (x_queue_selection_requests)
    abort ();

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

227
/* Stop queuing SELECTION_REQUEST_EVENT events.  */
228 229

static void
230
x_stop_queuing_selection_requests (void)
231 232 233 234 235 236 237 238 239 240
{
  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;
241
      TRACE1 ("RESTORE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
242 243 244 245 246 247 248
      kbd_buffer_unget_event (&queue_tmp->event);
      selection_queue = queue_tmp->next;
      xfree ((char *)queue_tmp);
    }
}


249
/* This converts a Lisp symbol to a server Atom, avoiding a server
Richard M. Stallman's avatar
Richard M. Stallman committed
250 251 252
   roundtrip whenever possible.  */

static Atom
253
symbol_to_x_atom (struct x_display_info *dpyinfo, Display *display, Lisp_Object sym)
Richard M. Stallman's avatar
Richard M. Stallman committed
254 255 256 257 258 259 260 261
{
  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;
262 263 264
  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
265
  if (EQ (sym, QCOMPOUND_TEXT)) return dpyinfo->Xatom_COMPOUND_TEXT;
Kenichi Handa's avatar
Kenichi Handa committed
266
  if (EQ (sym, QUTF8_STRING)) return dpyinfo->Xatom_UTF8_STRING;
267 268 269 270 271 272
  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
273 274 275 276 277 278 279 280 281 282 283 284
#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 ();

285
  TRACE1 (" XInternAtom %s", (char *) SDATA (SYMBOL_NAME (sym)));
Richard M. Stallman's avatar
Richard M. Stallman committed
286
  BLOCK_INPUT;
287
  val = XInternAtom (display, (char *) SDATA (SYMBOL_NAME (sym)), False);
Richard M. Stallman's avatar
Richard M. Stallman committed
288 289 290 291 292 293 294 295 296
  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
297
x_atom_to_symbol (Display *dpy, Atom atom)
Richard M. Stallman's avatar
Richard M. Stallman committed
298
{
299
  struct x_display_info *dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
300 301
  char *str;
  Lisp_Object val;
302

303 304
  if (! atom)
    return Qnil;
305

306 307 308 309 310 311 312 313 314 315 316 317
  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
318
#ifdef CUT_BUFFER_SUPPORT
319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334
    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
335
#endif
336 337
    }

338
  dpyinfo = x_display_info_for_display (dpy);
339
  if (atom == dpyinfo->Xatom_CLIPBOARD)
340
    return QCLIPBOARD;
341
  if (atom == dpyinfo->Xatom_TIMESTAMP)
342
    return QTIMESTAMP;
343
  if (atom == dpyinfo->Xatom_TEXT)
344
    return QTEXT;
Karl Heuer's avatar
Karl Heuer committed
345 346
  if (atom == dpyinfo->Xatom_COMPOUND_TEXT)
    return QCOMPOUND_TEXT;
Kenichi Handa's avatar
Kenichi Handa committed
347 348
  if (atom == dpyinfo->Xatom_UTF8_STRING)
    return QUTF8_STRING;
349
  if (atom == dpyinfo->Xatom_DELETE)
350
    return QDELETE;
351
  if (atom == dpyinfo->Xatom_MULTIPLE)
352
    return QMULTIPLE;
353
  if (atom == dpyinfo->Xatom_INCR)
354
    return QINCR;
355
  if (atom == dpyinfo->Xatom_EMACS_TMP)
356
    return QEMACS_TMP;
357
  if (atom == dpyinfo->Xatom_TARGETS)
358
    return QTARGETS;
359
  if (atom == dpyinfo->Xatom_NULL)
360
    return QNULL;
Richard M. Stallman's avatar
Richard M. Stallman committed
361 362

  BLOCK_INPUT;
363
  str = XGetAtomName (dpy, atom);
Richard M. Stallman's avatar
Richard M. Stallman committed
364
  UNBLOCK_INPUT;
365
  TRACE1 ("XGetAtomName --> %s", str);
Richard M. Stallman's avatar
Richard M. Stallman committed
366 367 368
  if (! str) return Qnil;
  val = intern (str);
  BLOCK_INPUT;
369
  /* This was allocated by Xlib, so use XFree.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
370 371 372 373
  XFree (str);
  UNBLOCK_INPUT;
  return val;
}
374

Richard M. Stallman's avatar
Richard M. Stallman committed
375
/* Do protocol to assert ourself as a selection owner.
376
   Update the Vselection_alist so that we can reply to later requests for
Richard M. Stallman's avatar
Richard M. Stallman committed
377 378 379
   our selection.  */

static void
380
x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value)
Richard M. Stallman's avatar
Richard M. Stallman committed
381
{
382
  struct frame *sf = SELECTED_FRAME ();
383 384
  Window selecting_window;
  Display *display;
385
  Time time = last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
386
  Atom selection_atom;
387
  struct x_display_info *dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
388

389 390 391 392 393 394
  if (! FRAME_X_P (sf))
    return;

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

396
  CHECK_SYMBOL (selection_name);
397
  selection_atom = symbol_to_x_atom (dpyinfo, display, selection_name);
Richard M. Stallman's avatar
Richard M. Stallman committed
398 399

  BLOCK_INPUT;
400
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
401
  XSetSelectionOwner (display, selection_atom, selecting_window, time);
402
  x_check_errors (display, "Can't set selection: %s");
403
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
404 405 406 407 408 409 410 411 412
  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);
413 414
    selection_data = list4 (selection_name, selection_value,
			    selection_time, selected_frame);
Richard M. Stallman's avatar
Richard M. Stallman committed
415 416 417 418 419 420 421 422 423 424
    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.  */
425
	for (rest = Vselection_alist; CONSP (rest); rest = XCDR (rest))
426
	  if (EQ (prev_value, Fcar (XCDR (rest))))
Richard M. Stallman's avatar
Richard M. Stallman committed
427
	    {
428
	      XSETCDR (rest, Fcdr (XCDR (rest)));
Richard M. Stallman's avatar
Richard M. Stallman committed
429 430 431 432 433 434 435 436 437
	      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
438 439
   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
440 441 442 443

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

static Lisp_Object
444
x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type, int local_request)
Richard M. Stallman's avatar
Richard M. Stallman committed
445 446 447 448 449 450 451 452 453 454 455 456 457
{
  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;
458
      value = XCAR (XCDR (XCDR (local_value)));
Richard M. Stallman's avatar
Richard M. Stallman committed
459 460 461 462 463 464 465
    }
#if 0
  else if (EQ (target_type, QDELETE))
    {
      handler_fn = Qnil;
      Fx_disown_selection_internal
	(selection_symbol,
466
	 XCAR (XCDR (XCDR (local_value))));
Richard M. Stallman's avatar
Richard M. Stallman committed
467 468 469 470 471 472
      value = QNULL;
    }
#endif

#if 0 /* #### MULTIPLE doesn't work yet */
  else if (CONSP (target_type)
473
	   && XCAR (target_type) == QMULTIPLE)
Richard M. Stallman's avatar
Richard M. Stallman committed
474
    {
475 476
      Lisp_Object pairs;
      int size;
Richard M. Stallman's avatar
Richard M. Stallman committed
477
      int i;
478
      pairs = XCDR (target_type);
479
      size = XVECTOR (pairs)->size;
Richard M. Stallman's avatar
Richard M. Stallman committed
480 481 482 483 484 485 486
      /* 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++)
	{
487 488
	  Lisp_Object pair;
	  pair = XVECTOR (pairs)->contents [i];
Richard M. Stallman's avatar
Richard M. Stallman committed
489 490
	  XVECTOR (pair)->contents [1]
	    = x_get_local_selection (XVECTOR (pair)->contents [0],
Kenichi Handa's avatar
Kenichi Handa committed
491 492
				     XVECTOR (pair)->contents [1],
				     local_request);
Richard M. Stallman's avatar
Richard M. Stallman committed
493 494 495 496 497 498 499 500 501
	}
      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
502
      count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
503 504
      specbind (Qinhibit_quit, Qt);

505
      CHECK_SYMBOL (target_type);
Richard M. Stallman's avatar
Richard M. Stallman committed
506
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
507 508 509
      /* gcpro is not needed here since nothing but HANDLER_FN
	 is live, and that ought to be a symbol.  */

510 511
      if (!NILP (handler_fn))
	value = call3 (handler_fn,
Kenichi Handa's avatar
Kenichi Handa committed
512
		       selection_symbol, (local_request ? Qnil : target_type),
513
		       XCAR (XCDR (local_value)));
514 515
      else
	value = Qnil;
Richard M. Stallman's avatar
Richard M. Stallman committed
516 517 518 519 520
      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
521

Richard M. Stallman's avatar
Richard M. Stallman committed
522 523
  check = value;
  if (CONSP (value)
524 525 526
      && SYMBOLP (XCAR (value)))
    type = XCAR (value),
    check = XCDR (value);
527

Richard M. Stallman's avatar
Richard M. Stallman committed
528 529 530
  if (STRINGP (check)
      || VECTORP (check)
      || SYMBOLP (check)
531
      || INTEGERP (check)
Richard M. Stallman's avatar
Richard M. Stallman committed
532 533
      || NILP (value))
    return value;
Richard M. Stallman's avatar
Richard M. Stallman committed
534
  /* Check for a value that cons_to_long could handle.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
535
  else if (CONSP (check)
536 537
	   && INTEGERP (XCAR (check))
	   && (INTEGERP (XCDR (check))
Richard M. Stallman's avatar
Richard M. Stallman committed
538
	       ||
539 540 541
	       (CONSP (XCDR (check))
		&& INTEGERP (XCAR (XCDR (check)))
		&& NILP (XCDR (XCDR (check))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
542
    return value;
543 544 545

  signal_error ("Invalid data returned by selection-conversion function",
		list2 (handler_fn, value));
Richard M. Stallman's avatar
Richard M. Stallman committed
546 547 548 549
}

/* Subroutines of x_reply_selection_request.  */

550
/* Send a SelectionNotify event to the requestor with property=None,
Richard M. Stallman's avatar
Richard M. Stallman committed
551 552 553
   meaning we were unable to do what they wanted.  */

static void
554
x_decline_selection_request (struct input_event *event)
Richard M. Stallman's avatar
Richard M. Stallman committed
555 556
{
  XSelectionEvent reply;
557

Richard M. Stallman's avatar
Richard M. Stallman committed
558 559
  reply.type = SelectionNotify;
  reply.display = SELECTION_EVENT_DISPLAY (event);
560
  reply.requestor = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
561 562 563 564 565
  reply.selection = SELECTION_EVENT_SELECTION (event);
  reply.time = SELECTION_EVENT_TIME (event);
  reply.target = SELECTION_EVENT_TARGET (event);
  reply.property = None;

566 567
  /* 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
568
  BLOCK_INPUT;
569
  x_catch_errors (reply.display);
570
  XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
571
  XFlush (reply.display);
572
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
573 574 575 576 577 578 579
  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;

580 581 582 583
/* Display info in x_selection_request.  */

static struct x_display_info *selection_request_dpyinfo;

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

static Lisp_Object
589
x_selection_request_lisp_error (Lisp_Object ignore)
Richard M. Stallman's avatar
Richard M. Stallman committed
590
{
591 592
  if (x_selection_current_request != 0
      && selection_request_dpyinfo->display)
Richard M. Stallman's avatar
Richard M. Stallman committed
593 594 595
    x_decline_selection_request (x_selection_current_request);
  return Qnil;
}
596 597

static Lisp_Object
598
x_catch_errors_unwind (Lisp_Object dummy)
599 600 601 602
{
  BLOCK_INPUT;
  x_uncatch_errors ();
  UNBLOCK_INPUT;
603
  return Qnil;
604
}
Richard M. Stallman's avatar
Richard M. Stallman committed
605

606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623

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

624 625 626 627
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);
628 629 630 631 632 633 634 635

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;
636 637

static Lisp_Object
638
queue_selection_requests_unwind (Lisp_Object tem)
639
{
640
  x_stop_queuing_selection_requests ();
641
  return Qnil;
642 643 644 645 646 647
}

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

static Lisp_Object
648
some_frame_on_display (struct x_display_info *dpyinfo)
649 650 651 652 653
{
  Lisp_Object list, frame;

  FOR_EACH_FRAME (list, frame)
    {
654 655
      if (FRAME_X_P (XFRAME (frame))
          && FRAME_X_DISPLAY_INFO (XFRAME (frame)) == dpyinfo)
656 657 658 659 660
	return frame;
    }

  return Qnil;
}
661

Richard M. Stallman's avatar
Richard M. Stallman committed
662 663 664 665 666
/* 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.  */

667
#ifdef TRACE_SELECTION
668
static int x_reply_selection_request_cnt;
669 670
#endif  /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
671
static void
672
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
673 674 675
{
  XSelectionEvent reply;
  Display *display = SELECTION_EVENT_DISPLAY (event);
676
  Window window = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
677 678 679
  int bytes_remaining;
  int format_bytes = format/8;
  int max_bytes = SELECTION_QUANTUM (display);
680
  struct x_display_info *dpyinfo = x_display_info_for_display (display);
681
  int count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
682 683 684 685 686 687

  if (max_bytes > MAX_SELECTION_QUANTUM)
    max_bytes = MAX_SELECTION_QUANTUM;

  reply.type = SelectionNotify;
  reply.display = display;
688
  reply.requestor = window;
Richard M. Stallman's avatar
Richard M. Stallman committed
689 690 691 692 693 694 695
  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;

696
  BLOCK_INPUT;
697 698 699 700
  /* 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);
701
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
702

703 704 705 706
#ifdef TRACE_SELECTION
  {
    char *sel = XGetAtomName (display, reply.selection);
    char *tgt = XGetAtomName (display, reply.target);
707
    TRACE3 ("%s, target %s (%d)", sel, tgt, ++x_reply_selection_request_cnt);
708 709 710 711 712
    if (sel) XFree (sel);
    if (tgt) XFree (tgt);
  }
#endif /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
713 714 715 716 717 718 719
  /* 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.  */
720
      TRACE1 ("Sending all %d bytes", bytes_remaining);
Richard M. Stallman's avatar
Richard M. Stallman committed
721 722 723
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, size);
      /* At this point, the selection was successfully stored; ack it.  */
724
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
Richard M. Stallman's avatar
Richard M. Stallman committed
725 726 727 728
    }
  else
    {
      /* Send an INCR selection.  */
729
      struct prop_location *wait_object;
730
      int had_errors;
731
      Lisp_Object frame;
Richard M. Stallman's avatar
Richard M. Stallman committed
732

733 734 735 736 737 738 739
      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))
	{
740
	  x_start_queuing_selection_requests ();
741 742

	  record_unwind_protect (queue_selection_requests_unwind,
743
				 Qnil);
744
	}
745

746
      if (x_window_to_frame (dpyinfo, window)) /* #### debug */
747
	error ("Attempt to transfer an INCR to ourself!");
748

749 750
      TRACE2 ("Start sending %d bytes incrementally (%s)",
	      bytes_remaining,  XGetAtomName (display, reply.property));
751 752
      wait_object = expect_property_change (display, window, reply.property,
					    PropertyDelete);
Richard M. Stallman's avatar
Richard M. Stallman committed
753

754 755
      TRACE1 ("Set %s to number of bytes to send",
	      XGetAtomName (display, reply.property));
756 757 758 759 760 761 762 763 764 765 766
      {
        /* 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
767
      XSelectInput (display, window, PropertyChangeMask);
768

Richard M. Stallman's avatar
Richard M. Stallman committed
769
      /* Tell 'em the INCR data is there...  */
770
      TRACE0 ("Send SelectionNotify event");
771
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
772
      XFlush (display);
773 774

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

777
      /* First, wait for the requester to ack by deleting the property.
Richard M. Stallman's avatar
Richard M. Stallman committed
778
	 This can run random lisp code (process handlers) or signal.  */
779
      if (! had_errors)
780 781 782 783 784
	{
	  TRACE1 ("Waiting for ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
	  wait_for_property_change (wait_object);
	}
785 786
      else
	unexpect_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
787

788
      TRACE0 ("Got ACK");
Richard M. Stallman's avatar
Richard M. Stallman committed
789 790
      while (bytes_remaining)
	{
791 792
          int i = ((bytes_remaining < max_bytes)
                   ? bytes_remaining
793
                   : max_bytes) / format_bytes;
794 795 796

	  BLOCK_INPUT;

797 798 799
	  wait_object
	    = expect_property_change (display, window, reply.property,
				      PropertyDelete);
800

801
	  TRACE1 ("Sending increment of %d elements", i);
802 803
	  TRACE1 ("Set %s to increment data",
		  XGetAtomName (display, reply.property));
804

Richard M. Stallman's avatar
Richard M. Stallman committed
805 806
	  /* Append the next chunk of data to the property.  */
	  XChangeProperty (display, window, reply.property, type, format,
807 808 809 810 811 812
			   PropModeAppend, data, i);
	  bytes_remaining -= i * format_bytes;
	  if (format == 32)
	    data += i * sizeof (long);
	  else
	    data += i * format_bytes;
813
	  XFlush (display);
814
	  had_errors = x_had_errors_p (display);
815
	  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
816

817 818 819
	  if (had_errors)
	    break;

820
	  /* Now wait for the requester to ack this chunk by deleting the
Juanma Barranquero's avatar
Juanma Barranquero committed
821
	     property.  This can run random lisp code or signal.  */
822 823
	  TRACE1 ("Waiting for increment ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
824
	  wait_for_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
825
	}
826

827 828
      /* Now write a zero-length chunk to the property to tell the
	 requester that we're done.  */
829
      BLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
830 831 832
      if (! waiting_for_other_props_on_window (display, window))
	XSelectInput (display, window, 0L);

833 834
      TRACE1 ("Set %s to a 0-length chunk to indicate EOF",
	      XGetAtomName (display, reply.property));
Richard M. Stallman's avatar
Richard M. Stallman committed
835 836
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, 0);
837
      TRACE0 ("Done sending incrementally");
Richard M. Stallman's avatar
Richard M. Stallman committed
838
    }
839

Richard M. Stallman's avatar
Richard M. Stallman committed
840
  /* rms, 2003-01-03: I think I have fixed this bug.  */
841 842 843 844 845 846
  /* 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.   */
847 848 849
  /* 2004-09-10: XSync and UNBLOCK so that possible protocol errors are
     delivered before uncatch errors.  */
  XSync (display, False);
850
  UNBLOCK_INPUT;
851 852 853 854 855

  /* 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;
856
  /* This calls x_uncatch_errors.  */
857
  unbind_to (count, Qnil);
858
  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
859 860 861 862 863
}

/* Handle a SelectionRequest event EVENT.
   This is called from keyboard.c when such an event is found in the queue.  */

864
static void
865
x_handle_selection_request (struct input_event *event)
Richard M. Stallman's avatar
Richard M. Stallman committed
866 867
{
  struct gcpro gcpro1, gcpro2, gcpro3;
868
  Lisp_Object local_selection_data;
Richard M. Stallman's avatar
Richard M. Stallman committed
869
  Lisp_Object selection_symbol;
870 871
  Lisp_Object target_symbol;
  Lisp_Object converted_selection;
Richard M. Stallman's avatar
Richard M. Stallman committed
872
  Time local_selection_time;
873
  Lisp_Object successful_p;
Richard M. Stallman's avatar
Richard M. Stallman committed
874
  int count;
875 876
  struct x_display_info *dpyinfo
    = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));
Richard M. Stallman's avatar
Richard M. Stallman committed
877

878 879 880
  TRACE2 ("x_handle_selection_request, from=0x%08lx time=%lu",
	  (unsigned long) SELECTION_EVENT_REQUESTOR (event),
	  (unsigned long) SELECTION_EVENT_TIME (event));
881

882 883 884 885 886
  local_selection_data = Qnil;
  target_symbol = Qnil;
  converted_selection = Qnil;
  successful_p = Qnil;

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

889
  selection_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
890 891 892 893 894 895 896 897 898 899 900 901 902
				       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)
903
    cons_to_long (XCAR (XCDR (XCDR (local_selection_data))));
Richard M. Stallman's avatar
Richard M. Stallman committed
904 905

  if (SELECTION_EVENT_TIME (event) != CurrentTime
906
      && local_selection_time > SELECTION_EVENT_TIME (event))
Richard M. Stallman's avatar
Richard M. Stallman committed
907 908 909 910 911 912 913 914 915
    {
      /* 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;
916
  count = SPECPDL_INDEX ();
917
  selection_request_dpyinfo = dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
918 919
  record_unwind_protect (x_selection_request_lisp_error, Qnil);

920
  target_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
921 922 923 924 925 926
				    SELECTION_EVENT_TARGET (event));

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