xselect.c 92.8 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 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 26 27 28 29 30 31 32

#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
33 34
#include "lisp.h"
#include "xterm.h"	/* for all of the X includes */
35 36
#include "dispextern.h"	/* frame.h seems to want this */
#include "frame.h"	/* Need this to get the X window of selected_frame */
37
#include "blockinput.h"
Kenichi Handa's avatar
Kenichi Handa committed
38
#include "buffer.h"
Andreas Schwab's avatar
Andreas Schwab committed
39
#include "process.h"
40
#include "termhooks.h"
41
#include "keyboard.h"
42 43

#include <X11/Xproto.h>
44

45 46 47 48 49 50
struct prop_location;

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


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


Richard M. Stallman's avatar
Richard M. Stallman committed
106 107 108 109 110 111
#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
112
Lisp_Object QCOMPOUND_TEXT;	/* This is a type of selection.  */
Kenichi Handa's avatar
Kenichi Handa committed
113
Lisp_Object QUTF8_STRING;	/* This is a type of selection.  */
Karl Heuer's avatar
Karl Heuer committed
114

115
Lisp_Object Qcompound_text_with_extensions;
116

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

122 123
static Lisp_Object Vx_lost_selection_functions;
static Lisp_Object Vx_sent_selection_functions;
124 125
static Lisp_Object Qforeign_selection;

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

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

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

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

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

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

165 166

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

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

static struct selection_event_queue *selection_queue;

178
/* Nonzero means queue up SELECTION_REQUEST_EVENT events.  */
179 180 181

static int x_queue_selection_requests;

182
/* Queue up an SELECTION_REQUEST_EVENT *EVENT, to be processed later.  */
183 184 185 186 187 188 189

static void
x_queue_event (event)
     struct input_event *event;
{
  struct selection_event_queue *queue_tmp;

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

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

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

214
/* Start queuing SELECTION_REQUEST_EVENT events.  */
215 216 217 218 219 220 221 222 223 224 225

static void
x_start_queuing_selection_requests ()
{
  if (x_queue_selection_requests)
    abort ();

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

226
/* Stop queuing SELECTION_REQUEST_EVENT events.  */
227 228 229 230 231 232 233 234 235 236 237 238 239

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

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

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

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

307 308
  if (! atom)
    return Qnil;
309

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

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

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

static void
x_own_selection (selection_name, selection_value)
     Lisp_Object selection_name, selection_value;
{
387
  struct frame *sf = SELECTED_FRAME ();
388 389
  Window selecting_window;
  Display *display;
390
  Time time = last_event_timestamp;
Richard M. Stallman's avatar
Richard M. Stallman committed
391
  Atom selection_atom;
392
  struct x_display_info *dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
393

394 395 396 397 398 399 400
  if (! FRAME_X_P (sf))
    return;

  selecting_window = FRAME_X_WINDOW (sf);
  display = FRAME_X_DISPLAY (sf);
  dpyinfo = FRAME_X_DISPLAY_INFO (sf);
  
401
  CHECK_SYMBOL (selection_name);
402
  selection_atom = symbol_to_x_atom (dpyinfo, display, selection_name);
Richard M. Stallman's avatar
Richard M. Stallman committed
403 404

  BLOCK_INPUT;
405
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
406
  XSetSelectionOwner (display, selection_atom, selecting_window, time);
407
  x_check_errors (display, "Can't set selection: %s");
408
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
409 410 411 412 413 414 415 416 417 418 419
  UNBLOCK_INPUT;

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

    selection_time = long_to_cons ((unsigned long) time);
    selection_data = Fcons (selection_name,
			    Fcons (selection_value,
420
				   Fcons (selection_time,
421
					  Fcons (selected_frame, Qnil))));
Richard M. Stallman's avatar
Richard M. Stallman committed
422 423 424 425 426 427 428 429 430 431
    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.  */
432
	for (rest = Vselection_alist; CONSP (rest); rest = XCDR (rest))
433
	  if (EQ (prev_value, Fcar (XCDR (rest))))
Richard M. Stallman's avatar
Richard M. Stallman committed
434
	    {
435
	      XSETCDR (rest, Fcdr (XCDR (rest)));
Richard M. Stallman's avatar
Richard M. Stallman committed
436 437 438 439 440 441 442 443 444
	      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
445 446
   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
447 448 449 450

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

static Lisp_Object
Kenichi Handa's avatar
Kenichi Handa committed
451
x_get_local_selection (selection_symbol, target_type, local_request)
Richard M. Stallman's avatar
Richard M. Stallman committed
452
     Lisp_Object selection_symbol, target_type;
Kenichi Handa's avatar
Kenichi Handa committed
453
     int local_request;
Richard M. Stallman's avatar
Richard M. Stallman committed
454 455 456 457 458 459 460 461 462 463 464 465 466
{
  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;
467
      value = XCAR (XCDR (XCDR (local_value)));
Richard M. Stallman's avatar
Richard M. Stallman committed
468 469 470 471 472 473 474
    }
#if 0
  else if (EQ (target_type, QDELETE))
    {
      handler_fn = Qnil;
      Fx_disown_selection_internal
	(selection_symbol,
475
	 XCAR (XCDR (XCDR (local_value))));
Richard M. Stallman's avatar
Richard M. Stallman committed
476 477 478 479 480 481
      value = QNULL;
    }
#endif

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

514
      CHECK_SYMBOL (target_type);
Richard M. Stallman's avatar
Richard M. Stallman committed
515
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
516 517 518
      /* gcpro is not needed here since nothing but HANDLER_FN
	 is live, and that ought to be a symbol.  */

519 520
      if (!NILP (handler_fn))
	value = call3 (handler_fn,
Kenichi Handa's avatar
Kenichi Handa committed
521
		       selection_symbol, (local_request ? Qnil : target_type),
522
		       XCAR (XCDR (local_value)));
523 524
      else
	value = Qnil;
Richard M. Stallman's avatar
Richard M. Stallman committed
525 526 527 528 529
      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
530

Richard M. Stallman's avatar
Richard M. Stallman committed
531 532
  check = value;
  if (CONSP (value)
533 534 535
      && SYMBOLP (XCAR (value)))
    type = XCAR (value),
    check = XCDR (value);
536

Richard M. Stallman's avatar
Richard M. Stallman committed
537 538 539
  if (STRINGP (check)
      || VECTORP (check)
      || SYMBOLP (check)
540
      || INTEGERP (check)
Richard M. Stallman's avatar
Richard M. Stallman committed
541 542
      || NILP (value))
    return value;
Richard M. Stallman's avatar
Richard M. Stallman committed
543
  /* Check for a value that cons_to_long could handle.  */
Richard M. Stallman's avatar
Richard M. Stallman committed
544
  else if (CONSP (check)
545 546
	   && INTEGERP (XCAR (check))
	   && (INTEGERP (XCDR (check))
Richard M. Stallman's avatar
Richard M. Stallman committed
547
	       ||
548 549 550
	       (CONSP (XCDR (check))
		&& INTEGERP (XCAR (XCDR (check)))
		&& NILP (XCDR (XCDR (check))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
551
    return value;
552 553 554

  signal_error ("Invalid data returned by selection-conversion function",
		list2 (handler_fn, value));
Richard M. Stallman's avatar
Richard M. Stallman committed
555 556 557 558
}

/* Subroutines of x_reply_selection_request.  */

559
/* Send a SelectionNotify event to the requestor with property=None,
Richard M. Stallman's avatar
Richard M. Stallman committed
560 561 562 563 564 565 566
   meaning we were unable to do what they wanted.  */

static void
x_decline_selection_request (event)
     struct input_event *event;
{
  XSelectionEvent reply;
567

Richard M. Stallman's avatar
Richard M. Stallman committed
568 569
  reply.type = SelectionNotify;
  reply.display = SELECTION_EVENT_DISPLAY (event);
570
  reply.requestor = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
571 572 573 574 575
  reply.selection = SELECTION_EVENT_SELECTION (event);
  reply.time = SELECTION_EVENT_TIME (event);
  reply.target = SELECTION_EVENT_TARGET (event);
  reply.property = None;

576 577
  /* 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
578
  BLOCK_INPUT;
579
  x_catch_errors (reply.display);
580
  XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
581
  XFlush (reply.display);
582
  x_uncatch_errors ();
Richard M. Stallman's avatar
Richard M. Stallman committed
583 584 585 586 587 588 589
  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;

590 591 592 593
/* Display info in x_selection_request.  */

static struct x_display_info *selection_request_dpyinfo;

Richard M. Stallman's avatar
Richard M. Stallman committed
594
/* Used as an unwind-protect clause so that, if a selection-converter signals
595
   an error, we tell the requester that we were unable to do what they wanted
Richard M. Stallman's avatar
Richard M. Stallman committed
596 597 598 599 600 601
   before we throw to top-level or go into the debugger or whatever.  */

static Lisp_Object
x_selection_request_lisp_error (ignore)
     Lisp_Object ignore;
{
602 603
  if (x_selection_current_request != 0
      && selection_request_dpyinfo->display)
Richard M. Stallman's avatar
Richard M. Stallman committed
604 605 606
    x_decline_selection_request (x_selection_current_request);
  return Qnil;
}
607 608 609 610 611 612 613 614

static Lisp_Object
x_catch_errors_unwind (dummy)
     Lisp_Object dummy;
{
  BLOCK_INPUT;
  x_uncatch_errors ();
  UNBLOCK_INPUT;
615
  return Qnil;
616
}
Richard M. Stallman's avatar
Richard M. Stallman committed
617

618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647

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

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

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

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

static int prop_location_identifier;

static Lisp_Object property_change_reply;

static struct prop_location *property_change_reply_object;

static struct prop_location *property_change_wait_list;
648 649

static Lisp_Object
650 651
queue_selection_requests_unwind (tem)
     Lisp_Object tem;
652
{
653
  x_stop_queuing_selection_requests ();
654
  return Qnil;
655 656 657 658 659 660 661 662 663 664 665 666 667
}

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

static Lisp_Object
some_frame_on_display (dpyinfo)
     struct x_display_info *dpyinfo;
{
  Lisp_Object list, frame;

  FOR_EACH_FRAME (list, frame)
    {
668 669
      if (FRAME_X_P (XFRAME (frame))
          && FRAME_X_DISPLAY_INFO (XFRAME (frame)) == dpyinfo)
670 671 672 673 674
	return frame;
    }

  return Qnil;
}
675

Richard M. Stallman's avatar
Richard M. Stallman committed
676 677 678 679 680
/* 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.  */

681
#ifdef TRACE_SELECTION
682
static int x_reply_selection_request_cnt;
683 684
#endif  /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
685 686 687 688 689 690 691 692 693
static void
x_reply_selection_request (event, format, data, size, type)
     struct input_event *event;
     int format, size;
     unsigned char *data;
     Atom type;
{
  XSelectionEvent reply;
  Display *display = SELECTION_EVENT_DISPLAY (event);
694
  Window window = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
695 696 697
  int bytes_remaining;
  int format_bytes = format/8;
  int max_bytes = SELECTION_QUANTUM (display);
698
  struct x_display_info *dpyinfo = x_display_info_for_display (display);
699
  int count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
700 701 702 703 704 705

  if (max_bytes > MAX_SELECTION_QUANTUM)
    max_bytes = MAX_SELECTION_QUANTUM;

  reply.type = SelectionNotify;
  reply.display = display;
706
  reply.requestor = window;
Richard M. Stallman's avatar
Richard M. Stallman committed
707 708 709 710 711 712 713
  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;

714
  BLOCK_INPUT;
715 716 717 718
  /* 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);
719
  x_catch_errors (display);
Richard M. Stallman's avatar
Richard M. Stallman committed
720

721 722 723 724
#ifdef TRACE_SELECTION
  {
    char *sel = XGetAtomName (display, reply.selection);
    char *tgt = XGetAtomName (display, reply.target);
725
    TRACE3 ("%s, target %s (%d)", sel, tgt, ++x_reply_selection_request_cnt);
726 727 728 729 730
    if (sel) XFree (sel);
    if (tgt) XFree (tgt);
  }
#endif /* TRACE_SELECTION */

Richard M. Stallman's avatar
Richard M. Stallman committed
731 732 733 734 735 736 737
  /* 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.  */
738
      TRACE1 ("Sending all %d bytes", bytes_remaining);
Richard M. Stallman's avatar
Richard M. Stallman committed
739 740 741
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, size);
      /* At this point, the selection was successfully stored; ack it.  */
742
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
Richard M. Stallman's avatar
Richard M. Stallman committed
743 744 745 746
    }
  else
    {
      /* Send an INCR selection.  */
747
      struct prop_location *wait_object;
748
      int had_errors;
749
      Lisp_Object frame;
Richard M. Stallman's avatar
Richard M. Stallman committed
750

751 752 753 754 755 756 757
      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))
	{
758
	  x_start_queuing_selection_requests ();
759 760

	  record_unwind_protect (queue_selection_requests_unwind,
761
				 Qnil);
762
	}
763

764
      if (x_window_to_frame (dpyinfo, window)) /* #### debug */
765
	error ("Attempt to transfer an INCR to ourself!");
766

767 768
      TRACE2 ("Start sending %d bytes incrementally (%s)",
	      bytes_remaining,  XGetAtomName (display, reply.property));
769 770
      wait_object = expect_property_change (display, window, reply.property,
					    PropertyDelete);
Richard M. Stallman's avatar
Richard M. Stallman committed
771

772 773
      TRACE1 ("Set %s to number of bytes to send",
	      XGetAtomName (display, reply.property));
774 775 776 777 778 779 780 781 782 783 784
      {
        /* 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
785
      XSelectInput (display, window, PropertyChangeMask);
786

Richard M. Stallman's avatar
Richard M. Stallman committed
787
      /* Tell 'em the INCR data is there...  */
788
      TRACE0 ("Send SelectionNotify event");
789
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);
790
      XFlush (display);
791 792

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

795
      /* First, wait for the requester to ack by deleting the property.
Richard M. Stallman's avatar
Richard M. Stallman committed
796
	 This can run random lisp code (process handlers) or signal.  */
797
      if (! had_errors)
798 799 800 801 802
	{
	  TRACE1 ("Waiting for ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
	  wait_for_property_change (wait_object);
	}
803 804
      else
	unexpect_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
805

806
      TRACE0 ("Got ACK");
Richard M. Stallman's avatar
Richard M. Stallman committed
807 808
      while (bytes_remaining)
	{
809 810
          int i = ((bytes_remaining < max_bytes)
                   ? bytes_remaining
811
                   : max_bytes) / format_bytes;
812 813 814

	  BLOCK_INPUT;

815 816 817
	  wait_object
	    = expect_property_change (display, window, reply.property,
				      PropertyDelete);
818

819
	  TRACE1 ("Sending increment of %d elements", i);
820 821
	  TRACE1 ("Set %s to increment data",
		  XGetAtomName (display, reply.property));
822

Richard M. Stallman's avatar
Richard M. Stallman committed
823 824
	  /* Append the next chunk of data to the property.  */
	  XChangeProperty (display, window, reply.property, type, format,
825 826 827 828 829 830
			   PropModeAppend, data, i);
	  bytes_remaining -= i * format_bytes;
	  if (format == 32)
	    data += i * sizeof (long);
	  else
	    data += i * format_bytes;
831
	  XFlush (display);
832
	  had_errors = x_had_errors_p (display);
833
	  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
834

835 836 837
	  if (had_errors)
	    break;

838
	  /* Now wait for the requester to ack this chunk by deleting the
Juanma Barranquero's avatar
Juanma Barranquero committed
839
	     property.  This can run random lisp code or signal.  */
840 841
	  TRACE1 ("Waiting for increment ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
842
	  wait_for_property_change (wait_object);
Richard M. Stallman's avatar
Richard M. Stallman committed
843
	}
844

845 846
      /* Now write a zero-length chunk to the property to tell the
	 requester that we're done.  */
847
      BLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
848 849 850
      if (! waiting_for_other_props_on_window (display, window))
	XSelectInput (display, window, 0L);

851 852
      TRACE1 ("Set %s to a 0-length chunk to indicate EOF",
	      XGetAtomName (display, reply.property));
Richard M. Stallman's avatar
Richard M. Stallman committed
853 854
      XChangeProperty (display, window, reply.property, type, format,
		       PropModeReplace, data, 0);
855
      TRACE0 ("Done sending incrementally");
Richard M. Stallman's avatar
Richard M. Stallman committed
856
    }
857

Richard M. Stallman's avatar
Richard M. Stallman committed
858
  /* rms, 2003-01-03: I think I have fixed this bug.  */
859 860 861 862 863 864
  /* 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.   */
865 866 867
  /* 2004-09-10: XSync and UNBLOCK so that possible protocol errors are
     delivered before uncatch errors.  */
  XSync (display, False);
868
  UNBLOCK_INPUT;
869 870 871 872 873

  /* 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;
874
  /* This calls x_uncatch_errors.  */
875
  unbind_to (count, Qnil);
876
  UNBLOCK_INPUT;
Richard M. Stallman's avatar
Richard M. Stallman committed
877 878 879 880 881
}

/* Handle a SelectionRequest event EVENT.
   This is called from keyboard.c when such an event is found in the queue.  */

882
static void
Richard M. Stallman's avatar
Richard M. Stallman committed
883 884 885 886
x_handle_selection_request (event)
     struct input_event *event;
{
  struct gcpro gcpro1, gcpro2, gcpro3;
887
  Lisp_Object local_selection_data;
Richard M. Stallman's avatar
Richard M. Stallman committed
888
  Lisp_Object selection_symbol;
889 890
  Lisp_Object target_symbol;
  Lisp_Object converted_selection;
Richard M. Stallman's avatar
Richard M. Stallman committed
891
  Time local_selection_time;
892
  Lisp_Object successful_p;
Richard M. Stallman's avatar
Richard M. Stallman committed
893
  int count;
894 895
  struct x_display_info *dpyinfo
    = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));
Richard M. Stallman's avatar
Richard M. Stallman committed
896

897 898 899
  TRACE2 ("x_handle_selection_request, from=0x%08lx time=%lu",
	  (unsigned long) SELECTION_EVENT_REQUESTOR (event),
	  (unsigned long) SELECTION_EVENT_TIME (event));
900

901 902 903 904 905
  local_selection_data = Qnil;
  target_symbol = Qnil;
  converted_selection = Qnil;
  successful_p = Qnil;

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

908
  selection_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
909 910 911 912 913 914 915 916 917 918 919 920 921
				       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)
922
    cons_to_long (XCAR (XCDR (XCDR (local_selection_data))));
Richard M. Stallman's avatar
Richard M. Stallman committed
923 924

  if (SELECTION_EVENT_TIME (event) != CurrentTime
925
      && local_selection_time > SELECTION_EVENT_TIME (event))
Richard M. Stallman's avatar
Richard M. Stallman committed
926 927 928 929 930 931 932 933 934
    {
      /* 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;
935
  count = SPECPDL_INDEX ();
936
  selection_request_dpyinfo = dpyinfo;
Richard M. Stallman's avatar
Richard M. Stallman committed
937 938
  record_unwind_protect (x_selection_request_lisp_error, Qnil);

939
  target_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
Richard M. Stallman's avatar
Richard M. Stallman committed
940 941 942 943 944 945
				    SELECTION_EVENT_TARGET (event));

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

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

Richard M. Stallman's avatar
Richard M. Stallman committed
949
  converted_selection
Kenichi Handa's avatar
Kenichi Handa committed
950
    = x_get_local_selection (selection_symbol, target_symbol, 0);
951

Richard M. Stallman's avatar
Richard M. Stallman committed
952 953 954 955 956 957
  if (! NILP (converted_selection))
    {
      unsigned char *data;
      unsigned int size;
      int format;
      Atom type;
958 959
      int nofree;

960 961 962 963 964 965
      if (CONSP (converted_selection) && NILP (XCDR (converted_selection)))
        {
          x_decline_selection_request (event);
          goto DONE2;
        }

966 967
      lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event),
				   converted_selection,
Richard M. Stallman's avatar