xselect.c 93 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 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 48 49 50 51
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
52
static Lisp_Object x_get_local_selection P_ ((Lisp_Object, Lisp_Object, int));
53 54 55 56
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 *));
57
static Lisp_Object x_catch_errors_unwind P_ ((Lisp_Object));
58 59 60 61 62 63 64 65
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 *));
66 67 68
static Lisp_Object x_get_foreign_selection P_ ((Lisp_Object,
                                                Lisp_Object,
                                                Lisp_Object));
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 96
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)
97 98
#define TRACE3(fmt, a0, a1, a2) \
  fprintf (stderr, "%d: " fmt "\n", getpid (), a0, a1, a2)
99 100 101 102
#else
#define TRACE0(fmt)		(void) 0
#define TRACE1(fmt, a0)		(void) 0
#define TRACE2(fmt, a0, a1)	(void) 0
103
#define TRACE3(fmt, a0, a1)	(void) 0
104 105 106
#endif


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

116
Lisp_Object Qcompound_text_with_extensions;
117

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

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

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

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

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

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

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

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

166 167

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

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

static struct selection_event_queue *selection_queue;

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

static int x_queue_selection_requests;

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

static void
x_queue_event (event)
     struct input_event *event;
{
  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 195 196
  for (queue_tmp = selection_queue; queue_tmp; queue_tmp = queue_tmp->next)
    {
      if (!bcmp (&queue_tmp->event, event, sizeof (*event)))
	{
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 218 219 220 221 222 223 224 225 226

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);
}

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

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

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

308 309
  if (! atom)
    return Qnil;
310

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

static struct x_display_info *selection_request_dpyinfo;

Richard M. Stallman's avatar
Richard M. Stallman committed
595
/* Used as an unwind-protect clause so that, if a selection-converter signals
596
   an error, we tell the requester that we were unable to do what they wanted
Richard M. Stallman's avatar
Richard M. Stallman committed
597 598 599 600 601 602
   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;
{
603 604
  if (x_selection_current_request != 0
      && selection_request_dpyinfo->display)
Richard M. Stallman's avatar
Richard M. Stallman committed
605 606 607
    x_decline_selection_request (x_selection_current_request);
  return Qnil;
}
608 609 610 611 612 613 614 615

static Lisp_Object
x_catch_errors_unwind (dummy)
     Lisp_Object dummy;
{
  BLOCK_INPUT;
  x_uncatch_errors ();
  UNBLOCK_INPUT;
616
  return Qnil;
617
}
Richard M. Stallman's avatar
Richard M. Stallman committed
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 648

/* 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;
649 650

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

/* 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)
    {
669 670
      if (FRAME_X_P (XFRAME (frame))
          && FRAME_X_DISPLAY_INFO (XFRAME (frame)) == dpyinfo)
671 672 673 674 675
	return frame;
    }

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

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

Richard M. Stallman's avatar
Richard M. Stallman committed
686 687 688 689 690 691 692 693 694
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);
695
  Window window = SELECTION_EVENT_REQUESTOR (event);
Richard M. Stallman's avatar
Richard M. Stallman committed
696 697 698
  int bytes_remaining;
  int format_bytes = format/8;
  int max_bytes = SELECTION_QUANTUM (display);
699
  struct x_display_info *dpyinfo = x_display_info_for_display (display);
700
  int count = SPECPDL_INDEX ();
Richard M. Stallman's avatar
Richard M. Stallman committed
701 702 703 704 705 706

  if (max_bytes > MAX_SELECTION_QUANTUM)
    max_bytes = MAX_SELECTION_QUANTUM;

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

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

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

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

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

	  record_unwind_protect (queue_selection_requests_unwind,
762
				 Qnil);
763
	}
764

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

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

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

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

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

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

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

	  BLOCK_INPUT;

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

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

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

836 837 838
	  if (had_errors)
	    break;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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