(char-db-feature-domains): Delete `jis/alt' because it has been
[chise/xemacs-chise.git] / src / select-x.c
1 /* X Selection processing for XEmacs
2    Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
3
4 This file is part of XEmacs.
5
6 XEmacs is free software; you can redistribute it and/or modify it
7 under the terms of the GNU General Public License as published by the
8 Free Software Foundation; either version 2, or (at your option) any
9 later version.
10
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
14 for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with XEmacs; see the file COPYING.  If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA.  */
20
21 /* Synched up with: Not synched with FSF. */
22
23 /* Rewritten by jwz */
24
25 #include <config.h>
26 #include "lisp.h"
27
28 #include "buffer.h"
29 #include "console-x.h"
30 #include "objects-x.h"
31
32 #include "frame.h"
33 #include "opaque.h"
34 #include "systime.h"
35 #include "select.h"
36
37 int lisp_to_time (Lisp_Object, time_t *);
38 Lisp_Object time_to_lisp (time_t);
39
40 #ifdef LWLIB_USES_MOTIF
41 # define MOTIF_CLIPBOARDS
42 #endif
43
44 #ifdef MOTIF_CLIPBOARDS
45 # include <Xm/CutPaste.h>
46 static void hack_motif_clipboard_selection (Atom selection_atom,
47                                             Lisp_Object selection_value,
48                                             Time thyme, Display *display,
49                                             Window selecting_window,
50                                             int owned_p);
51 #endif
52
53 #define CUT_BUFFER_SUPPORT
54
55 #ifdef CUT_BUFFER_SUPPORT
56 Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
57   QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
58 #endif
59
60 Lisp_Object Vx_sent_selection_hooks;
61
62 /* If this is a smaller number than the max-request-size of the display,
63    emacs will use INCR selection transfer when the selection is larger
64    than this.  The max-request-size is usually around 64k, so if you want
65    emacs to use incremental selection transfers when the selection is
66    smaller than that, set this.  I added this mostly for debugging the
67    incremental transfer stuff, but it might improve server performance.
68  */
69 #define MAX_SELECTION_QUANTUM 0xFFFFFF
70
71 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize (dpy) << 2) - 100)
72
73 /* If the selection owner takes too long to reply to a selection request,
74    we give up on it.  This is in seconds (0 = no timeout).
75  */
76 Fixnum x_selection_timeout;
77
78 /* Enable motif selection optimizations. */
79 int x_selection_strict_motif_ownership;
80
81 \f
82 /* Utility functions */
83
84 static void lisp_data_to_selection_data (struct device *,
85                                          Lisp_Object obj,
86                                          unsigned char **data_ret,
87                                          Atom *type_ret,
88                                          unsigned int *size_ret,
89                                          int *format_ret);
90 static Lisp_Object selection_data_to_lisp_data (struct device *,
91                                                 Extbyte *data,
92                                                 size_t size,
93                                                 Atom type,
94                                                 int format);
95 static Lisp_Object x_get_window_property_as_lisp_data (Display *,
96                                                        Window,
97                                                        Atom property,
98                                                        Lisp_Object target_type,
99                                                        Atom selection_atom);
100
101 static int expect_property_change (Display *, Window, Atom prop, int state);
102 static void wait_for_property_change (long);
103 static void unexpect_property_change (int);
104 static int waiting_for_other_props_on_window (Display *, Window);
105
106 /* This converts a Lisp symbol to a server Atom, avoiding a server
107    roundtrip whenever possible.
108  */
109 static Atom
110 symbol_to_x_atom (struct device *d, Lisp_Object sym, int only_if_exists)
111 {
112   Display *display = DEVICE_X_DISPLAY (d);
113
114   if (NILP (sym))               return XA_PRIMARY;
115   if (EQ (sym, Qt))             return XA_SECONDARY;
116   if (EQ (sym, QPRIMARY))       return XA_PRIMARY;
117   if (EQ (sym, QSECONDARY))     return XA_SECONDARY;
118   if (EQ (sym, QSTRING))        return XA_STRING;
119   if (EQ (sym, QINTEGER))       return XA_INTEGER;
120   if (EQ (sym, QATOM))          return XA_ATOM;
121   if (EQ (sym, QCLIPBOARD))     return DEVICE_XATOM_CLIPBOARD (d);
122   if (EQ (sym, QTIMESTAMP))     return DEVICE_XATOM_TIMESTAMP (d);
123   if (EQ (sym, QTEXT))          return DEVICE_XATOM_TEXT      (d);
124   if (EQ (sym, QDELETE))        return DEVICE_XATOM_DELETE    (d);
125   if (EQ (sym, QMULTIPLE))      return DEVICE_XATOM_MULTIPLE  (d);
126   if (EQ (sym, QINCR))          return DEVICE_XATOM_INCR      (d);
127   if (EQ (sym, QEMACS_TMP))     return DEVICE_XATOM_EMACS_TMP (d);
128   if (EQ (sym, QTARGETS))       return DEVICE_XATOM_TARGETS   (d);
129   if (EQ (sym, QNULL))          return DEVICE_XATOM_NULL      (d);
130   if (EQ (sym, QATOM_PAIR))     return DEVICE_XATOM_ATOM_PAIR (d);
131   if (EQ (sym, QCOMPOUND_TEXT)) return DEVICE_XATOM_COMPOUND_TEXT (d);
132
133 #ifdef CUT_BUFFER_SUPPORT
134   if (EQ (sym, QCUT_BUFFER0))   return XA_CUT_BUFFER0;
135   if (EQ (sym, QCUT_BUFFER1))   return XA_CUT_BUFFER1;
136   if (EQ (sym, QCUT_BUFFER2))   return XA_CUT_BUFFER2;
137   if (EQ (sym, QCUT_BUFFER3))   return XA_CUT_BUFFER3;
138   if (EQ (sym, QCUT_BUFFER4))   return XA_CUT_BUFFER4;
139   if (EQ (sym, QCUT_BUFFER5))   return XA_CUT_BUFFER5;
140   if (EQ (sym, QCUT_BUFFER6))   return XA_CUT_BUFFER6;
141   if (EQ (sym, QCUT_BUFFER7))   return XA_CUT_BUFFER7;
142 #endif /* CUT_BUFFER_SUPPORT */
143
144   {
145     const char *nameext;
146     LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), nameext, Qctext);
147     return XInternAtom (display, nameext, only_if_exists ? True : False);
148   }
149 }
150
151
152 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
153    and calls to intern whenever possible.
154  */
155 static Lisp_Object
156 x_atom_to_symbol (struct device *d, Atom atom)
157 {
158   Display *display = DEVICE_X_DISPLAY (d);
159
160   if (! atom) return Qnil;
161   if (atom == XA_PRIMARY)       return QPRIMARY;
162   if (atom == XA_SECONDARY)     return QSECONDARY;
163   if (atom == XA_STRING)        return QSTRING;
164   if (atom == XA_INTEGER)       return QINTEGER;
165   if (atom == XA_ATOM)          return QATOM;
166   if (atom == DEVICE_XATOM_CLIPBOARD (d)) return QCLIPBOARD;
167   if (atom == DEVICE_XATOM_TIMESTAMP (d)) return QTIMESTAMP;
168   if (atom == DEVICE_XATOM_TEXT      (d)) return QTEXT;
169   if (atom == DEVICE_XATOM_DELETE    (d)) return QDELETE;
170   if (atom == DEVICE_XATOM_MULTIPLE  (d)) return QMULTIPLE;
171   if (atom == DEVICE_XATOM_INCR      (d)) return QINCR;
172   if (atom == DEVICE_XATOM_EMACS_TMP (d)) return QEMACS_TMP;
173   if (atom == DEVICE_XATOM_TARGETS   (d)) return QTARGETS;
174   if (atom == DEVICE_XATOM_NULL      (d)) return QNULL;
175   if (atom == DEVICE_XATOM_ATOM_PAIR (d)) return QATOM_PAIR;
176   if (atom == DEVICE_XATOM_COMPOUND_TEXT (d)) return QCOMPOUND_TEXT;
177
178 #ifdef CUT_BUFFER_SUPPORT
179   if (atom == XA_CUT_BUFFER0)   return QCUT_BUFFER0;
180   if (atom == XA_CUT_BUFFER1)   return QCUT_BUFFER1;
181   if (atom == XA_CUT_BUFFER2)   return QCUT_BUFFER2;
182   if (atom == XA_CUT_BUFFER3)   return QCUT_BUFFER3;
183   if (atom == XA_CUT_BUFFER4)   return QCUT_BUFFER4;
184   if (atom == XA_CUT_BUFFER5)   return QCUT_BUFFER5;
185   if (atom == XA_CUT_BUFFER6)   return QCUT_BUFFER6;
186   if (atom == XA_CUT_BUFFER7)   return QCUT_BUFFER7;
187 #endif
188
189   {
190     char *intstr;
191     char *str = XGetAtomName (display, atom);
192
193     if (! str) return Qnil;
194
195     TO_INTERNAL_FORMAT (C_STRING, str,
196                         C_STRING_ALLOCA, intstr,
197                         Qctext);
198     XFree (str);
199     return intern (intstr);
200   }
201 }
202
203 \f
204 /* Do protocol to assert ourself as a selection owner.
205  */
206 static Lisp_Object
207 x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
208                  Lisp_Object how_to_add, Lisp_Object selection_type,
209                  int owned_p)
210 {
211   struct device *d = decode_x_device (Qnil);
212   Display *display = DEVICE_X_DISPLAY (d);
213   struct frame *sel_frame = selected_frame ();
214   Window selecting_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
215   Lisp_Object selection_time;
216   /* Use the time of the last-read mouse or keyboard event.
217      For selection purposes, we use this as a sleazy way of knowing what the
218      current time is in server-time.  This assumes that the most recently read
219      mouse or keyboard event has something to do with the assertion of the
220      selection, which is probably true.
221      */
222   Time thyme = DEVICE_X_MOUSE_TIMESTAMP (d);
223   Atom selection_atom;
224
225   CHECK_SYMBOL (selection_name);
226   selection_atom = symbol_to_x_atom (d, selection_name, 0);
227
228   XSetSelectionOwner (display, selection_atom, selecting_window, thyme);
229
230   /* We do NOT use time_to_lisp() here any more, like we used to.
231      That assumed equivalence of time_t and Time, which is not
232      necessarily the case (e.g. under OSF on the Alphas, where
233      Time is a 64-bit quantity and time_t is a 32-bit quantity).
234
235      Opaque pointers are the clean way to go here.
236   */
237   selection_time = make_opaque (&thyme, sizeof (thyme));
238
239 #ifdef MOTIF_CLIPBOARDS
240   hack_motif_clipboard_selection (selection_atom, selection_value,
241                                   thyme, display, selecting_window, owned_p);
242 #endif
243   return selection_time;
244 }
245
246 #ifdef MOTIF_CLIPBOARDS /* Bend over baby.  Take it and like it. */
247
248 # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
249 static void motif_clipboard_cb ();
250 # endif
251
252 static void
253 hack_motif_clipboard_selection (Atom selection_atom,
254                                 Lisp_Object selection_value,
255                                 Time thyme,
256                                 Display *display,
257                                 Window selecting_window,
258                                 int owned_p)
259 {
260   struct device *d = get_device_from_display (display);
261   /* Those Motif wankers can't be bothered to follow the ICCCM, and do
262      their own non-Xlib non-Xt clipboard processing.  So we have to do
263      this so that linked-in Motif widgets don't get themselves wedged.
264    */
265   if (selection_atom == DEVICE_XATOM_CLIPBOARD (d)
266       && STRINGP (selection_value)
267
268       /* If we already own the clipboard, don't own it again in the Motif
269          way.  This might lose in some subtle way, since the timestamp won't
270          be current, but owning the selection on the Motif way does a
271          SHITLOAD of X protocol, and it makes killing text be incredibly
272          slow when using an X terminal.  ARRRRGGGHHH!!!!
273        */
274       /* No, this is no good, because then Motif text fields don't bother
275          to look up the new value, and you can't Copy from a buffer, Paste
276          into a text field, then Copy something else from the buffer and
277          paste it into the text field -- it pastes the first thing again. */
278       && (!owned_p 
279           /* Selectively re-enable this because for most users its
280              just too painful - especially over a remote link. */
281           || x_selection_strict_motif_ownership)
282       )
283     {
284 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
285       Widget widget = FRAME_X_TEXT_WIDGET (selected_frame());
286 #endif
287       long itemid;
288 #if XmVersion >= 1002
289       long dataid;
290 #else
291       int dataid;       /* 1.2 wants long, but 1.1.5 wants int... */
292 #endif
293       XmString fmh;
294       String encoding = "STRING";
295       const Bufbyte *data  = XSTRING_DATA (selection_value);
296       Bytecount bytes = XSTRING_LENGTH (selection_value);
297
298 #ifdef MULE
299       {
300         enum { ASCII, LATIN_1, WORLD } chartypes = ASCII;
301         const Bufbyte *ptr = data, *end = ptr + bytes;
302         /* Optimize for the common ASCII case */
303         while (ptr <= end)
304           {
305             if (BYTE_ASCII_P (*ptr))
306               {
307                 ptr++;
308                 continue;
309               }
310
311             if ((*ptr) == LEADING_BYTE_LATIN_ISO8859_1 ||
312                 (*ptr) == LEADING_BYTE_CONTROL_1)
313               {
314                 chartypes = LATIN_1;
315                 ptr += 2;
316                 continue;
317               }
318
319             chartypes = WORLD;
320             break;
321           }
322
323         if (chartypes == LATIN_1)
324           TO_EXTERNAL_FORMAT (LISP_STRING, selection_value,
325                               ALLOCA, (data, bytes),
326                               Qbinary);
327         else if (chartypes == WORLD)
328           {
329             TO_EXTERNAL_FORMAT (LISP_STRING, selection_value,
330                                 ALLOCA, (data, bytes),
331                                 Qctext);
332             encoding = "COMPOUND_TEXT";
333           }
334       }
335 #endif /* MULE */
336
337       fmh = XmStringCreateLtoR ("Clipboard", XmSTRING_DEFAULT_CHARSET);
338       while (ClipboardSuccess !=
339              XmClipboardStartCopy (display, selecting_window, fmh, thyme,
340 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
341                                    widget, motif_clipboard_cb,
342 #else
343                                    0, NULL,
344 #endif
345                                    &itemid))
346         ;
347       XmStringFree (fmh);
348       while (ClipboardSuccess !=
349              XmClipboardCopy (display, selecting_window, itemid, encoding,
350 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
351                               /* O'Reilly examples say size can be 0,
352                                  but this clearly is not the case. */
353                               0, bytes, (int) selecting_window, /* private id */
354 #else /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
355                               (XtPointer) data, bytes, 0,
356 #endif /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
357                               &dataid))
358         ;
359       while (ClipboardSuccess !=
360              XmClipboardEndCopy (display, selecting_window, itemid))
361         ;
362     }
363 }
364
365 # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
366 /* I tried to treat the clipboard like a real selection, and not send
367    the data until it was requested, but it looks like that just doesn't
368    work at all unless the selection owner and requestor are in different
369    processes.  From reading the Motif source, it looks like they never
370    even considered having two widgets in the same application transfer
371    data between each other using "by-name" clipboard values.  What a
372    bunch of fuckups.
373  */
374 static void
375 motif_clipboard_cb (Widget widget, int *data_id, int *private_id, int *reason)
376 {
377   switch (*reason)
378     {
379     case XmCR_CLIPBOARD_DATA_REQUEST:
380       {
381         Display *dpy = XtDisplay (widget);
382         Window window = (Window) *private_id;
383         Lisp_Object selection = select_convert_out (QCLIPBOARD, Qnil, Qnil);
384
385         /* Whichever lazy git wrote this originally just called ABORT()
386            when anything didn't go their way... */
387
388         /* Try some other text types */
389         if (NILP (selection))
390           selection = select_convert_out (QCLIPBOARD, QSTRING, Qnil);
391         if (NILP (selection))
392           selection = select_convert_out (QCLIPBOARD, QTEXT, Qnil);
393         if (NILP (selection))
394           selection = select_convert_out (QCLIPBOARD, QCOMPOUND_TEXT, Qnil);
395
396         if (CONSP (selection) && SYMBOLP (XCAR (selection))
397             && (EQ (XCAR (selection), QSTRING)
398                 || EQ (XCAR (selection), QTEXT)
399                 || EQ (XCAR (selection), QCOMPOUND_TEXT)))
400           selection = XCDR (selection);
401
402         if (NILP (selection))
403           signal_error (Qselection_conversion_error,
404                         build_string ("no selection"));
405
406         if (!STRINGP (selection))
407           signal_error (Qselection_conversion_error,
408                         build_string ("couldn't convert selection to string"));
409
410
411         XmClipboardCopyByName (dpy, window, *data_id,
412                                (char *) XSTRING_DATA (selection),
413                                XSTRING_LENGTH (selection) + 1,
414                                0);
415       }
416       break;
417     case XmCR_CLIPBOARD_DATA_DELETE:
418     default:
419       /* don't need to free anything */
420       break;
421     }
422 }
423 # endif /* MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
424 #endif /* MOTIF_CLIPBOARDS */
425
426
427
428
429 /* Send a SelectionNotify event to the requestor with property=None, meaning
430    we were unable to do what they wanted.
431  */
432 static void
433 x_decline_selection_request (XSelectionRequestEvent *event)
434 {
435   XSelectionEvent reply;
436   reply.type      = SelectionNotify;
437   reply.display   = event->display;
438   reply.requestor = event->requestor;
439   reply.selection = event->selection;
440   reply.time      = event->time;
441   reply.target    = event->target;
442   reply.property  = None;
443
444   XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
445   XFlush (reply.display);
446 }
447
448
449 /* Used as an unwind-protect clause so that, if a selection-converter signals
450    an error, we tell the requestor that we were unable to do what they wanted
451    before we throw to top-level or go into the debugger or whatever.
452  */
453 static Lisp_Object
454 x_selection_request_lisp_error (Lisp_Object closure)
455 {
456   XSelectionRequestEvent *event = (XSelectionRequestEvent *)
457     get_opaque_ptr (closure);
458
459   free_opaque_ptr (closure);
460   if (event->type == 0) /* we set this to mean "completed normally" */
461     return Qnil;
462   x_decline_selection_request (event);
463   return Qnil;
464 }
465
466
467 /* Convert our selection to the requested type, and put that data where the
468    requestor wants it.  Then tell them whether we've succeeded.
469  */
470 static void
471 x_reply_selection_request (XSelectionRequestEvent *event, int format,
472                            unsigned char *data, int size, Atom type)
473 {
474   /* This function can GC */
475   XSelectionEvent reply;
476   Display *display = event->display;
477   struct device *d = get_device_from_display (display);
478   Window window = event->requestor;
479   int bytes_remaining;
480   int format_bytes = format/8;
481   int max_bytes = SELECTION_QUANTUM (display);
482   if (max_bytes > MAX_SELECTION_QUANTUM) max_bytes = MAX_SELECTION_QUANTUM;
483
484   reply.type      = SelectionNotify;
485   reply.display   = display;
486   reply.requestor = window;
487   reply.selection = event->selection;
488   reply.time      = event->time;
489   reply.target    = event->target;
490   reply.property  = (event->property == None ? event->target : event->property);
491
492   /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
493
494   /* Store the data on the requested property.
495      If the selection is large, only store the first N bytes of it.
496    */
497   bytes_remaining = size * format_bytes;
498   if (bytes_remaining <= max_bytes)
499     {
500       /* Send all the data at once, with minimal handshaking. */
501 #if 0
502       stderr_out ("\nStoring all %d\n", bytes_remaining);
503 #endif
504       XChangeProperty (display, window, reply.property, type, format,
505                        PropModeReplace, data, size);
506       /* At this point, the selection was successfully stored; ack it. */
507       XSendEvent (display, window, False, 0L, (XEvent *) &reply);
508       XFlush (display);
509     }
510   else
511     {
512 #ifndef HAVE_XTREGISTERDRAWABLE
513       invalid_operation("Copying that much data requires X11R6.", Qunbound);
514 #else
515       /* Send an INCR selection. */
516       int prop_id;
517       Widget widget = FRAME_X_TEXT_WIDGET (XFRAME(DEVICE_SELECTED_FRAME(d)));
518
519       if (x_window_to_frame (d, window)) /* #### debug */
520         error ("attempt to transfer an INCR to ourself!");
521 #if 0
522       stderr_out ("\nINCR %d\n", bytes_remaining);
523 #endif
524       /* Tell Xt not to drop PropertyNotify events that arrive for the
525          target window, rather, pass them to us. This would be a hack, but
526          the Xt selection routines are broken for our purposes--we can't
527          pass them callbacks from Lisp, for example. Let's call it a
528          workaround.
529  
530          The call to wait_for_property_change means we can break out of that
531          function, switch to another frame on the same display (which will
532          be another Xt widget), select a huge amount of text, and have the
533          same (foreign) app ask for another incremental selection
534          transfer. Programming like X11 made sense, would mean that, in that
535          case, XtRegisterDrawable is called twice with different widgets.
536  
537          Since the results of calling XtRegisterDrawable when the drawable
538          is already registered with another widget are undefined, we want to
539          avoid that--so, only call it when XtWindowToWidget returns NULL,
540          which it will only do with a valid Window if it's not already
541          registered. */
542       if (NULL == XtWindowToWidget(display, window))
543       {
544         XtRegisterDrawable(display, (Drawable)window, widget);
545       }
546       
547       prop_id = expect_property_change (display, window, reply.property,
548                                         PropertyDelete);
549
550       XChangeProperty (display, window, reply.property, DEVICE_XATOM_INCR (d),
551                        32, PropModeReplace, (unsigned char *)
552                        &bytes_remaining, 1);
553       XSelectInput (display, window, PropertyChangeMask);
554       /* Tell 'em the INCR data is there... */
555       XSendEvent (display, window, False, 0L, (XEvent *) &reply);
556       XFlush (display);
557
558       /* First, wait for the requestor to ack by deleting the property.
559          This can run random lisp code (process handlers) or signal.
560        */
561       wait_for_property_change (prop_id);
562
563       while (bytes_remaining)
564         {
565           int i = ((bytes_remaining < max_bytes)
566                    ? bytes_remaining
567                    : max_bytes);
568           prop_id = expect_property_change (display, window, reply.property,
569                                             PropertyDelete);
570 #if 0
571           stderr_out ("  INCR adding %d\n", i);
572 #endif
573           /* Append the next chunk of data to the property. */
574           XChangeProperty (display, window, reply.property, type, format,
575                            PropModeAppend, data, i / format_bytes);
576           bytes_remaining -= i;
577           data += i;
578
579           /* Now wait for the requestor to ack this chunk by deleting the
580              property.   This can run random lisp code or signal.
581            */
582           wait_for_property_change (prop_id);
583         }
584       /* Now write a zero-length chunk to the property to tell the requestor
585          that we're done. */
586 #if 0
587       stderr_out ("  INCR done\n");
588 #endif
589       if (! waiting_for_other_props_on_window (display, window))
590       {
591         XSelectInput (display, window, 0L);
592         XtUnregisterDrawable(display, (Drawable)window);
593       }
594
595       XChangeProperty (display, window, reply.property, type, format,
596                        PropModeReplace, data, 0);
597 #endif /* HAVE_XTREGISTERDRAWABLE */
598     }
599 }
600
601
602
603 /* Called from the event-loop in response to a SelectionRequest event.
604  */
605 void
606 x_handle_selection_request (XSelectionRequestEvent *event)
607 {
608   /* This function can GC */
609   struct gcpro gcpro1, gcpro2;
610   Lisp_Object temp_obj;
611   Lisp_Object selection_symbol;
612   Lisp_Object target_symbol = Qnil;
613   Lisp_Object converted_selection = Qnil;
614   Time local_selection_time;
615   Lisp_Object successful_p = Qnil;
616   int count;
617   struct device *d = get_device_from_display (event->display);
618
619   GCPRO2 (converted_selection, target_symbol);
620
621   selection_symbol = x_atom_to_symbol (d, event->selection);
622   target_symbol = x_atom_to_symbol (d, event->target);
623
624 #if 0 /* #### MULTIPLE doesn't work yet */
625   if (EQ (target_symbol, QMULTIPLE))
626     target_symbol = fetch_multiple_target (event);
627 #endif
628
629   temp_obj = Fget_selection_timestamp (selection_symbol);
630
631   if (NILP (temp_obj))
632     {
633       /* We don't appear to have the selection. */
634       x_decline_selection_request (event);
635
636       goto DONE_LABEL;
637     }
638
639   local_selection_time = * (Time *) XOPAQUE_DATA (temp_obj);
640
641   if (event->time != CurrentTime &&
642       local_selection_time > event->time)
643     {
644       /* Someone asked for the selection, and we have one, but not the one
645          they're looking for. */
646       x_decline_selection_request (event);
647       goto DONE_LABEL;
648     }
649
650   converted_selection = select_convert_out (selection_symbol,
651                                             target_symbol, Qnil);
652
653   /* #### Is this the right thing to do? I'm no X expert. -- ajh */
654   if (NILP (converted_selection))
655     {
656       /* We don't appear to have a selection in that data type. */
657       x_decline_selection_request (event);
658       goto DONE_LABEL;
659     }
660
661   count = specpdl_depth ();
662   record_unwind_protect (x_selection_request_lisp_error,
663                          make_opaque_ptr (event));
664
665   {
666     unsigned char *data;
667     unsigned int size;
668     int format;
669     Atom type;
670     lisp_data_to_selection_data (d, converted_selection,
671                                  &data, &type, &size, &format);
672
673     x_reply_selection_request (event, format, data, size, type);
674     successful_p = Qt;
675     /* Tell x_selection_request_lisp_error() it's cool. */
676     event->type = 0;
677     xfree (data);
678   }
679
680   unbind_to (count, Qnil);
681
682  DONE_LABEL:
683
684   UNGCPRO;
685
686   /* Let random lisp code notice that the selection has been asked for. */
687   {
688     Lisp_Object val = Vx_sent_selection_hooks;
689     if (!UNBOUNDP (val) && !NILP (val))
690       {
691         Lisp_Object rest;
692         if (CONSP (val) && !EQ (XCAR (val), Qlambda))
693           for (rest = val; !NILP (rest); rest = Fcdr (rest))
694             call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
695         else
696           call3 (val, selection_symbol, target_symbol, successful_p);
697       }
698   }
699 }
700
701
702 /* Called from the event-loop in response to a SelectionClear event.
703  */
704 void
705 x_handle_selection_clear (XSelectionClearEvent *event)
706 {
707   Display *display = event->display;
708   struct device *d = get_device_from_display (display);
709   Atom selection = event->selection;
710   Time changed_owner_time = event->time;
711
712   Lisp_Object selection_symbol, local_selection_time_lisp;
713   Time local_selection_time;
714
715   selection_symbol = x_atom_to_symbol (d, selection);
716
717   local_selection_time_lisp = Fget_selection_timestamp (selection_symbol);
718
719   /* We don't own the selection, so that's fine. */
720   if (NILP (local_selection_time_lisp))
721     return;
722
723   local_selection_time = * (Time *) XOPAQUE_DATA (local_selection_time_lisp);
724
725   /* This SelectionClear is for a selection that we no longer own, so we can
726      disregard it.  (That is, we have reasserted the selection since this
727      request was generated.)
728    */
729   if (changed_owner_time != CurrentTime &&
730       local_selection_time > changed_owner_time)
731     return;
732
733   handle_selection_clear (selection_symbol);
734 }
735
736 \f
737 /* This stuff is so that INCR selections are reentrant (that is, so we can
738    be servicing multiple INCR selection requests simultaneously).  I haven't
739    actually tested that yet.
740  */
741
742 static int prop_location_tick;
743
744 static struct prop_location {
745   int tick;
746   Display *display;
747   Window window;
748   Atom property;
749   int desired_state;
750   struct prop_location *next;
751 } *for_whom_the_bell_tolls;
752
753
754 static int
755 property_deleted_p (void *tick)
756 {
757   struct prop_location *rest = for_whom_the_bell_tolls;
758   while (rest)
759     if (rest->tick == (long) tick)
760       return 0;
761     else
762       rest = rest->next;
763   return 1;
764 }
765
766 static int
767 waiting_for_other_props_on_window (Display *display, Window window)
768 {
769   struct prop_location *rest = for_whom_the_bell_tolls;
770   while (rest)
771     if (rest->display == display && rest->window == window)
772       return 1;
773     else
774       rest = rest->next;
775   return 0;
776 }
777
778
779 static int
780 expect_property_change (Display *display, Window window,
781                         Atom property, int state)
782 {
783   struct prop_location *pl = xnew (struct prop_location);
784   pl->tick = ++prop_location_tick;
785   pl->display = display;
786   pl->window = window;
787   pl->property = property;
788   pl->desired_state = state;
789   pl->next = for_whom_the_bell_tolls;
790   for_whom_the_bell_tolls = pl;
791   return pl->tick;
792 }
793
794 static void
795 unexpect_property_change (int tick)
796 {
797   struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
798   while (rest)
799     {
800       if (rest->tick == tick)
801         {
802           if (prev)
803             prev->next = rest->next;
804           else
805             for_whom_the_bell_tolls = rest->next;
806           xfree (rest);
807           return;
808         }
809       prev = rest;
810       rest = rest->next;
811     }
812 }
813
814 static void
815 wait_for_property_change (long tick)
816 {
817   /* This function can GC */
818   wait_delaying_user_input (property_deleted_p, (void *) tick);
819 }
820
821
822 /* Called from the event-loop in response to a PropertyNotify event.
823  */
824 void
825 x_handle_property_notify (XPropertyEvent *event)
826 {
827   struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
828   while (rest)
829     {
830       if (rest->property == event->atom &&
831           rest->window == event->window &&
832           rest->display == event->display &&
833           rest->desired_state == event->state)
834         {
835 #if 0
836           stderr_out ("Saw expected prop-%s on %s\n",
837                    (event->state == PropertyDelete ? "delete" : "change"),
838                       (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name);
839 #endif
840           if (prev)
841             prev->next = rest->next;
842           else
843             for_whom_the_bell_tolls = rest->next;
844           xfree (rest);
845           return;
846         }
847       prev = rest;
848       rest = rest->next;
849     }
850 #if 0
851   stderr_out ("Saw UNexpected prop-%s on %s\n",
852            (event->state == PropertyDelete ? "delete" : "change"),
853            (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name));
854 #endif
855 }
856
857
858 \f
859 #if 0 /* #### MULTIPLE doesn't work yet */
860
861 static Lisp_Object
862 fetch_multiple_target (XSelectionRequestEvent *event)
863 {
864   /* This function can GC */
865   Display *display = event->display;
866   Window window = event->requestor;
867   Atom target = event->target;
868   Atom selection_atom = event->selection;
869   int result;
870
871   return
872     Fcons (QMULTIPLE,
873            x_get_window_property_as_lisp_data (display, window, target,
874                                                QMULTIPLE,
875                                                selection_atom));
876 }
877
878 static Lisp_Object
879 copy_multiple_data (Lisp_Object obj)
880 {
881   Lisp_Object vec;
882   int i;
883   int len;
884   if (CONSP (obj))
885     return Fcons (XCAR (obj), copy_multiple_data (XCDR (obj)));
886
887   CHECK_VECTOR (obj);
888   len = XVECTOR_LENGTH (obj);
889   vec = make_vector (len, Qnil);
890   for (i = 0; i < len; i++)
891     {
892       Lisp_Object vec2 = XVECTOR_DATA (obj) [i];
893       CHECK_VECTOR (vec2);
894       if (XVECTOR_LENGTH (vec2) != 2)
895         signal_error (Qerror, list2 (build_string
896                                      ("vectors must be of length 2"),
897                                      vec2));
898       XVECTOR_DATA (vec) [i] = make_vector (2, Qnil);
899       XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [0] = XVECTOR_DATA (vec2) [0];
900       XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [1] = XVECTOR_DATA (vec2) [1];
901     }
902   return vec;
903 }
904
905 #endif /* 0 */
906
907 \f
908 static Window reading_selection_reply;
909 static Atom reading_which_selection;
910 static int selection_reply_timed_out;
911
912 static int
913 selection_reply_done (void *ignore)
914 {
915   return !reading_selection_reply;
916 }
917
918 static Lisp_Object Qx_selection_reply_timeout_internal;
919
920 DEFUN ("x-selection-reply-timeout-internal", Fx_selection_reply_timeout_internal,
921        1, 1, 0, /*
922 */
923        (arg))
924 {
925   selection_reply_timed_out = 1;
926   reading_selection_reply = 0;
927   return Qnil;
928 }
929
930
931 /* Do protocol to read selection-data from the server.
932    Converts this to lisp data and returns it.
933  */
934 static Lisp_Object
935 x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
936 {
937   /* This function can GC */
938   struct device *d = decode_x_device (Qnil);
939   Display *display = DEVICE_X_DISPLAY (d);
940   struct frame *sel_frame = selected_frame ();
941   Window requestor_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
942   Time requestor_time = DEVICE_X_MOUSE_TIMESTAMP (d);
943   Atom target_property = DEVICE_XATOM_EMACS_TMP (d);
944   Atom selection_atom = symbol_to_x_atom (d, selection_symbol, 0);
945   int speccount;
946   Atom type_atom = symbol_to_x_atom (d, (CONSP (target_type) ?
947                                          XCAR (target_type) : target_type), 0);
948
949   XConvertSelection (display, selection_atom, type_atom, target_property,
950                      requestor_window, requestor_time);
951
952   /* Block until the reply has been read. */
953   reading_selection_reply = requestor_window;
954   reading_which_selection = selection_atom;
955   selection_reply_timed_out = 0;
956
957   speccount = specpdl_depth ();
958
959   /* add a timeout handler */
960   if (x_selection_timeout > 0)
961     {
962       Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout),
963                                      Qx_selection_reply_timeout_internal,
964                                      Qnil, Qnil);
965       record_unwind_protect (Fdisable_timeout, id);
966     }
967
968   /* This is ^Gable */
969   wait_delaying_user_input (selection_reply_done, 0);
970
971   if (selection_reply_timed_out)
972     error ("timed out waiting for reply from selection owner");
973
974   unbind_to (speccount, Qnil);
975
976   /* otherwise, the selection is waiting for us on the requested property. */
977
978   return select_convert_in (selection_symbol,
979                             target_type,
980                             x_get_window_property_as_lisp_data(display,
981                                                                requestor_window,
982                                                                target_property,
983                                                                target_type,
984                                                                selection_atom));
985 }
986
987
988 static void
989 x_get_window_property (Display *display, Window window, Atom property,
990                        Extbyte **data_ret, int *bytes_ret,
991                        Atom *actual_type_ret, int *actual_format_ret,
992                        unsigned long *actual_size_ret, int delete_p)
993 {
994   size_t total_size;
995   unsigned long bytes_remaining;
996   int offset = 0;
997   unsigned char *tmp_data = 0;
998   int result;
999   int buffer_size = SELECTION_QUANTUM (display);
1000   if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
1001
1002   /* First probe the thing to find out how big it is. */
1003   result = XGetWindowProperty (display, window, property,
1004                                0, 0, False, AnyPropertyType,
1005                                actual_type_ret, actual_format_ret,
1006                                actual_size_ret,
1007                                &bytes_remaining, &tmp_data);
1008   if (result != Success)
1009     {
1010       *data_ret = 0;
1011       *bytes_ret = 0;
1012       return;
1013     }
1014   XFree ((char *) tmp_data);
1015
1016   if (*actual_type_ret == None || *actual_format_ret == 0)
1017     {
1018       if (delete_p) XDeleteProperty (display, window, property);
1019       *data_ret = 0;
1020       *bytes_ret = 0;
1021       return;
1022     }
1023
1024   total_size = bytes_remaining + 1;
1025   *data_ret = (Extbyte *) xmalloc (total_size);
1026
1027   /* Now read, until we've gotten it all. */
1028   while (bytes_remaining)
1029     {
1030 #if 0
1031       int last = bytes_remaining;
1032 #endif
1033       result =
1034         XGetWindowProperty (display, window, property,
1035                             offset/4, buffer_size/4,
1036                             (delete_p ? True : False),
1037                             AnyPropertyType,
1038                             actual_type_ret, actual_format_ret,
1039                             actual_size_ret, &bytes_remaining, &tmp_data);
1040 #if 0
1041       stderr_out ("<< read %d\n", last-bytes_remaining);
1042 #endif
1043       /* If this doesn't return Success at this point, it means that
1044          some clod deleted the selection while we were in the midst of
1045          reading it.  Deal with that, I guess....
1046        */
1047       if (result != Success) break;
1048       *actual_size_ret *= *actual_format_ret / 8;
1049       memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
1050       offset += *actual_size_ret;
1051       XFree ((char *) tmp_data);
1052     }
1053   *bytes_ret = offset;
1054 }
1055
1056
1057 static void
1058 receive_incremental_selection (Display *display, Window window, Atom property,
1059                                /* this one is for error messages only */
1060                                Lisp_Object target_type,
1061                                unsigned int min_size_bytes,
1062                                Extbyte **data_ret, int *size_bytes_ret,
1063                                Atom *type_ret, int *format_ret,
1064                                unsigned long *size_ret)
1065 {
1066   /* This function can GC */
1067   int offset = 0;
1068   int prop_id;
1069   *size_bytes_ret = min_size_bytes;
1070   *data_ret = (Extbyte *) xmalloc (*size_bytes_ret);
1071 #if 0
1072   stderr_out ("\nread INCR %d\n", min_size_bytes);
1073 #endif
1074   /* At this point, we have read an INCR property, and deleted it (which
1075      is how we ack its receipt: the sending window will be selecting
1076      PropertyNotify events on our window to notice this).
1077
1078      Now, we must loop, waiting for the sending window to put a value on
1079      that property, then reading the property, then deleting it to ack.
1080      We are done when the sender places a property of length 0.
1081    */
1082   prop_id = expect_property_change (display, window, property,
1083                                     PropertyNewValue);
1084   while (1)
1085     {
1086       Extbyte *tmp_data;
1087       int tmp_size_bytes;
1088       wait_for_property_change (prop_id);
1089       /* expect it again immediately, because x_get_window_property may
1090          .. no it won't, I don't get it.
1091          .. Ok, I get it now, the Xt code that implements INCR is broken.
1092        */
1093       prop_id = expect_property_change (display, window, property,
1094                                         PropertyNewValue);
1095       x_get_window_property (display, window, property,
1096                              &tmp_data, &tmp_size_bytes,
1097                              type_ret, format_ret, size_ret, 1);
1098
1099       if (tmp_size_bytes == 0) /* we're done */
1100         {
1101 #if 0
1102           stderr_out ("  read INCR done\n");
1103 #endif
1104           unexpect_property_change (prop_id);
1105           if (tmp_data) xfree (tmp_data);
1106           break;
1107         }
1108 #if 0
1109       stderr_out ("  read INCR %d\n", tmp_size_bytes);
1110 #endif
1111       if (*size_bytes_ret < offset + tmp_size_bytes)
1112         {
1113 #if 0
1114           stderr_out ("  read INCR realloc %d -> %d\n",
1115                    *size_bytes_ret, offset + tmp_size_bytes);
1116 #endif
1117           *size_bytes_ret = offset + tmp_size_bytes;
1118           *data_ret = (Extbyte *) xrealloc (*data_ret, *size_bytes_ret);
1119         }
1120       memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
1121       offset += tmp_size_bytes;
1122       xfree (tmp_data);
1123     }
1124 }
1125
1126
1127 static Lisp_Object
1128 x_get_window_property_as_lisp_data (Display *display,
1129                                     Window window,
1130                                     Atom property,
1131                                     /* next two for error messages only */
1132                                     Lisp_Object target_type,
1133                                     Atom selection_atom)
1134 {
1135   /* This function can GC */
1136   Atom actual_type;
1137   int actual_format;
1138   unsigned long actual_size;
1139   Extbyte *data = NULL;
1140   int bytes = 0;
1141   Lisp_Object val;
1142   struct device *d = get_device_from_display (display);
1143
1144   x_get_window_property (display, window, property, &data, &bytes,
1145                          &actual_type, &actual_format, &actual_size, 1);
1146   if (! data)
1147     {
1148       if (XGetSelectionOwner (display, selection_atom))
1149         /* there is a selection owner */
1150         signal_error
1151           (Qselection_conversion_error,
1152            Fcons (build_string ("selection owner couldn't convert"),
1153                   Fcons (x_atom_to_symbol (d, selection_atom),
1154                          actual_type ?
1155                          list2 (target_type, x_atom_to_symbol (d, actual_type)) :
1156                          list1 (target_type))));
1157       else
1158         signal_error (Qerror,
1159                       list2 (build_string ("no selection"),
1160                              x_atom_to_symbol (d, selection_atom)));
1161     }
1162
1163   if (actual_type == DEVICE_XATOM_INCR (d))
1164     {
1165       /* Ok, that data wasn't *the* data, it was just the beginning. */
1166
1167       unsigned int min_size_bytes = * ((unsigned int *) data);
1168       xfree (data);
1169       receive_incremental_selection (display, window, property, target_type,
1170                                      min_size_bytes, &data, &bytes,
1171                                      &actual_type, &actual_format,
1172                                      &actual_size);
1173     }
1174
1175   /* It's been read.  Now convert it to a lisp object in some semi-rational
1176      manner. */
1177   val = selection_data_to_lisp_data (d, data, bytes,
1178                                      actual_type, actual_format);
1179
1180   xfree (data);
1181   return val;
1182 }
1183 \f
1184 /* #### These are going to move into Lisp code(!) with the aid of
1185         some new functions I'm working on - ajh */
1186
1187 /* These functions convert from the selection data read from the server into
1188    something that we can use from elisp, and vice versa.
1189
1190         Type:   Format: Size:           Elisp Type:
1191         -----   ------- -----           -----------
1192         *       8       *               String
1193         ATOM    32      1               Symbol
1194         ATOM    32      > 1             Vector of Symbols
1195         *       16      1               Integer
1196         *       16      > 1             Vector of Integers
1197         *       32      1               if <=16 bits: Integer
1198                                         if > 16 bits: Cons of top16, bot16
1199         *       32      > 1             Vector of the above
1200
1201    When converting a Lisp number to C, it is assumed to be of format 16 if
1202    it is an integer, and of format 32 if it is a cons of two integers.
1203
1204    When converting a vector of numbers from Elisp to C, it is assumed to be
1205    of format 16 if every element in the vector is an integer, and is assumed
1206    to be of format 32 if any element is a cons of two integers.
1207
1208    When converting an object to C, it may be of the form (SYMBOL . <data>)
1209    where SYMBOL is what we should claim that the type is.  Format and
1210    representation are as above.
1211
1212    NOTE: Under Mule, when someone shoves us a string without a type, we
1213    set the type to 'COMPOUND_TEXT and automatically convert to Compound
1214    Text.  If the string has a type, we assume that the user wants the
1215    data sent as-is so we just do "binary" conversion.
1216  */
1217
1218
1219 static Lisp_Object
1220 selection_data_to_lisp_data (struct device *d,
1221                              Extbyte *data,
1222                              size_t size,
1223                              Atom type,
1224                              int format)
1225 {
1226   if (type == DEVICE_XATOM_NULL (d))
1227     return QNULL;
1228
1229   /* Convert any 8-bit data to a string, for compactness. */
1230   else if (format == 8)
1231     return make_ext_string (data, size,
1232                             type == DEVICE_XATOM_TEXT (d) ||
1233                             type == DEVICE_XATOM_COMPOUND_TEXT (d)
1234                             ? Qctext : Qbinary);
1235
1236   /* Convert a single atom to a Lisp Symbol.
1237      Convert a set of atoms to a vector of symbols. */
1238   else if (type == XA_ATOM)
1239     {
1240       if (size == sizeof (Atom))
1241         return x_atom_to_symbol (d, *((Atom *) data));
1242       else
1243         {
1244           int i;
1245           int len = size / sizeof (Atom);
1246           Lisp_Object v = Fmake_vector (make_int (len), Qzero);
1247           for (i = 0; i < len; i++)
1248             Faset (v, make_int (i), x_atom_to_symbol (d, ((Atom *) data) [i]));
1249           return v;
1250         }
1251     }
1252
1253   /* Convert a single 16 or small 32 bit number to a Lisp Int.
1254      If the number is > 16 bits, convert it to a cons of integers,
1255      16 bits in each half.
1256    */
1257   else if (format == 32 && size == sizeof (long))
1258     return word_to_lisp (((unsigned long *) data) [0]);
1259   else if (format == 16 && size == sizeof (short))
1260     return make_int ((int) (((unsigned short *) data) [0]));
1261
1262   /* Convert any other kind of data to a vector of numbers, represented
1263      as above (as an integer, or a cons of two 16 bit integers).
1264
1265      #### Perhaps we should return the actual type to lisp as well.
1266
1267         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1268         ==> [4 4]
1269
1270      and perhaps it should be
1271
1272         (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1273         ==> (SPAN . [4 4])
1274
1275      Right now the fact that the return type was SPAN is discarded before
1276      lisp code gets to see it.
1277    */
1278   else if (format == 16)
1279     {
1280       int i;
1281       Lisp_Object v = make_vector (size / 4, Qzero);
1282       for (i = 0; i < (int) size / 4; i++)
1283         {
1284           int j = (int) ((unsigned short *) data) [i];
1285           Faset (v, make_int (i), make_int (j));
1286         }
1287       return v;
1288     }
1289   else
1290     {
1291       int i;
1292       Lisp_Object v = make_vector (size / 4, Qzero);
1293       for (i = 0; i < (int) size / 4; i++)
1294         {
1295           unsigned long j = ((unsigned long *) data) [i];
1296           Faset (v, make_int (i), word_to_lisp (j));
1297         }
1298       return v;
1299     }
1300 }
1301
1302
1303 static void
1304 lisp_data_to_selection_data (struct device *d,
1305                              Lisp_Object obj,
1306                              unsigned char **data_ret,
1307                              Atom *type_ret,
1308                              unsigned int *size_ret,
1309                              int *format_ret)
1310 {
1311   Lisp_Object type = Qnil;
1312
1313   if (CONSP (obj) && SYMBOLP (XCAR (obj)))
1314     {
1315       type = XCAR (obj);
1316       obj = XCDR (obj);
1317       if (CONSP (obj) && NILP (XCDR (obj)))
1318         obj = XCAR (obj);
1319     }
1320
1321   if (EQ (obj, QNULL) || (EQ (type, QNULL)))
1322     {                           /* This is not the same as declining */
1323       *format_ret = 32;
1324       *size_ret = 0;
1325       *data_ret = 0;
1326       type = QNULL;
1327     }
1328   else if (STRINGP (obj))
1329     {
1330       const Extbyte *extval;
1331       Extcount extvallen;
1332
1333       TO_EXTERNAL_FORMAT (LISP_STRING, obj,
1334                           ALLOCA, (extval, extvallen),
1335                           (NILP (type) ? Qctext : Qbinary));
1336       *format_ret = 8;
1337       *size_ret = extvallen;
1338       *data_ret = (unsigned char *) xmalloc (*size_ret);
1339       memcpy (*data_ret, extval, *size_ret);
1340 #ifdef MULE
1341       if (NILP (type)) type = QCOMPOUND_TEXT;
1342 #else
1343       if (NILP (type)) type = QSTRING;
1344 #endif
1345     }
1346   else if (CHARP (obj))
1347     {
1348       Bufbyte buf[MAX_EMCHAR_LEN];
1349       Bytecount len;
1350       const Extbyte *extval;
1351       Extcount extvallen;
1352
1353       *format_ret = 8;
1354       len = set_charptr_emchar (buf, XCHAR (obj));
1355       TO_EXTERNAL_FORMAT (DATA, (buf, len),
1356                           ALLOCA, (extval, extvallen),
1357                           Qctext);
1358       *size_ret = extvallen;
1359       *data_ret = (unsigned char *) xmalloc (*size_ret);
1360       memcpy (*data_ret, extval, *size_ret);
1361 #ifdef MULE
1362       if (NILP (type)) type = QCOMPOUND_TEXT;
1363 #else
1364       if (NILP (type)) type = QSTRING;
1365 #endif
1366     }
1367   else if (SYMBOLP (obj))
1368     {
1369       *format_ret = 32;
1370       *size_ret = 1;
1371       *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
1372       (*data_ret) [sizeof (Atom)] = 0;
1373       (*(Atom **) data_ret) [0] = symbol_to_x_atom (d, obj, 0);
1374       if (NILP (type)) type = QATOM;
1375     }
1376   else if (INTP (obj) &&
1377            XINT (obj) <= 0x7FFF &&
1378            XINT (obj) >= -0x8000)
1379     {
1380       *format_ret = 16;
1381       *size_ret = 1;
1382       *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
1383       (*data_ret) [sizeof (short)] = 0;
1384       (*(short **) data_ret) [0] = (short) XINT (obj);
1385       if (NILP (type)) type = QINTEGER;
1386     }
1387   else if (INTP (obj) || CONSP (obj))
1388     {
1389       *format_ret = 32;
1390       *size_ret = 1;
1391       *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
1392       (*data_ret) [sizeof (long)] = 0;
1393       (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
1394       if (NILP (type)) type = QINTEGER;
1395     }
1396   else if (VECTORP (obj))
1397     {
1398       /* Lisp Vectors may represent a set of ATOMs;
1399          a set of 16 or 32 bit INTEGERs;
1400          or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1401        */
1402       int i;
1403
1404       if (SYMBOLP (XVECTOR_DATA (obj) [0]))
1405         /* This vector is an ATOM set */
1406         {
1407           if (NILP (type)) type = QATOM;
1408           *size_ret = XVECTOR_LENGTH (obj);
1409           *format_ret = 32;
1410           *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
1411           for (i = 0; i < (int) (*size_ret); i++)
1412             if (SYMBOLP (XVECTOR_DATA (obj) [i]))
1413               (*(Atom **) data_ret) [i] =
1414                 symbol_to_x_atom (d, XVECTOR_DATA (obj) [i], 0);
1415             else
1416               signal_error (Qerror, /* Qselection_error */
1417                             list2 (build_string
1418                    ("all elements of the vector must be of the same type"),
1419                                    obj));
1420         }
1421 #if 0 /* #### MULTIPLE doesn't work yet */
1422       else if (VECTORP (XVECTOR_DATA (obj) [0]))
1423         /* This vector is an ATOM_PAIR set */
1424         {
1425           if (NILP (type)) type = QATOM_PAIR;
1426           *size_ret = XVECTOR_LENGTH (obj);
1427           *format_ret = 32;
1428           *data_ret = (unsigned char *)
1429             xmalloc ((*size_ret) * sizeof (Atom) * 2);
1430           for (i = 0; i < *size_ret; i++)
1431             if (VECTORP (XVECTOR_DATA (obj) [i]))
1432               {
1433                 Lisp_Object pair = XVECTOR_DATA (obj) [i];
1434                 if (XVECTOR_LENGTH (pair) != 2)
1435                   signal_error (Qerror,
1436                                 list2 (build_string
1437        ("elements of the vector must be vectors of exactly two elements"),
1438                                   pair));
1439
1440                 (*(Atom **) data_ret) [i * 2] =
1441                   symbol_to_x_atom (d, XVECTOR_DATA (pair) [0], 0);
1442                 (*(Atom **) data_ret) [(i * 2) + 1] =
1443                   symbol_to_x_atom (d, XVECTOR_DATA (pair) [1], 0);
1444               }
1445             else
1446               signal_error (Qerror,
1447                             list2 (build_string
1448                    ("all elements of the vector must be of the same type"),
1449                                    obj));
1450         }
1451 #endif
1452       else
1453         /* This vector is an INTEGER set, or something like it */
1454         {
1455           *size_ret = XVECTOR_LENGTH (obj);
1456           if (NILP (type)) type = QINTEGER;
1457           *format_ret = 16;
1458           for (i = 0; i < (int) (*size_ret); i++)
1459             if (CONSP (XVECTOR_DATA (obj) [i]))
1460               *format_ret = 32;
1461             else if (!INTP (XVECTOR_DATA (obj) [i]))
1462               signal_error (Qerror, /* Qselection_error */
1463                             list2 (build_string
1464         ("all elements of the vector must be integers or conses of integers"),
1465                                    obj));
1466
1467           *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
1468           for (i = 0; i < (int) (*size_ret); i++)
1469             if (*format_ret == 32)
1470               (*((unsigned long **) data_ret)) [i] =
1471                 lisp_to_word (XVECTOR_DATA (obj) [i]);
1472             else
1473               (*((unsigned short **) data_ret)) [i] =
1474                 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
1475         }
1476     }
1477   else
1478     signal_error (Qerror, /* Qselection_error */
1479                   list2 (build_string ("unrecognized selection data"),
1480                          obj));
1481
1482   *type_ret = symbol_to_x_atom (d, type, 0);
1483 }
1484
1485
1486 \f
1487 /* Called from the event loop to handle SelectionNotify events.
1488    I don't think this needs to be reentrant.
1489  */
1490 void
1491 x_handle_selection_notify (XSelectionEvent *event)
1492 {
1493   if (! reading_selection_reply)
1494     message ("received an unexpected SelectionNotify event");
1495   else if (event->requestor != reading_selection_reply)
1496     message ("received a SelectionNotify event for the wrong window");
1497   else if (event->selection != reading_which_selection)
1498     message ("received the wrong selection type in SelectionNotify!");
1499   else
1500     reading_selection_reply = 0; /* we're done now. */
1501 }
1502
1503 static void
1504 x_disown_selection (Lisp_Object selection, Lisp_Object timeval)
1505 {
1506   struct device *d = decode_x_device (Qnil);
1507   Display *display = DEVICE_X_DISPLAY (d);
1508   Time timestamp;
1509   Atom selection_atom;
1510
1511   CHECK_SYMBOL (selection);
1512   if (NILP (timeval))
1513     timestamp = DEVICE_X_MOUSE_TIMESTAMP (d);
1514   else
1515     {
1516       /* #### This is bogus.  See the comment above about problems
1517          on OSF/1 and DEC Alphas.  Yet another reason why it sucks
1518          to have the implementation (i.e. cons of two 16-bit
1519          integers) exposed. */
1520       time_t the_time;
1521       lisp_to_time (timeval, &the_time);
1522       timestamp = (Time) the_time;
1523     }
1524
1525   selection_atom = symbol_to_x_atom (d, selection, 0);
1526
1527   XSetSelectionOwner (display, selection_atom, None, timestamp);
1528 }
1529
1530 static Lisp_Object
1531 x_selection_exists_p (Lisp_Object selection,
1532                       Lisp_Object selection_type)
1533 {
1534   struct device *d = decode_x_device (Qnil);
1535   Display *dpy = DEVICE_X_DISPLAY (d);
1536   return XGetSelectionOwner (dpy, symbol_to_x_atom (d, selection, 0)) != None ?
1537     Qt : Qnil;
1538 }
1539
1540 \f
1541 #ifdef CUT_BUFFER_SUPPORT
1542
1543 static int cut_buffers_initialized; /* Whether we're sure they all exist */
1544
1545 /* Ensure that all 8 cut buffers exist.  ICCCM says we gotta... */
1546 static void
1547 initialize_cut_buffers (Display *display, Window window)
1548 {
1549   static unsigned const char * const data = (unsigned const char *) "";
1550 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1551                                     PropModeAppend, data, 0)
1552   FROB (XA_CUT_BUFFER0);
1553   FROB (XA_CUT_BUFFER1);
1554   FROB (XA_CUT_BUFFER2);
1555   FROB (XA_CUT_BUFFER3);
1556   FROB (XA_CUT_BUFFER4);
1557   FROB (XA_CUT_BUFFER5);
1558   FROB (XA_CUT_BUFFER6);
1559   FROB (XA_CUT_BUFFER7);
1560 #undef FROB
1561   cut_buffers_initialized = 1;
1562 }
1563
1564 #define CHECK_CUTBUFFER(symbol) do {                            \
1565   CHECK_SYMBOL (symbol);                                        \
1566   if (! (EQ (symbol, QCUT_BUFFER0) ||                           \
1567          EQ (symbol, QCUT_BUFFER1) ||                           \
1568          EQ (symbol, QCUT_BUFFER2) ||                           \
1569          EQ (symbol, QCUT_BUFFER3) ||                           \
1570          EQ (symbol, QCUT_BUFFER4) ||                           \
1571          EQ (symbol, QCUT_BUFFER5) ||                           \
1572          EQ (symbol, QCUT_BUFFER6) ||                           \
1573          EQ (symbol, QCUT_BUFFER7)))                            \
1574     signal_simple_error ("Doesn't name a cutbuffer", symbol);   \
1575 } while (0)
1576
1577 DEFUN ("x-get-cutbuffer-internal", Fx_get_cutbuffer_internal, 1, 1, 0, /*
1578 Return the value of the named CUTBUFFER (typically CUT_BUFFER0).
1579 */
1580        (cutbuffer))
1581 {
1582   struct device *d = decode_x_device (Qnil);
1583   Display *display = DEVICE_X_DISPLAY (d);
1584   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1585   Atom cut_buffer_atom;
1586   Extbyte *data;
1587   int bytes;
1588   Atom type;
1589   int format;
1590   unsigned long size;
1591   Lisp_Object ret;
1592
1593   CHECK_CUTBUFFER (cutbuffer);
1594   cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1595
1596   x_get_window_property (display, window, cut_buffer_atom, &data, &bytes,
1597                          &type, &format, &size, 0);
1598   if (!data) return Qnil;
1599
1600   if (format != 8 || type != XA_STRING)
1601     signal_simple_error_2 ("Cut buffer doesn't contain 8-bit STRING data",
1602                            x_atom_to_symbol (d, type),
1603                            make_int (format));
1604
1605   /* We cheat - if the string contains an ESC character, that's
1606      technically not allowed in a STRING, so we assume it's
1607      COMPOUND_TEXT that we stored there ourselves earlier,
1608      in x-store-cutbuffer-internal  */
1609   ret = (bytes ?
1610          make_ext_string (data, bytes,
1611                           memchr (data, 0x1b, bytes) ?
1612                           Qctext : Qbinary)
1613          : Qnil);
1614   xfree (data);
1615   return ret;
1616 }
1617
1618
1619 DEFUN ("x-store-cutbuffer-internal", Fx_store_cutbuffer_internal, 2, 2, 0, /*
1620 Set the value of the named CUTBUFFER (typically CUT_BUFFER0) to STRING.
1621 */
1622        (cutbuffer, string))
1623 {
1624   struct device *d = decode_x_device (Qnil);
1625   Display *display = DEVICE_X_DISPLAY (d);
1626   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1627   Atom cut_buffer_atom;
1628   const Bufbyte *data  = XSTRING_DATA (string);
1629   Bytecount bytes = XSTRING_LENGTH (string);
1630   Bytecount bytes_remaining;
1631   int max_bytes = SELECTION_QUANTUM (display);
1632 #ifdef MULE
1633   const Bufbyte *ptr, *end;
1634   enum { ASCII, LATIN_1, WORLD } chartypes = ASCII;
1635 #endif
1636
1637   if (max_bytes > MAX_SELECTION_QUANTUM)
1638     max_bytes = MAX_SELECTION_QUANTUM;
1639
1640   CHECK_CUTBUFFER (cutbuffer);
1641   CHECK_STRING (string);
1642   cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1643
1644   if (! cut_buffers_initialized)
1645     initialize_cut_buffers (display, window);
1646
1647   /* We use the STRING encoding (Latin-1 only) if we can, else COMPOUND_TEXT.
1648      We cheat and use type = `STRING' even when using COMPOUND_TEXT.
1649      The ICCCM requires that this be so, and other clients assume it,
1650      as we do ourselves in initialize_cut_buffers.  */
1651
1652 #ifdef MULE
1653   /* Optimize for the common ASCII case */
1654   for (ptr = data, end = ptr + bytes; ptr <= end; )
1655     {
1656       if (BYTE_ASCII_P (*ptr))
1657         {
1658           ptr++;
1659           continue;
1660         }
1661
1662 #ifdef UTF2000
1663       if ((*ptr) <= 0xC3)
1664         {
1665           chartypes = LATIN_1;
1666           ptr += 2;
1667           continue;
1668         }
1669 #else
1670       if ((*ptr) == LEADING_BYTE_LATIN_ISO8859_1 ||
1671           (*ptr) == LEADING_BYTE_CONTROL_1)
1672         {
1673           chartypes = LATIN_1;
1674           ptr += 2;
1675           continue;
1676         }
1677 #endif
1678
1679       chartypes = WORLD;
1680       break;
1681     }
1682
1683   if (chartypes == LATIN_1)
1684     TO_EXTERNAL_FORMAT (LISP_STRING, string,
1685                         ALLOCA, (data, bytes),
1686                         Qbinary);
1687   else if (chartypes == WORLD)
1688     TO_EXTERNAL_FORMAT (LISP_STRING, string,
1689                         ALLOCA, (data, bytes),
1690                         Qctext);
1691 #endif /* MULE */
1692
1693   bytes_remaining = bytes;
1694
1695   while (bytes_remaining)
1696     {
1697       int chunk = bytes_remaining < max_bytes ? bytes_remaining : max_bytes;
1698       XChangeProperty (display, window, cut_buffer_atom, XA_STRING, 8,
1699                        (bytes_remaining == bytes
1700                         ? PropModeReplace : PropModeAppend),
1701                        data, chunk);
1702       data += chunk;
1703       bytes_remaining -= chunk;
1704     }
1705   return string;
1706 }
1707
1708
1709 DEFUN ("x-rotate-cutbuffers-internal", Fx_rotate_cutbuffers_internal, 1, 1, 0, /*
1710 Rotate the values of the cutbuffers by the given number of steps;
1711 positive means move values forward, negative means backward.
1712 */
1713        (n))
1714 {
1715   struct device *d = decode_x_device (Qnil);
1716   Display *display = DEVICE_X_DISPLAY (d);
1717   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1718   Atom props [8];
1719
1720   CHECK_INT (n);
1721   if (XINT (n) == 0)
1722     return n;
1723   if (! cut_buffers_initialized)
1724     initialize_cut_buffers (display, window);
1725   props[0] = XA_CUT_BUFFER0;
1726   props[1] = XA_CUT_BUFFER1;
1727   props[2] = XA_CUT_BUFFER2;
1728   props[3] = XA_CUT_BUFFER3;
1729   props[4] = XA_CUT_BUFFER4;
1730   props[5] = XA_CUT_BUFFER5;
1731   props[6] = XA_CUT_BUFFER6;
1732   props[7] = XA_CUT_BUFFER7;
1733   XRotateWindowProperties (display, window, props, 8, XINT (n));
1734   return n;
1735 }
1736
1737 #endif /* CUT_BUFFER_SUPPORT */
1738
1739
1740 \f
1741 /************************************************************************/
1742 /*                            initialization                            */
1743 /************************************************************************/
1744
1745 void
1746 syms_of_select_x (void)
1747 {
1748
1749 #ifdef CUT_BUFFER_SUPPORT
1750   DEFSUBR (Fx_get_cutbuffer_internal);
1751   DEFSUBR (Fx_store_cutbuffer_internal);
1752   DEFSUBR (Fx_rotate_cutbuffers_internal);
1753 #endif /* CUT_BUFFER_SUPPORT */
1754
1755   /* Unfortunately, timeout handlers must be lisp functions. */
1756   defsymbol (&Qx_selection_reply_timeout_internal,
1757              "x-selection-reply-timeout-internal");
1758   DEFSUBR (Fx_selection_reply_timeout_internal);
1759
1760 #ifdef CUT_BUFFER_SUPPORT
1761   defsymbol (&QCUT_BUFFER0, "CUT_BUFFER0");
1762   defsymbol (&QCUT_BUFFER1, "CUT_BUFFER1");
1763   defsymbol (&QCUT_BUFFER2, "CUT_BUFFER2");
1764   defsymbol (&QCUT_BUFFER3, "CUT_BUFFER3");
1765   defsymbol (&QCUT_BUFFER4, "CUT_BUFFER4");
1766   defsymbol (&QCUT_BUFFER5, "CUT_BUFFER5");
1767   defsymbol (&QCUT_BUFFER6, "CUT_BUFFER6");
1768   defsymbol (&QCUT_BUFFER7, "CUT_BUFFER7");
1769 #endif /* CUT_BUFFER_SUPPORT */
1770 }
1771
1772 void
1773 console_type_create_select_x (void)
1774 {
1775   CONSOLE_HAS_METHOD (x, own_selection);
1776   CONSOLE_HAS_METHOD (x, disown_selection);
1777   CONSOLE_HAS_METHOD (x, get_foreign_selection);
1778   CONSOLE_HAS_METHOD (x, selection_exists_p);
1779 }
1780
1781 void
1782 reinit_vars_of_select_x (void)
1783 {
1784   reading_selection_reply = 0;
1785   reading_which_selection = 0;
1786   selection_reply_timed_out = 0;
1787   for_whom_the_bell_tolls = 0;
1788   prop_location_tick = 0;
1789 }
1790
1791 void
1792 vars_of_select_x (void)
1793 {
1794   reinit_vars_of_select_x ();
1795
1796 #ifdef CUT_BUFFER_SUPPORT
1797   cut_buffers_initialized = 0;
1798   Fprovide (intern ("cut-buffer"));
1799 #endif
1800
1801   DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks /*
1802 A function or functions to be called after we have responded to some
1803 other client's request for the value of a selection that we own.  The
1804 function(s) will be called with four arguments:
1805   - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);
1806   - the name of the selection-type which we were requested to convert the
1807     selection into before sending (for example, STRING or LENGTH);
1808   - and whether we successfully transmitted the selection.
1809 We might have failed (and declined the request) for any number of reasons,
1810 including being asked for a selection that we no longer own, or being asked
1811 to convert into a type that we don't know about or that is inappropriate.
1812 This hook doesn't let you change the behavior of emacs's selection replies,
1813 it merely informs you that they have happened.
1814 */ );
1815   Vx_sent_selection_hooks = Qunbound;
1816
1817   DEFVAR_INT ("x-selection-timeout", &x_selection_timeout /*
1818 If the selection owner doesn't reply in this many seconds, we give up.
1819 A value of 0 means wait as long as necessary.  This is initialized from the
1820 \"*selectionTimeout\" resource (which is expressed in milliseconds).
1821 */ );
1822   x_selection_timeout = 0;
1823
1824   DEFVAR_BOOL ("x-selection-strict-motif-ownership", &x_selection_strict_motif_ownership /*
1825 *If nil and XEmacs already owns the clipboard, don't own it again in the
1826 Motif way. Owning the selection on the Motif way does a huge amount of
1827 X protocol, and it makes killing text incredibly slow when using an
1828 X terminal.  However, when enabled Motif text fields don't bother to look up
1829 the new value, and you can't Copy from a buffer, Paste into a text
1830 field, then Copy something else from the buffer and paste it into the
1831 text field; it pastes the first thing again.
1832 */ );
1833   x_selection_strict_motif_ownership = 1;
1834 }
1835
1836 void
1837 Xatoms_of_select_x (struct device *d)
1838 {
1839   Display *D = DEVICE_X_DISPLAY (d);
1840
1841   /* Non-predefined atoms that we might end up using a lot */
1842   DEVICE_XATOM_CLIPBOARD     (d) = XInternAtom (D, "CLIPBOARD",     False);
1843   DEVICE_XATOM_TIMESTAMP     (d) = XInternAtom (D, "TIMESTAMP",     False);
1844   DEVICE_XATOM_TEXT          (d) = XInternAtom (D, "TEXT",          False);
1845   DEVICE_XATOM_DELETE        (d) = XInternAtom (D, "DELETE",        False);
1846   DEVICE_XATOM_MULTIPLE      (d) = XInternAtom (D, "MULTIPLE",      False);
1847   DEVICE_XATOM_INCR          (d) = XInternAtom (D, "INCR",          False);
1848   DEVICE_XATOM_TARGETS       (d) = XInternAtom (D, "TARGETS",       False);
1849   DEVICE_XATOM_NULL          (d) = XInternAtom (D, "NULL",          False);
1850   DEVICE_XATOM_ATOM_PAIR     (d) = XInternAtom (D, "ATOM_PAIR",     False);
1851   DEVICE_XATOM_COMPOUND_TEXT (d) = XInternAtom (D, "COMPOUND_TEXT", False);
1852
1853   /* #### I don't like the looks of this... what is it for? - ajh */
1854   DEVICE_XATOM_EMACS_TMP     (d) = XInternAtom (D, "_EMACS_TMP_",   False);
1855 }