comparison src/xselect.c @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

/* X Selection processing for Emacs.
   Copyright (C) 1993, 1994, 1995, 1996, 1997, 2000, 2001
   Free Software Foundation.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

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
along with GNU Emacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */


/* Rewritten by jwz */

#include <config.h>
#include "lisp.h"
#include "xterm.h"	/* for all of the X includes */
#include "dispextern.h"	/* frame.h seems to want this */
#include "frame.h"	/* Need this to get the X window of selected_frame */
#include "blockinput.h"
#include "buffer.h"
#include "charset.h"
#include "coding.h"
#include "process.h"
#include "composite.h"

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

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 *));
static Lisp_Object x_get_foreign_selection P_ ((Lisp_Object, Lisp_Object));
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,

  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)
#else
#define TRACE0(fmt)		(void) 0
#define TRACE1(fmt, a0)		(void) 0
#define TRACE2(fmt, a0, a1)	(void) 0
#endif


#define CUT_BUFFER_SUPPORT

#ifdef CUT_BUFFER_SUPPORT
Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
  QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
#endif

static Lisp_Object Vx_lost_selection_hooks;
static Lisp_Object Vx_sent_selection_hooks;
/* Coding system for communicating with other X clients via cutbuffer,
   selection, and clipboard.  */
static Lisp_Object Vselection_coding_system;

/* Coding system for the next communicating with other X clients.  */
static Lisp_Object Vnext_selection_coding_system;

/* 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
   emacs to use incremental selection transfers when the selection is

static Lisp_Object Vselection_converter_alist;

/* If the selection owner takes too long to reply to a selection request,
   we give up on it.  This is in milliseconds (0 = no timeout.)  */
static EMACS_INT x_selection_timeout;

/* Utility functions */

static void lisp_data_to_selection_data ();
static Lisp_Object selection_data_to_lisp_data ();
static Lisp_Object x_get_window_property_as_lisp_data ();

/* This converts a Lisp symbol to a server Atom, avoiding a server
   roundtrip whenever possible.  */

static Atom

      count = SPECPDL_INDEX ();
      specbind (Qinhibit_quit, Qt);

      CHECK_SYMBOL (target_type);
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
      if (!NILP (handler_fn))
	value = call3 (handler_fn,
		       selection_symbol, (local_request ? Qnil : target_type),
		       XCAR (XCDR (local_value)));
      else

static struct prop_location *property_change_reply_object;

static struct prop_location *property_change_wait_list;

static Lisp_Object
queue_selection_requests_unwind (frame)
     Lisp_Object frame;
{
  FRAME_PTR f = XFRAME (frame);

  if (! NILP (frame))
    x_stop_queuing_selection_requests (FRAME_X_DISPLAY (f));
  return Qnil;
}

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

  /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
  BLOCK_INPUT;
  count = x_catch_errors (display);

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

      /* 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))
	{
	  x_start_queuing_selection_requests (display);

	  record_unwind_protect (queue_selection_requests_unwind,
				 frame);
	}

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

      wait_object = expect_property_change (display, window, reply.property,
					    PropertyDelete);

      TRACE1 ("Set %s to number of bytes to send",
	      XGetAtomName (display, reply.property));
      XChangeProperty (display, window, reply.property, dpyinfo->Xatom_INCR,
		       32, PropModeReplace,
		       (unsigned char *) &bytes_remaining, 1);
      XSelectInput (display, window, PropertyChangeMask);

      /* Tell 'em the INCR data is there...  */
      TRACE0 ("Send SelectionNotify event");
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);

	{
	  TRACE1 ("Waiting for ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
	  wait_for_property_change (wait_object);
	}

      TRACE0 ("Got ACK");
      while (bytes_remaining)
	{
	  int i = ((bytes_remaining < max_bytes)
		   ? bytes_remaining
		   : max_bytes);

	  BLOCK_INPUT;

	  wait_object
	    = expect_property_change (display, window, reply.property,

     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.   */
  XFlush (display);
  x_uncatch_errors (display, count);
  UNBLOCK_INPUT;
}

/* Handle a SelectionRequest event EVENT.
   This is called from keyboard.c when such an event is found in the queue.  */

void
x_handle_selection_request (event)
     struct input_event *event;
{
  struct gcpro gcpro1, gcpro2, gcpro3;
  Lisp_Object local_selection_data;

  Lisp_Object successful_p;
  int count;
  struct x_display_info *dpyinfo
    = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));

  local_selection_data = Qnil;
  target_symbol = Qnil;
  converted_selection = Qnil;
  successful_p = Qnil;

    }
  unbind_to (count, Qnil);

 DONE:

  UNGCPRO;

  /* Let random lisp code notice that the selection has been asked for.  */
  {
    Lisp_Object rest;
    rest = Vx_sent_selection_hooks;
    if (!EQ (rest, Qunbound))
      for (; CONSP (rest); rest = Fcdr (rest))
	call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
  }
}

/* Handle a SelectionClear event EVENT, which indicates that some
   client cleared out our previously asserted selection.
   This is called from keyboard.c when such an event is found in the queue.  */

void
x_handle_selection_clear (event)
     struct input_event *event;
{
  Display *display = SELECTION_EVENT_DISPLAY (event);
  Atom selection = SELECTION_EVENT_SELECTION (event);

  Lisp_Object selection_symbol, local_selection_data;
  Time local_selection_time;
  struct x_display_info *dpyinfo = x_display_info_for_display (display);
  struct x_display_info *t_dpyinfo;

  /* If the new selection owner is also Emacs,
     don't clear the new selection.  */
  BLOCK_INPUT;
  /* Check each display on the same terminal,

  /* Let random lisp code notice that the selection has been stolen.  */

  {
    Lisp_Object rest;
    rest = Vx_lost_selection_hooks;
    if (!EQ (rest, Qunbound))
      {
	for (; CONSP (rest); rest = Fcdr (rest))
	  call1 (Fcar (rest), selection_symbol);
	prepare_menu_bars ();
	redisplay_preserve_echo_area (20);
      }
  }
}

/* Clear all selections that were made from frame F.
   We do this when about to delete a frame.  */

void
x_clear_frame_selections (f)

	 && EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (Vselection_alist)))))))
    {
      /* Let random Lisp code notice that the selection has been stolen.  */
      Lisp_Object hooks, selection_symbol;

      hooks = Vx_lost_selection_hooks;
      selection_symbol = Fcar (Fcar (Vselection_alist));

      if (!EQ (hooks, Qunbound))
	{
	  for (; CONSP (hooks); hooks = Fcdr (hooks))

    if (EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (XCDR (rest))))))))
      {
	/* Let random Lisp code notice that the selection has been stolen.  */
	Lisp_Object hooks, selection_symbol;

	hooks = Vx_lost_selection_hooks;
	selection_symbol = Fcar (Fcar (XCDR (rest)));

	if (!EQ (hooks, Qunbound))
	  {
	    for (; CONSP (hooks); hooks = Fcdr (hooks))

}

/* Remove the property change expectation element for IDENTIFIER.  */

static Lisp_Object
wait_for_property_change_unwind (identifierval)
     Lisp_Object identifierval;
{
  unexpect_property_change ((struct prop_location *)
			    (XFASTINT (XCAR (identifierval)) << 16
			     | XFASTINT (XCDR (identifierval))));
  return Qnil;
}

/* Actually wait for a property change.
   IDENTIFIER should be the value that expect_property_change returned.  */

wait_for_property_change (location)
     struct prop_location *location;
{
  int secs, usecs;
  int count = SPECPDL_INDEX ();
  Lisp_Object tem;

  tem = Fcons (Qnil, Qnil);
  XSETCARFASTINT (tem, (EMACS_UINT)location >> 16);
  XSETCDRFASTINT (tem, (EMACS_UINT)location & 0xffff);

  /* Make sure to do unexpect_property_change if we quit or err.  */
  record_unwind_protect (wait_for_property_change_unwind, tem);

  XSETCAR (property_change_reply, Qnil);

  property_change_reply_object = location;
  /* If the event we are waiting for arrives beyond here, it will set
     property_change_reply, because property_change_reply_object says so.  */
  if (! location->arrived)
    {
      secs = x_selection_timeout / 1000;
      usecs = (x_selection_timeout % 1000) * 1000;
      TRACE2 ("  Waiting %d secs, %d usecs", secs, usecs);
      wait_reading_process_input (secs, usecs, property_change_reply, 0);

      if (NILP (XCAR (property_change_reply)))
	{
	  TRACE0 ("  Timed out");
	  error ("Timed out waiting for property-notify event");

{
  struct prop_location *prev = 0, *rest = property_change_wait_list;

  while (rest)
    {
      if (rest->property == event->atom
	  && rest->window == event->window
	  && rest->display == event->display
	  && rest->desired_state == event->state)
	{
	  TRACE2 ("Expected %s of property %s",

	  /* If this is the one wait_for_property_change is waiting for,
	     tell it to wake up.  */
	  if (rest == property_change_reply_object)
	    XSETCAR (property_change_reply, Qt);

	  if (prev)
	    prev->next = rest->next;
	  else
	    property_change_wait_list = rest->next;
	  xfree (rest);
	  return;
	}

      prev = rest;
      rest = rest->next;

/* Do protocol to read selection-data from the server.
   Converts this to Lisp data and returns it.  */

static Lisp_Object
x_get_foreign_selection (selection_symbol, target_type)
     Lisp_Object selection_symbol, target_type;
{
  struct frame *sf = SELECTED_FRAME ();
  Window requestor_window = FRAME_X_WINDOW (sf);
  Display *display = FRAME_X_DISPLAY (sf);
  struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (sf);

  if (CONSP (target_type))
    type_atom = symbol_to_x_atom (dpyinfo, display, XCAR (target_type));
  else
    type_atom = symbol_to_x_atom (dpyinfo, display, target_type);

  BLOCK_INPUT;

  count = x_catch_errors (display);

  TRACE2 ("Get selection %s, type %s",

  /* 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))
    {
      x_start_queuing_selection_requests (display);

      record_unwind_protect (queue_selection_requests_unwind,
			     frame);
    }
  UNBLOCK_INPUT;

  /* This allows quits.  Also, don't wait forever.  */
  secs = x_selection_timeout / 1000;
  usecs = (x_selection_timeout % 1000) * 1000;
  TRACE1 ("  Start waiting %d secs for SelectionNotify", secs);
  wait_reading_process_input (secs, usecs, reading_selection_reply, 0);
  TRACE1 ("  Got event = %d", !NILP (XCAR (reading_selection_reply)));

  BLOCK_INPUT;
  x_check_errors (display, "Cannot get selection: %s");
  x_uncatch_errors (display, count);

      /* If this doesn't return Success at this point, it means that
	 some clod deleted the selection while we were in the midst of
	 reading it.  Deal with that, I guess.... */
      if (result != Success)
	break;
      *actual_size_ret *= *actual_format_ret / 8;
      bcopy (tmp_data, (*data_ret) + offset, *actual_size_ret);
      offset += *actual_size_ret;

      /* This was allocated by Xlib, so use XFree.  */
      XFree ((char *) tmp_data);
    }

     We are done when the sender places a property of length 0.
   */
  BLOCK_INPUT;
  XSelectInput (display, window, STANDARD_EVENT_SET | PropertyChangeMask);
  TRACE1 ("  Delete property %s",
	  XSYMBOL (x_atom_to_symbol (display, property))->name->data);
  XDeleteProperty (display, window, property);
  TRACE1 ("  Expect new value of property %s",
	  XSYMBOL (x_atom_to_symbol (display, property))->name->data);
  wait_object = expect_property_change (display, window, property,
					PropertyNewValue);
  XFlush (display);
  UNBLOCK_INPUT;

	{
	  TRACE0 ("Done reading incrementally");

	  if (! waiting_for_other_props_on_window (display, window))
	    XSelectInput (display, window, STANDARD_EVENT_SET);
	  unexpect_property_change (wait_object);
	  /* Use xfree, not XFree, because x_get_window_property
	     calls xmalloc itself.  */
	  if (tmp_data) xfree (tmp_data);
	  break;
	}

   of format 16 if every element in the vector is an integer, and is assumed
   to be of format 32 if any element is a cons of two integers.

   When converting an object to C, it may be of the form (SYMBOL . <data>)
   where SYMBOL is what we should claim that the type is.  Format and
   representation are as above.  */



static Lisp_Object
selection_data_to_lisp_data (display, data, size, type, format)

    return QNULL;

  /* Convert any 8-bit data to a string, for compactness.  */
  else if (format == 8)
    {
      Lisp_Object str;
      int require_encoding = 0;

      if (
#if 1
	  1
#else
	  ! NILP (buffer_defaults.enable_multibyte_characters)
#endif
	  )
	{
	  /* If TYPE is `TEXT' or `COMPOUND_TEXT', we should decode
	     DATA to Emacs internal format because DATA may be encoded
	     in compound text format.  In addtion, if TYPE is `STRING'
	     and DATA contains any 8-bit Latin-1 code, we should also
	     decode it.  */
	  if (type == dpyinfo->Xatom_TEXT
	      || type == dpyinfo->Xatom_COMPOUND_TEXT)
	    require_encoding = 1;
	  else if (type == XA_STRING)
	    {
	      int i;
	      for (i = 0; i < size; i++)
		{
		  if (data[i] >= 0x80)
		    {
		      require_encoding = 1;
		      break;
		    }
		}
	    }
	}
      if (!require_encoding)
	{
	  str = make_unibyte_string ((char *) data, size);
	  Vlast_coding_system_used = Qraw_text;
	}
      else
	{
	  int bufsize;
	  unsigned char *buf;
	  struct coding_system coding;

	  if (NILP (Vnext_selection_coding_system))
	    Vnext_selection_coding_system = Vselection_coding_system;
	  setup_coding_system
	    (Fcheck_coding_system(Vnext_selection_coding_system), &coding);
	  coding.src_multibyte = 0;
	  coding.dst_multibyte = 1;
	  Vnext_selection_coding_system = Qnil;
          coding.mode |= CODING_MODE_LAST_BLOCK;
	  /* We explicitely disable composition handling because
	     selection data should not contain any composition
	     sequence.  */
	  coding.composing = COMPOSITION_DISABLED;
	  bufsize = decoding_buffer_size (&coding, size);
	  buf = (unsigned char *) xmalloc (bufsize);
	  decode_coding (&coding, data, buf, size, bufsize);
	  str = make_string_from_bytes ((char *) buf,
					coding.produced_char, coding.produced);
	  xfree (buf);

	  if (SYMBOLP (coding.post_read_conversion)
	      && !NILP (Ffboundp (coding.post_read_conversion)))
	    str = run_pre_post_conversion_on_str (str, &coding, 0);
	  Vlast_coding_system_used = coding.symbol;
	}
      compose_chars_in_text (0, SCHARS (str), str);
      return str;
    }
  /* Convert a single atom to a Lisp_Symbol.  Convert a set of atoms to
     a vector of symbols.
   */
  else if (type == XA_ATOM)
    {
      int i;
      if (size == sizeof (Atom))
	return x_atom_to_symbol (display, *((Atom *) data));
      else
	{
	  Lisp_Object v = Fmake_vector (make_number (size / sizeof (Atom)),
					make_number (0));
	  for (i = 0; i < size / sizeof (Atom); i++)
	    Faset (v, make_number (i),
		   x_atom_to_symbol (display, ((Atom *) data) [i]));
	  return v;
	}
    }

  /* Convert a single 16 or small 32 bit number to a Lisp_Int.
     If the number is > 16 bits, convert it to a cons of integers,
     16 bits in each half.
   */
  else if (format == 32 && size == sizeof (long))
    return long_to_cons (((unsigned long *) data) [0]);
  else if (format == 16 && size == sizeof (short))
    return make_number ((int) (((unsigned short *) data) [0]));

  /* Convert any other kind of data to a vector of numbers, represented
     as above (as an integer, or a cons of two 16 bit integers.)

    {
      int i;
      Lisp_Object v = Fmake_vector (make_number (size / 4), make_number (0));
      for (i = 0; i < size / 4; i++)
	{
	  unsigned long j = ((unsigned long *) data) [i];
	  Faset (v, make_number (i), long_to_cons (j));
	}
      return v;
    }
}

      *data_ret = 0;
      type = QNULL;
    }
  else if (STRINGP (obj))
    {
      xassert (! STRING_MULTIBYTE (obj));
      if (NILP (type))
	type = QSTRING;
      *format_ret = 8;
      *size_ret = SBYTES (obj);
      *data_ret = SDATA (obj);

	}
#endif
      else
	/* This vector is an INTEGER set, or something like it */
	{
	  *size_ret = XVECTOR (obj)->size;
	  if (NILP (type)) type = QINTEGER;
	  *format_ret = 16;
	  for (i = 0; i < *size_ret; i++)
	    if (CONSP (XVECTOR (obj)->contents [i]))

	      Fsignal (Qerror, /* Qselection_error */
		       Fcons (build_string
	("elements of selection vector must be integers or conses of integers"),
			      Fcons (obj, Qnil)));

	  *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
	  for (i = 0; i < *size_ret; i++)
	    if (*format_ret == 32)
	      (*((unsigned long **) data_ret)) [i]
		= cons_to_long (XVECTOR (obj)->contents [i]);
	    else

		= (unsigned short) cons_to_long (XVECTOR (obj)->contents [i]);
	}
    }
  else
    Fsignal (Qerror, /* Qselection_error */
	     Fcons (build_string ("unrecognised selection data"),
		    Fcons (obj, Qnil)));

  *type_ret = symbol_to_x_atom (dpyinfo, display, type);
}

     (selection_name, selection_value)
     Lisp_Object selection_name, selection_value;
{
  check_x ();
  CHECK_SYMBOL (selection_name);
  if (NILP (selection_value)) error ("selection-value may not be nil");
  x_own_selection (selection_name, selection_value);
  return selection_value;
}


/* Request the selection value from the owner.  If we are the owner,
   simply return our selection value.  If we are not the owner, this
   will block until all of the data has arrived.  */

DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
       Sx_get_selection_internal, 2, 2, 0,
       doc: /* Return text selected from some X window.
SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
\(Those are literal upper-case symbol names, since that's what X expects.)
TYPE is the type of data desired, typically `STRING'.  */)
     (selection_symbol, target_type)
     Lisp_Object selection_symbol, target_type;
{
  Lisp_Object val = Qnil;
  struct gcpro gcpro1, gcpro2;
  GCPRO2 (target_type, val); /* we store newly consed data into these */
  check_x ();

  val = x_get_local_selection (selection_symbol, target_type, 1);

  if (NILP (val))
    {
      val = x_get_foreign_selection (selection_symbol, target_type);
      goto DONE;
    }

  if (CONSP (val)
      && SYMBOLP (XCAR (val)))

     Lisp_Object selection;
     Lisp_Object time;
{
  Time timestamp;
  Atom selection_atom;
  struct selection_input_event event;
  Display *display;
  struct x_display_info *dpyinfo;
  struct frame *sf = SELECTED_FRAME ();

  check_x ();

  /* It doesn't seem to be guaranteed that a SelectionClear event will be
     generated for a window which owns the selection when that window sets
     the selection owner to None.  The NCD server does, the MIT Sun4 server
     doesn't.  So we synthesize one; this means we might get two, but
     that's ok, because the second one won't have any effect.  */
  SELECTION_EVENT_DISPLAY (&event) = display;
  SELECTION_EVENT_SELECTION (&event) = selection_atom;
  SELECTION_EVENT_TIME (&event) = timestamp;
  x_handle_selection_clear ((struct input_event *) &event);

  return Qt;
}

/* Get rid of all the selections in buffer BUFFER.

    Fsignal (Qerror,
	     Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
		    Fcons (x_atom_to_symbol (display, type),
			   Fcons (make_number (format), Qnil))));

  ret = (bytes ? make_string ((char *) data, bytes) : Qnil);
  /* Use xfree, not XFree, because x_get_window_property
     calls xmalloc itself.  */
  xfree (data);
  return ret;
}

  return n;
}

#endif

void
syms_of_xselect ()
{
  defsubr (&Sx_get_selection_internal);
  defsubr (&Sx_own_selection_internal);

#ifdef CUT_BUFFER_SUPPORT
  defsubr (&Sx_get_cut_buffer_internal);
  defsubr (&Sx_store_cut_buffer_internal);
  defsubr (&Sx_rotate_cut_buffers_internal);
#endif

  reading_selection_reply = Fcons (Qnil, Qnil);
  staticpro (&reading_selection_reply);
  reading_selection_window = 0;
  reading_which_selection = 0;

A return value which is the symbol `NULL'
means that a side-effect was executed,
and there is no meaningful selection value.  */);
  Vselection_converter_alist = Qnil;

  DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks,
	       doc: /* A list of functions to be called when Emacs loses an X selection.
\(This happens when some other X client makes its own selection
or when a Lisp program explicitly clears the selection.)
The functions are called with one argument, the selection type
\(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').  */);
  Vx_lost_selection_hooks = Qnil;

  DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks,
	       doc: /* A list of functions to be called when Emacs answers a selection request.
The functions are called with four arguments:
  - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');
  - the selection-type which Emacs was asked to convert the
    selection into before sending (for example, `STRING' or `LENGTH');

We might have failed (and declined the request) for any number of reasons,
including being asked for a selection that we no longer own, or being asked
to convert into a type that we don't know about or that is inappropriate.
This hook doesn't let you change the behavior of Emacs's selection replies,
it merely informs you that they have happened.  */);
  Vx_sent_selection_hooks = Qnil;

  DEFVAR_LISP ("selection-coding-system", &Vselection_coding_system,
	       doc: /* Coding system for communicating with other X clients.
When sending or receiving text via cut_buffer, selection, and clipboard,
the text is encoded or decoded by this coding system.

  QCLIPBOARD = intern ("CLIPBOARD");	staticpro (&QCLIPBOARD);
  QTIMESTAMP = intern ("TIMESTAMP");	staticpro (&QTIMESTAMP);
  QTEXT      = intern ("TEXT"); 	staticpro (&QTEXT);
  QCOMPOUND_TEXT = intern ("COMPOUND_TEXT"); staticpro (&QCOMPOUND_TEXT);
  QUTF8_STRING = intern ("UTF8_STRING"); staticpro (&QUTF8_STRING);
  QTIMESTAMP = intern ("TIMESTAMP");	staticpro (&QTIMESTAMP);
  QDELETE    = intern ("DELETE");	staticpro (&QDELETE);
  QMULTIPLE  = intern ("MULTIPLE");	staticpro (&QMULTIPLE);
  QINCR      = intern ("INCR");		staticpro (&QINCR);
  QEMACS_TMP = intern ("_EMACS_TMP_");	staticpro (&QEMACS_TMP);
  QTARGETS   = intern ("TARGETS");	staticpro (&QTARGETS);

  QCUT_BUFFER5 = intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5);
  QCUT_BUFFER6 = intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6);
  QCUT_BUFFER7 = intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7);
#endif

}

88155:d7ddb3e565de

/* X Selection processing for Emacs.
   Copyright (C) 1993, 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
                 2004, 2005 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

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
along with GNU Emacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */


/* Rewritten by jwz */

#include <config.h>
#include <stdio.h>      /* termhooks.h needs this */

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

#include "lisp.h"
#include "xterm.h"	/* for all of the X includes */
#include "dispextern.h"	/* frame.h seems to want this */
#include "frame.h"	/* Need this to get the X window of selected_frame */
#include "blockinput.h"
#include "buffer.h"
#include "process.h"
#include "termhooks.h"
#include "keyboard.h"

#include <X11/Xproto.h>

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

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 *));
static Lisp_Object x_get_foreign_selection P_ ((Lisp_Object,
                                                Lisp_Object,
                                                Lisp_Object));
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,

  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)
#define TRACE3(fmt, a0, a1, a2) \
  fprintf (stderr, "%d: " fmt "\n", getpid (), a0, a1, a2)
#else
#define TRACE0(fmt)		(void) 0
#define TRACE1(fmt, a0)		(void) 0
#define TRACE2(fmt, a0, a1)	(void) 0
#define TRACE3(fmt, a0, a1)	(void) 0
#endif


#define CUT_BUFFER_SUPPORT

#ifdef CUT_BUFFER_SUPPORT
Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
  QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
#endif

static Lisp_Object Vx_lost_selection_functions;
static Lisp_Object Vx_sent_selection_functions;
/* Coding system for communicating with other X clients via cutbuffer,
   selection, and clipboard.  */
static Lisp_Object Vselection_coding_system;

/* Coding system for the next communicating with other X clients.  */
static Lisp_Object Vnext_selection_coding_system;

static Lisp_Object Qforeign_selection;

/* 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
   emacs to use incremental selection transfers when the selection is

static Lisp_Object Vselection_converter_alist;

/* If the selection owner takes too long to reply to a selection request,
   we give up on it.  This is in milliseconds (0 = no timeout.)  */
static EMACS_INT x_selection_timeout;



/* Define a queue to save up SELECTION_REQUEST_EVENT events for later
   handling.  */

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

static struct selection_event_queue *selection_queue;

/* Nonzero means queue up SELECTION_REQUEST_EVENT events.  */

static int x_queue_selection_requests;

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

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

  /* Don't queue repeated requests.
     This only happens for large requests which uses the incremental protocol.  */
  for (queue_tmp = selection_queue; queue_tmp; queue_tmp = queue_tmp->next)
    {
      if (!bcmp (&queue_tmp->event, event, sizeof (*event)))
	{
	  TRACE1 ("DECLINE DUP SELECTION EVENT %08lx", (unsigned long)queue_tmp);
	  x_decline_selection_request (event);
	  return;
	}
    }

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

  if (queue_tmp != NULL)
    {
      TRACE1 ("QUEUE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
      queue_tmp->event = *event;
      queue_tmp->next = selection_queue;
      selection_queue = queue_tmp;
    }
}

/* Start queuing SELECTION_REQUEST_EVENT events.  */

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

/* Stop queuing SELECTION_REQUEST_EVENT events.  */

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;
      TRACE1 ("RESTORE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
      kbd_buffer_unget_event (&queue_tmp->event);
      selection_queue = queue_tmp->next;
      xfree ((char *)queue_tmp);
    }
}


/* This converts a Lisp symbol to a server Atom, avoiding a server
   roundtrip whenever possible.  */

static Atom

      count = SPECPDL_INDEX ();
      specbind (Qinhibit_quit, Qt);

      CHECK_SYMBOL (target_type);
      handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
      /* gcpro is not needed here since nothing but HANDLER_FN
	 is live, and that ought to be a symbol.  */

      if (!NILP (handler_fn))
	value = call3 (handler_fn,
		       selection_symbol, (local_request ? Qnil : target_type),
		       XCAR (XCDR (local_value)));
      else

static struct prop_location *property_change_reply_object;

static struct prop_location *property_change_wait_list;

static Lisp_Object
queue_selection_requests_unwind (tem)
     Lisp_Object tem;
{
  x_stop_queuing_selection_requests ();
  return Qnil;
}

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

  /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
  BLOCK_INPUT;
  count = x_catch_errors (display);

#ifdef TRACE_SELECTION
  {
    static int cnt;
    char *sel = XGetAtomName (display, reply.selection);
    char *tgt = XGetAtomName (display, reply.target);
    TRACE3 ("%s, target %s (%d)", sel, tgt, ++cnt);
    if (sel) XFree (sel);
    if (tgt) XFree (tgt);
  }
#endif /* TRACE_SELECTION */

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

      /* 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))
	{
	  x_start_queuing_selection_requests ();

	  record_unwind_protect (queue_selection_requests_unwind,
				 Qnil);
	}

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

      wait_object = expect_property_change (display, window, reply.property,
					    PropertyDelete);

      TRACE1 ("Set %s to number of bytes to send",
	      XGetAtomName (display, reply.property));
      {
        /* 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);
      }

      XSelectInput (display, window, PropertyChangeMask);

      /* Tell 'em the INCR data is there...  */
      TRACE0 ("Send SelectionNotify event");
      XSendEvent (display, window, False, 0L, (XEvent *) &reply);

	{
	  TRACE1 ("Waiting for ACK (deletion of %s)",
		  XGetAtomName (display, reply.property));
	  wait_for_property_change (wait_object);
	}
      else
	unexpect_property_change (wait_object);

      TRACE0 ("Got ACK");
      while (bytes_remaining)
	{
          int i = ((bytes_remaining < max_bytes)
                   ? bytes_remaining
                   : max_bytes);

	  BLOCK_INPUT;

	  wait_object
	    = expect_property_change (display, window, reply.property,

     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.   */
  /* 2004-09-10: XSync and UNBLOCK so that possible protocol errors are
     delivered before uncatch errors.  */
  XSync (display, False);
  UNBLOCK_INPUT;

  /* 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;
  x_uncatch_errors (display, count);
  UNBLOCK_INPUT;
}

/* Handle a SelectionRequest event EVENT.
   This is called from keyboard.c when such an event is found in the queue.  */

static void
x_handle_selection_request (event)
     struct input_event *event;
{
  struct gcpro gcpro1, gcpro2, gcpro3;
  Lisp_Object local_selection_data;

  Lisp_Object successful_p;
  int count;
  struct x_display_info *dpyinfo
    = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));

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

  local_selection_data = Qnil;
  target_symbol = Qnil;
  converted_selection = Qnil;
  successful_p = Qnil;

    }
  unbind_to (count, Qnil);

 DONE:

  /* Let random lisp code notice that the selection has been asked for.  */
  {
    Lisp_Object rest;
    rest = Vx_sent_selection_functions;
    if (!EQ (rest, Qunbound))
      for (; CONSP (rest); rest = Fcdr (rest))
	call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
  }

  UNGCPRO;
}

/* Handle a SelectionClear event EVENT, which indicates that some
   client cleared out our previously asserted selection.
   This is called from keyboard.c when such an event is found in the queue.  */

static void
x_handle_selection_clear (event)
     struct input_event *event;
{
  Display *display = SELECTION_EVENT_DISPLAY (event);
  Atom selection = SELECTION_EVENT_SELECTION (event);

  Lisp_Object selection_symbol, local_selection_data;
  Time local_selection_time;
  struct x_display_info *dpyinfo = x_display_info_for_display (display);
  struct x_display_info *t_dpyinfo;

  TRACE0 ("x_handle_selection_clear");

  /* If the new selection owner is also Emacs,
     don't clear the new selection.  */
  BLOCK_INPUT;
  /* Check each display on the same terminal,

  /* Let random lisp code notice that the selection has been stolen.  */

  {
    Lisp_Object rest;
    rest = Vx_lost_selection_functions;
    if (!EQ (rest, Qunbound))
      {
	for (; CONSP (rest); rest = Fcdr (rest))
	  call1 (Fcar (rest), selection_symbol);
	prepare_menu_bars ();
	redisplay_preserve_echo_area (20);
      }
  }
}

void
x_handle_selection_event (event)
     struct input_event *event;
{
  TRACE0 ("x_handle_selection_event");

  if (event->kind == SELECTION_REQUEST_EVENT)
    {
      if (x_queue_selection_requests)
	x_queue_event (event);
      else
	x_handle_selection_request (event);
    }
  else
    x_handle_selection_clear (event);
}


/* Clear all selections that were made from frame F.
   We do this when about to delete a frame.  */

void
x_clear_frame_selections (f)

	 && EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (Vselection_alist)))))))
    {
      /* Let random Lisp code notice that the selection has been stolen.  */
      Lisp_Object hooks, selection_symbol;

      hooks = Vx_lost_selection_functions;
      selection_symbol = Fcar (Fcar (Vselection_alist));

      if (!EQ (hooks, Qunbound))
	{
	  for (; CONSP (hooks); hooks = Fcdr (hooks))

    if (EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (XCDR (rest))))))))
      {
	/* Let random Lisp code notice that the selection has been stolen.  */
	Lisp_Object hooks, selection_symbol;

	hooks = Vx_lost_selection_functions;
	selection_symbol = Fcar (Fcar (XCDR (rest)));

	if (!EQ (hooks, Qunbound))
	  {
	    for (; CONSP (hooks); hooks = Fcdr (hooks))

}

/* Remove the property change expectation element for IDENTIFIER.  */

static Lisp_Object
wait_for_property_change_unwind (loc)
     Lisp_Object loc;
{
  struct prop_location *location = XSAVE_VALUE (loc)->pointer;

  unexpect_property_change (location);
  if (location == property_change_reply_object)
    property_change_reply_object = 0;
  return Qnil;
}

/* Actually wait for a property change.
   IDENTIFIER should be the value that expect_property_change returned.  */

wait_for_property_change (location)
     struct prop_location *location;
{
  int secs, usecs;
  int count = SPECPDL_INDEX ();

  if (property_change_reply_object)
    abort ();

  /* Make sure to do unexpect_property_change if we quit or err.  */
  record_unwind_protect (wait_for_property_change_unwind,
			 make_save_value (location, 0));

  XSETCAR (property_change_reply, Qnil);
  property_change_reply_object = location;

  /* If the event we are waiting for arrives beyond here, it will set
     property_change_reply, because property_change_reply_object says so.  */
  if (! location->arrived)
    {
      secs = x_selection_timeout / 1000;
      usecs = (x_selection_timeout % 1000) * 1000;
      TRACE2 ("  Waiting %d secs, %d usecs", secs, usecs);
      wait_reading_process_output (secs, usecs, 0, 0,
				   property_change_reply, NULL, 0);

      if (NILP (XCAR (property_change_reply)))
	{
	  TRACE0 ("  Timed out");
	  error ("Timed out waiting for property-notify event");

{
  struct prop_location *prev = 0, *rest = property_change_wait_list;

  while (rest)
    {
      if (!rest->arrived
	  && rest->property == event->atom
	  && rest->window == event->window
	  && rest->display == event->display
	  && rest->desired_state == event->state)
	{
	  TRACE2 ("Expected %s of property %s",

	  /* If this is the one wait_for_property_change is waiting for,
	     tell it to wake up.  */
	  if (rest == property_change_reply_object)
	    XSETCAR (property_change_reply, Qt);

	  return;
	}

      prev = rest;
      rest = rest->next;

/* Do protocol to read selection-data from the server.
   Converts this to Lisp data and returns it.  */

static Lisp_Object
x_get_foreign_selection (selection_symbol, target_type, time_stamp)
     Lisp_Object selection_symbol, target_type, time_stamp;
{
  struct frame *sf = SELECTED_FRAME ();
  Window requestor_window = FRAME_X_WINDOW (sf);
  Display *display = FRAME_X_DISPLAY (sf);
  struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (sf);

  if (CONSP (target_type))
    type_atom = symbol_to_x_atom (dpyinfo, display, XCAR (target_type));
  else
    type_atom = symbol_to_x_atom (dpyinfo, display, target_type);

  if (! NILP (time_stamp))
    {
      if (CONSP (time_stamp))
        requestor_time = (Time) cons_to_long (time_stamp);
      else if (INTEGERP (time_stamp))
        requestor_time = (Time) XUINT (time_stamp);
      else if (FLOATP (time_stamp))
        requestor_time = (Time) XFLOAT_DATA (time_stamp);
      else
        error ("TIME_STAMP must be cons or number");
    }

  BLOCK_INPUT;

  count = x_catch_errors (display);

  TRACE2 ("Get selection %s, type %s",

  /* 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))
    {
      x_start_queuing_selection_requests ();

      record_unwind_protect (queue_selection_requests_unwind,
			     Qnil);
    }
  UNBLOCK_INPUT;

  /* This allows quits.  Also, don't wait forever.  */
  secs = x_selection_timeout / 1000;
  usecs = (x_selection_timeout % 1000) * 1000;
  TRACE1 ("  Start waiting %d secs for SelectionNotify", secs);
  wait_reading_process_output (secs, usecs, 0, 0,
			       reading_selection_reply, NULL, 0);
  TRACE1 ("  Got event = %d", !NILP (XCAR (reading_selection_reply)));

  BLOCK_INPUT;
  x_check_errors (display, "Cannot get selection: %s");
  x_uncatch_errors (display, count);

      /* If this doesn't return Success at this point, it means that
	 some clod deleted the selection while we were in the midst of
	 reading it.  Deal with that, I guess.... */
      if (result != Success)
	break;

      /* The man page for XGetWindowProperty says:
         "If the returned format is 32, the returned data is represented
          as a long array and should be cast to that type to obtain the
          elements."
         This applies even if long is more than 32 bits, the X library
         converts from 32 bit elements received from the X server to long
         and passes the long array to us.  Thus, for that case bcopy can not
         be used.  We convert to a 32 bit type here, because so much code
         assume on that.

         The bytes and offsets passed to XGetWindowProperty refers to the
         property and those are indeed in 32 bit quantities if format is 32.  */

      if (*actual_format_ret == 32 && *actual_format_ret < BITS_PER_LONG)
        {
          unsigned long i;
          int  *idata = (int *) ((*data_ret) + offset);
          long *ldata = (long *) tmp_data;

          for (i = 0; i < *actual_size_ret; ++i)
            {
              idata[i]= (int) ldata[i];
              offset += 4;
            }
        }
      else
        {
          *actual_size_ret *= *actual_format_ret / 8;
          bcopy (tmp_data, (*data_ret) + offset, *actual_size_ret);
          offset += *actual_size_ret;
        }

      /* This was allocated by Xlib, so use XFree.  */
      XFree ((char *) tmp_data);
    }

     We are done when the sender places a property of length 0.
   */
  BLOCK_INPUT;
  XSelectInput (display, window, STANDARD_EVENT_SET | PropertyChangeMask);
  TRACE1 ("  Delete property %s",
	  SDATA (SYMBOL_NAME (x_atom_to_symbol (display, property))));
  XDeleteProperty (display, window, property);
  TRACE1 ("  Expect new value of property %s",
	  SDATA (SYMBOL_NAME (x_atom_to_symbol (display, property))));
  wait_object = expect_property_change (display, window, property,
					PropertyNewValue);
  XFlush (display);
  UNBLOCK_INPUT;

	{
	  TRACE0 ("Done reading incrementally");

	  if (! waiting_for_other_props_on_window (display, window))
	    XSelectInput (display, window, STANDARD_EVENT_SET);
	  /* Use xfree, not XFree, because x_get_window_property
	     calls xmalloc itself.  */
	  if (tmp_data) xfree (tmp_data);
	  break;
	}

   of format 16 if every element in the vector is an integer, and is assumed
   to be of format 32 if any element is a cons of two integers.

   When converting an object to C, it may be of the form (SYMBOL . <data>)
   where SYMBOL is what we should claim that the type is.  Format and
   representation are as above.

   Important: When format is 32, data should contain an array of int,
   not an array of long as the X library returns.  This makes a difference
   when sizeof(long) != sizeof(int).  */



static Lisp_Object
selection_data_to_lisp_data (display, data, size, type, format)

    return QNULL;

  /* Convert any 8-bit data to a string, for compactness.  */
  else if (format == 8)
    {
      Lisp_Object str, lispy_type;

      str = make_unibyte_string ((char *) data, size);
      /* Indicate that this string is from foreign selection by a text
	 property `foreign-selection' so that the caller of
	 x-get-selection-internal (usually x-get-selection) can know
	 that the string must be decode.  */
      if (type == dpyinfo->Xatom_COMPOUND_TEXT)
	lispy_type = QCOMPOUND_TEXT;
      else if (type == dpyinfo->Xatom_UTF8_STRING)
	lispy_type = QUTF8_STRING;
      else
	lispy_type = QSTRING;
      Fput_text_property (make_number (0), make_number (size),
			  Qforeign_selection, lispy_type, str);
      return str;
    }
  /* Convert a single atom to a Lisp_Symbol.  Convert a set of atoms to
     a vector of symbols.
   */
  else if (type == XA_ATOM)
    {
      int i;
      /* On a 64 bit machine sizeof(Atom) == sizeof(long) == 8.
         But the callers of these function has made sure the data for
         format == 32 is an array of int.  Thus, use int instead
         of Atom.  */
      int *idata = (int *) data;

      if (size == sizeof (int))
	return x_atom_to_symbol (display, (Atom) idata[0]);
      else
	{
	  Lisp_Object v = Fmake_vector (make_number (size / sizeof (int)),
					make_number (0));
	  for (i = 0; i < size / sizeof (int); i++)
	    Faset (v, make_number (i),
                   x_atom_to_symbol (display, (Atom) idata[i]));
	  return v;
	}
    }

  /* Convert a single 16 or small 32 bit number to a Lisp_Int.
     If the number is > 16 bits, convert it to a cons of integers,
     16 bits in each half.
   */
  else if (format == 32 && size == sizeof (int))
    return long_to_cons (((unsigned int *) data) [0]);
  else if (format == 16 && size == sizeof (short))
    return make_number ((int) (((unsigned short *) data) [0]));

  /* Convert any other kind of data to a vector of numbers, represented
     as above (as an integer, or a cons of two 16 bit integers.)

    {
      int i;
      Lisp_Object v = Fmake_vector (make_number (size / 4), make_number (0));
      for (i = 0; i < size / 4; i++)
	{
	  unsigned int j = ((unsigned int *) data) [i];
	  Faset (v, make_number (i), long_to_cons (j));
	}
      return v;
    }
}

      *data_ret = 0;
      type = QNULL;
    }
  else if (STRINGP (obj))
    {
      if (SCHARS (obj) < SBYTES (obj))
	/* OBJ is a multibyte string containing a non-ASCII char.  */
	Fsignal (Qerror, /* Qselection_error */
		 Fcons (build_string
			("Non-ASCII string must be encoded in advance"),
			Fcons (obj, Qnil)));
      if (NILP (type))
	type = QSTRING;
      *format_ret = 8;
      *size_ret = SBYTES (obj);
      *data_ret = SDATA (obj);

	}
#endif
      else
	/* This vector is an INTEGER set, or something like it */
	{
          int data_size = 2;
	  *size_ret = XVECTOR (obj)->size;
	  if (NILP (type)) type = QINTEGER;
	  *format_ret = 16;
	  for (i = 0; i < *size_ret; i++)
	    if (CONSP (XVECTOR (obj)->contents [i]))

	      Fsignal (Qerror, /* Qselection_error */
		       Fcons (build_string
	("elements of selection vector must be integers or conses of integers"),
			      Fcons (obj, Qnil)));

          /* Use sizeof(long) even if it is more than 32 bits.  See comment
             in x_get_window_property and x_fill_property_data.  */

          if (*format_ret == 32) data_size = sizeof(long);
	  *data_ret = (unsigned char *) xmalloc (*size_ret * data_size);
	  for (i = 0; i < *size_ret; i++)
	    if (*format_ret == 32)
	      (*((unsigned long **) data_ret)) [i]
		= cons_to_long (XVECTOR (obj)->contents [i]);
	    else

		= (unsigned short) cons_to_long (XVECTOR (obj)->contents [i]);
	}
    }
  else
    Fsignal (Qerror, /* Qselection_error */
	     Fcons (build_string ("unrecognized selection data"),
		    Fcons (obj, Qnil)));

  *type_ret = symbol_to_x_atom (dpyinfo, display, type);
}

     (selection_name, selection_value)
     Lisp_Object selection_name, selection_value;
{
  check_x ();
  CHECK_SYMBOL (selection_name);
  if (NILP (selection_value)) error ("SELECTION-VALUE may not be nil");
  x_own_selection (selection_name, selection_value);
  return selection_value;
}


/* Request the selection value from the owner.  If we are the owner,
   simply return our selection value.  If we are not the owner, this
   will block until all of the data has arrived.  */

DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
       Sx_get_selection_internal, 2, 3, 0,
       doc: /* Return text selected from some X window.
SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
\(Those are literal upper-case symbol names, since that's what X expects.)
TYPE is the type of data desired, typically `STRING'.
TIME_STAMP is the time to use in the XConvertSelection call for foreign
selections.  If omitted, defaults to the time for the last event.  */)
  (selection_symbol, target_type, time_stamp)
     Lisp_Object selection_symbol, target_type, time_stamp;
{
  Lisp_Object val = Qnil;
  struct gcpro gcpro1, gcpro2;
  GCPRO2 (target_type, val); /* we store newly consed data into these */
  check_x ();

  val = x_get_local_selection (selection_symbol, target_type, 1);

  if (NILP (val))
    {
      val = x_get_foreign_selection (selection_symbol, target_type, time_stamp);
      goto DONE;
    }

  if (CONSP (val)
      && SYMBOLP (XCAR (val)))

     Lisp_Object selection;
     Lisp_Object time;
{
  Time timestamp;
  Atom selection_atom;
  union {
    struct selection_input_event sie;
    struct input_event ie;
  } event;
  Display *display;
  struct x_display_info *dpyinfo;
  struct frame *sf = SELECTED_FRAME ();

  check_x ();

  /* It doesn't seem to be guaranteed that a SelectionClear event will be
     generated for a window which owns the selection when that window sets
     the selection owner to None.  The NCD server does, the MIT Sun4 server
     doesn't.  So we synthesize one; this means we might get two, but
     that's ok, because the second one won't have any effect.  */
  SELECTION_EVENT_DISPLAY (&event.sie) = display;
  SELECTION_EVENT_SELECTION (&event.sie) = selection_atom;
  SELECTION_EVENT_TIME (&event.sie) = timestamp;
  x_handle_selection_clear (&event.ie);

  return Qt;
}

/* Get rid of all the selections in buffer BUFFER.

    Fsignal (Qerror,
	     Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
		    Fcons (x_atom_to_symbol (display, type),
			   Fcons (make_number (format), Qnil))));

  ret = (bytes ? make_unibyte_string ((char *) data, bytes) : Qnil);
  /* Use xfree, not XFree, because x_get_window_property
     calls xmalloc itself.  */
  xfree (data);
  return ret;
}

  return n;
}

#endif

/***********************************************************************
                      Drag and drop support
***********************************************************************/
/* Check that lisp values are of correct type for x_fill_property_data.
   That is, number, string or a cons with two numbers (low and high 16
   bit parts of a 32 bit number).  */

int
x_check_property_data (data)
     Lisp_Object data;
{
  Lisp_Object iter;
  int size = 0;

  for (iter = data; CONSP (iter) && size != -1; iter = XCDR (iter), ++size)
    {
      Lisp_Object o = XCAR (iter);

      if (! NUMBERP (o) && ! STRINGP (o) && ! CONSP (o))
        size = -1;
      else if (CONSP (o) &&
               (! NUMBERP (XCAR (o)) || ! NUMBERP (XCDR (o))))
        size = -1;
    }

  return size;
}

/* Convert lisp values to a C array.  Values may be a number, a string
   which is taken as an X atom name and converted to the atom value, or
   a cons containing the two 16 bit parts of a 32 bit number.

   DPY is the display use to look up X atoms.
   DATA is a Lisp list of values to be converted.
   RET is the C array that contains the converted values.  It is assumed
   it is big enough to hold all values.
   FORMAT is 8, 16 or 32 and denotes char/short/long for each C value to
   be stored in RET.  Note that long is used for 32 even if long is more
   than 32 bits (see man pages for XChangeProperty, XGetWindowProperty and
   XClientMessageEvent).  */

void
x_fill_property_data (dpy, data, ret, format)
     Display *dpy;
     Lisp_Object data;
     void *ret;
     int format;
{
  long val;
  long  *d32 = (long  *) ret;
  short *d16 = (short *) ret;
  char  *d08 = (char  *) ret;
  Lisp_Object iter;

  for (iter = data; CONSP (iter); iter = XCDR (iter))
    {
      Lisp_Object o = XCAR (iter);

      if (INTEGERP (o))
        val = (long) XFASTINT (o);
      else if (FLOATP (o))
        val = (long) XFLOAT_DATA (o);
      else if (CONSP (o))
        val = (long) cons_to_long (o);
      else if (STRINGP (o))
        {
          BLOCK_INPUT;
          val = (long) XInternAtom (dpy, (char *) SDATA (o), False);
          UNBLOCK_INPUT;
        }
      else
        error ("Wrong type, must be string, number or cons");

      if (format == 8)
        *d08++ = (char) val;
      else if (format == 16)
        *d16++ = (short) val;
      else
        *d32++ = val;
    }
}

/* Convert an array of C values to a Lisp list.
   F is the frame to be used to look up X atoms if the TYPE is XA_ATOM.
   DATA is a C array of values to be converted.
   TYPE is the type of the data.  Only XA_ATOM is special, it converts
   each number in DATA to its corresponfing X atom as a symbol.
   FORMAT is 8, 16 or 32 and gives the size in bits for each C value to
   be stored in RET.
   SIZE is the number of elements in DATA.

   Important: When format is 32, data should contain an array of int,
   not an array of long as the X library returns.  This makes a difference
   when sizeof(long) != sizeof(int).

   Also see comment for selection_data_to_lisp_data above.  */

Lisp_Object
x_property_data_to_lisp (f, data, type, format, size)
     struct frame *f;
     unsigned char *data;
     Atom type;
     int format;
     unsigned long size;
{
  return selection_data_to_lisp_data (FRAME_X_DISPLAY (f),
                                      data, size*format/8, type, format);
}

/* Get the mouse position in frame relative coordinates.  */

static void
mouse_position_for_drop (f, x, y)
     FRAME_PTR f;
     int *x;
     int *y;
{
  Window root, dummy_window;
  int dummy;

  BLOCK_INPUT;

  XQueryPointer (FRAME_X_DISPLAY (f),
                 DefaultRootWindow (FRAME_X_DISPLAY (f)),

                 /* The root window which contains the pointer.  */
                 &root,

                 /* Window pointer is on, not used  */
                 &dummy_window,

                 /* The position on that root window.  */
                 x, y,

                 /* x/y in dummy_window coordinates, not used.  */
                 &dummy, &dummy,

                 /* Modifier keys and pointer buttons, about which
                    we don't care.  */
                 (unsigned int *) &dummy);


  /* Absolute to relative.  */
  *x -= f->left_pos + FRAME_OUTER_TO_INNER_DIFF_X (f);
  *y -= f->top_pos + FRAME_OUTER_TO_INNER_DIFF_Y (f);

  UNBLOCK_INPUT;
}

DEFUN ("x-get-atom-name", Fx_get_atom_name,
       Sx_get_atom_name, 1, 2, 0,
       doc: /* Return the X atom name for VALUE as a string.
VALUE may be a number or a cons where the car is the upper 16 bits and
the cdr is the lower 16 bits of a 32 bit value.
Use the display for FRAME or the current frame if FRAME is not given or nil.

If the value is 0 or the atom is not known, return the empty string.  */)
  (value, frame)
     Lisp_Object value, frame;
{
  struct frame *f = check_x_frame (frame);
  char *name = 0;
  Lisp_Object ret = Qnil;
  int count;
  Display *dpy = FRAME_X_DISPLAY (f);
  Atom atom;

  if (INTEGERP (value))
    atom = (Atom) XUINT (value);
  else if (FLOATP (value))
    atom = (Atom) XFLOAT_DATA (value);
  else if (CONSP (value))
    atom = (Atom) cons_to_long (value);
  else
    error ("Wrong type, value must be number or cons");

  BLOCK_INPUT;
  count = x_catch_errors (dpy);

  name = atom ? XGetAtomName (dpy, atom) : "";

  if (! x_had_errors_p (dpy))
    ret = make_string (name, strlen (name));

  x_uncatch_errors (dpy, count);

  if (atom && name) XFree (name);
  if (NILP (ret)) ret = make_string ("", 0);

  UNBLOCK_INPUT;

  return ret;
}

/* Convert an XClientMessageEvent to a Lisp event of type DRAG_N_DROP_EVENT.
   TODO: Check if this client event really is a DND event?  */

int
x_handle_dnd_message (f, event, dpyinfo, bufp)
     struct frame *f;
     XClientMessageEvent *event;
     struct x_display_info *dpyinfo;
     struct input_event *bufp;
{
  Lisp_Object vec;
  Lisp_Object frame;
  /* format 32 => size 5, format 16 => size 10, format 8 => size 20 */
  unsigned long size = 160/event->format;
  int x, y;
  unsigned char *data = (unsigned char *) event->data.b;
  int idata[5];

  XSETFRAME (frame, f);

  /* On a 64 bit machine, the event->data.l array members are 64 bits (long),
     but the x_property_data_to_lisp (or rather selection_data_to_lisp_data)
     function expects them to be of size int (i.e. 32).  So to be able to
     use that function, put the data in the form it expects if format is 32. */

  if (event->format == 32 && event->format < BITS_PER_LONG)
    {
      int i;
      for (i = 0; i < 5; ++i) /* There are only 5 longs in a ClientMessage. */
        idata[i] = (int) event->data.l[i];
      data = (unsigned char *) idata;
    }

  vec = Fmake_vector (make_number (4), Qnil);
  AREF (vec, 0) = SYMBOL_NAME (x_atom_to_symbol (FRAME_X_DISPLAY (f),
                                                 event->message_type));
  AREF (vec, 1) = frame;
  AREF (vec, 2) = make_number (event->format);
  AREF (vec, 3) = x_property_data_to_lisp (f,
                                           data,
                                           event->message_type,
                                           event->format,
                                           size);

  mouse_position_for_drop (f, &x, &y);
  bufp->kind = DRAG_N_DROP_EVENT;
  bufp->frame_or_window = frame;
  bufp->timestamp = CurrentTime;
  bufp->x = make_number (x);
  bufp->y = make_number (y);
  bufp->arg = vec;
  bufp->modifiers = 0;

  return 1;
}

DEFUN ("x-send-client-message", Fx_send_client_event,
       Sx_send_client_message, 6, 6, 0,
       doc: /* Send a client message of MESSAGE-TYPE to window DEST on DISPLAY.

For DISPLAY, specify either a frame or a display name (a string).
If DISPLAY is nil, that stands for the selected frame's display.
DEST may be a number, in which case it is a Window id.  The value 0 may
be used to send to the root window of the DISPLAY.
If DEST is a cons, it is converted to a 32 bit number
with the high 16 bits from the car and the lower 16 bit from the cdr.  That
number is then used as a window id.
If DEST is a frame the event is sent to the outer window of that frame.
Nil means the currently selected frame.
If DEST is the string "PointerWindow" the event is sent to the window that
contains the pointer.  If DEST is the string "InputFocus" the event is
sent to the window that has the input focus.
FROM is the frame sending the event.  Use nil for currently selected frame.
MESSAGE-TYPE is the name of an Atom as a string.
FORMAT must be one of 8, 16 or 32 and determines the size of the values in
bits.  VALUES is a list of numbers, cons and/or strings containing the values
to send.  If a value is a string, it is converted to an Atom and the value of
the Atom is sent.  If a value is a cons, it is converted to a 32 bit number
with the high 16 bits from the car and the lower 16 bit from the cdr.
If more values than fits into the event is given, the excessive values
are ignored.  */)
     (display, dest, from, message_type, format, values)
     Lisp_Object display, dest, from, message_type, format, values;
{
  struct x_display_info *dpyinfo = check_x_display_info (display);
  Window wdest;
  XEvent event;
  Lisp_Object cons;
  int size;
  struct frame *f = check_x_frame (from);
  int count;
  int to_root;

  CHECK_STRING (message_type);
  CHECK_NUMBER (format);
  CHECK_CONS (values);

  if (x_check_property_data (values) == -1)
    error ("Bad data in VALUES, must be number, cons or string");

  event.xclient.type = ClientMessage;
  event.xclient.format = XFASTINT (format);

  if (event.xclient.format != 8 && event.xclient.format != 16
      && event.xclient.format != 32)
    error ("FORMAT must be one of 8, 16 or 32");

  if (FRAMEP (dest) || NILP (dest))
    {
      struct frame *fdest = check_x_frame (dest);
      wdest = FRAME_OUTER_WINDOW (fdest);
    }
  else if (STRINGP (dest))
    {
      if (strcmp (SDATA (dest), "PointerWindow") == 0)
        wdest = PointerWindow;
      else if (strcmp (SDATA (dest), "InputFocus") == 0)
        wdest = InputFocus;
      else
        error ("DEST as a string must be one of PointerWindow or InputFocus");
    }
  else if (INTEGERP (dest))
    wdest = (Window) XFASTINT (dest);
  else if (FLOATP (dest))
    wdest =  (Window) XFLOAT_DATA (dest);
  else if (CONSP (dest))
    {
      if (! NUMBERP (XCAR (dest)) || ! NUMBERP (XCDR (dest)))
        error ("Both car and cdr for DEST must be numbers");
      else
        wdest = (Window) cons_to_long (dest);
    }
  else
    error ("DEST must be a frame, nil, string, number or cons");

  if (wdest == 0) wdest = dpyinfo->root_window;
  to_root = wdest == dpyinfo->root_window;

  for (cons = values, size = 0; CONSP (cons); cons = XCDR (cons), ++size)
    ;

  BLOCK_INPUT;

  event.xclient.message_type
    = XInternAtom (dpyinfo->display, SDATA (message_type), False);
  event.xclient.display = dpyinfo->display;

  /* Some clients (metacity for example) expects sending window to be here
     when sending to the root window.  */
  event.xclient.window = to_root ? FRAME_OUTER_WINDOW (f) : wdest;


  memset (event.xclient.data.b, 0, sizeof (event.xclient.data.b));
  x_fill_property_data (dpyinfo->display, values, event.xclient.data.b,
                        event.xclient.format);

  /* If event mask is 0 the event is sent to the client that created
     the destination window.  But if we are sending to the root window,
     there is no such client.  Then we set the event mask to 0xffff.  The
     event then goes to clients selecting for events on the root window.  */
  count = x_catch_errors (dpyinfo->display);
  {
    int propagate = to_root ? False : True;
    unsigned mask = to_root ? 0xffff : 0;
    XSendEvent (dpyinfo->display, wdest, propagate, mask, &event);
    XFlush (dpyinfo->display);
  }
  x_uncatch_errors (dpyinfo->display, count);
  UNBLOCK_INPUT;

  return Qnil;
}


void
syms_of_xselect ()
{
  defsubr (&Sx_get_selection_internal);
  defsubr (&Sx_own_selection_internal);

#ifdef CUT_BUFFER_SUPPORT
  defsubr (&Sx_get_cut_buffer_internal);
  defsubr (&Sx_store_cut_buffer_internal);
  defsubr (&Sx_rotate_cut_buffers_internal);
#endif

  defsubr (&Sx_get_atom_name);
  defsubr (&Sx_send_client_message);

  reading_selection_reply = Fcons (Qnil, Qnil);
  staticpro (&reading_selection_reply);
  reading_selection_window = 0;
  reading_which_selection = 0;

A return value which is the symbol `NULL'
means that a side-effect was executed,
and there is no meaningful selection value.  */);
  Vselection_converter_alist = Qnil;

  DEFVAR_LISP ("x-lost-selection-functions", &Vx_lost_selection_functions,
	       doc: /* A list of functions to be called when Emacs loses an X selection.
\(This happens when some other X client makes its own selection
or when a Lisp program explicitly clears the selection.)
The functions are called with one argument, the selection type
\(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').  */);
  Vx_lost_selection_functions = Qnil;

  DEFVAR_LISP ("x-sent-selection-functions", &Vx_sent_selection_functions,
	       doc: /* A list of functions to be called when Emacs answers a selection request.
The functions are called with four arguments:
  - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');
  - the selection-type which Emacs was asked to convert the
    selection into before sending (for example, `STRING' or `LENGTH');

We might have failed (and declined the request) for any number of reasons,
including being asked for a selection that we no longer own, or being asked
to convert into a type that we don't know about or that is inappropriate.
This hook doesn't let you change the behavior of Emacs's selection replies,
it merely informs you that they have happened.  */);
  Vx_sent_selection_functions = Qnil;

  DEFVAR_LISP ("selection-coding-system", &Vselection_coding_system,
	       doc: /* Coding system for communicating with other X clients.
When sending or receiving text via cut_buffer, selection, and clipboard,
the text is encoded or decoded by this coding system.

  QCLIPBOARD = intern ("CLIPBOARD");	staticpro (&QCLIPBOARD);
  QTIMESTAMP = intern ("TIMESTAMP");	staticpro (&QTIMESTAMP);
  QTEXT      = intern ("TEXT"); 	staticpro (&QTEXT);
  QCOMPOUND_TEXT = intern ("COMPOUND_TEXT"); staticpro (&QCOMPOUND_TEXT);
  QUTF8_STRING = intern ("UTF8_STRING"); staticpro (&QUTF8_STRING);
  QDELETE    = intern ("DELETE");	staticpro (&QDELETE);
  QMULTIPLE  = intern ("MULTIPLE");	staticpro (&QMULTIPLE);
  QINCR      = intern ("INCR");		staticpro (&QINCR);
  QEMACS_TMP = intern ("_EMACS_TMP_");	staticpro (&QEMACS_TMP);
  QTARGETS   = intern ("TARGETS");	staticpro (&QTARGETS);

  QCUT_BUFFER5 = intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5);
  QCUT_BUFFER6 = intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6);
  QCUT_BUFFER7 = intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7);
#endif

  Qforeign_selection = intern ("foreign-selection");
  staticpro (&Qforeign_selection);
}

/* arch-tag: 7c293b0f-9918-4f69-8ac7-03e142307236
   (do not change this comment) */