1 /* X Selection processing for XEmacs
2 Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
4 This file is part of XEmacs.
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
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
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. */
21 /* Synched up with: Not synched with FSF. */
23 /* Rewritten by jwz */
29 #include "console-x.h"
30 #include "objects-x.h"
36 int lisp_to_time (Lisp_Object, time_t *);
37 Lisp_Object time_to_lisp (time_t);
39 #ifdef LWLIB_USES_MOTIF
40 # define MOTIF_CLIPBOARDS
43 #ifdef MOTIF_CLIPBOARDS
44 # include <Xm/CutPaste.h>
45 static void hack_motif_clipboard_selection (Atom selection_atom,
46 Lisp_Object selection_value,
47 Time thyme, Display *display,
48 Window selecting_window,
52 #define CUT_BUFFER_SUPPORT
54 Lisp_Object QPRIMARY, QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP,
55 QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL,
56 QATOM_PAIR, QCOMPOUND_TEXT;
58 #ifdef CUT_BUFFER_SUPPORT
59 Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
60 QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
63 Lisp_Object Vx_lost_selection_hooks;
64 Lisp_Object Vx_sent_selection_hooks;
66 /* If this is a smaller number than the max-request-size of the display,
67 emacs will use INCR selection transfer when the selection is larger
68 than this. The max-request-size is usually around 64k, so if you want
69 emacs to use incremental selection transfers when the selection is
70 smaller than that, set this. I added this mostly for debugging the
71 incremental transfer stuff, but it might improve server performance.
73 #define MAX_SELECTION_QUANTUM 0xFFFFFF
75 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize (dpy) << 2) - 100)
77 /* This is an association list whose elements are of the form
78 ( selection-name selection-value selection-timestamp )
79 selection-name is a lisp symbol, whose name is the name of an X Atom.
80 selection-value is the value that emacs owns for that selection.
81 It may be any kind of Lisp object.
82 selection-timestamp is the time at which emacs began owning this selection,
83 as a cons of two 16-bit numbers (making a 32 bit time).
84 If there is an entry in this alist, then it can be assumed that emacs owns
86 The only (eq) parts of this list that are visible from elisp are the
89 Lisp_Object Vselection_alist;
91 /* This is an alist whose CARs are selection-types (whose names are the same
92 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
93 call to convert the given Emacs selection value to a string representing
94 the given selection type. This is for elisp-level extension of the emacs
97 Lisp_Object Vselection_converter_alist;
99 /* "Selection owner couldn't convert selection" */
100 Lisp_Object Qselection_conversion_error;
102 /* If the selection owner takes too long to reply to a selection request,
103 we give up on it. This is in seconds (0 = no timeout).
105 int x_selection_timeout;
108 /* Utility functions */
110 static void lisp_data_to_selection_data (struct device *,
112 unsigned char **data_ret,
114 unsigned int *size_ret,
116 static Lisp_Object selection_data_to_lisp_data (struct device *,
121 static Lisp_Object x_get_window_property_as_lisp_data (Display *,
124 Lisp_Object target_type,
125 Atom selection_atom);
127 static int expect_property_change (Display *, Window, Atom prop, int state);
128 static void wait_for_property_change (long);
129 static void unexpect_property_change (int);
130 static int waiting_for_other_props_on_window (Display *, Window);
132 /* This converts a Lisp symbol to a server Atom, avoiding a server
133 roundtrip whenever possible.
136 symbol_to_x_atom (struct device *d, Lisp_Object sym, int only_if_exists)
138 Display *display = DEVICE_X_DISPLAY (d);
140 if (NILP (sym)) return XA_PRIMARY;
141 if (EQ (sym, Qt)) return XA_SECONDARY;
142 if (EQ (sym, QPRIMARY)) return XA_PRIMARY;
143 if (EQ (sym, QSECONDARY)) return XA_SECONDARY;
144 if (EQ (sym, QSTRING)) return XA_STRING;
145 if (EQ (sym, QINTEGER)) return XA_INTEGER;
146 if (EQ (sym, QATOM)) return XA_ATOM;
147 if (EQ (sym, QCLIPBOARD)) return DEVICE_XATOM_CLIPBOARD (d);
148 if (EQ (sym, QTIMESTAMP)) return DEVICE_XATOM_TIMESTAMP (d);
149 if (EQ (sym, QTEXT)) return DEVICE_XATOM_TEXT (d);
150 if (EQ (sym, QDELETE)) return DEVICE_XATOM_DELETE (d);
151 if (EQ (sym, QMULTIPLE)) return DEVICE_XATOM_MULTIPLE (d);
152 if (EQ (sym, QINCR)) return DEVICE_XATOM_INCR (d);
153 if (EQ (sym, QEMACS_TMP)) return DEVICE_XATOM_EMACS_TMP (d);
154 if (EQ (sym, QTARGETS)) return DEVICE_XATOM_TARGETS (d);
155 if (EQ (sym, QNULL)) return DEVICE_XATOM_NULL (d);
156 if (EQ (sym, QATOM_PAIR)) return DEVICE_XATOM_ATOM_PAIR (d);
157 if (EQ (sym, QCOMPOUND_TEXT)) return DEVICE_XATOM_COMPOUND_TEXT (d);
159 #ifdef CUT_BUFFER_SUPPORT
160 if (EQ (sym, QCUT_BUFFER0)) return XA_CUT_BUFFER0;
161 if (EQ (sym, QCUT_BUFFER1)) return XA_CUT_BUFFER1;
162 if (EQ (sym, QCUT_BUFFER2)) return XA_CUT_BUFFER2;
163 if (EQ (sym, QCUT_BUFFER3)) return XA_CUT_BUFFER3;
164 if (EQ (sym, QCUT_BUFFER4)) return XA_CUT_BUFFER4;
165 if (EQ (sym, QCUT_BUFFER5)) return XA_CUT_BUFFER5;
166 if (EQ (sym, QCUT_BUFFER6)) return XA_CUT_BUFFER6;
167 if (EQ (sym, QCUT_BUFFER7)) return XA_CUT_BUFFER7;
168 #endif /* CUT_BUFFER_SUPPORT */
172 GET_C_STRING_CTEXT_DATA_ALLOCA (Fsymbol_name (sym), nameext);
173 return XInternAtom (display, nameext, only_if_exists ? True : False);
178 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
179 and calls to intern whenever possible.
182 x_atom_to_symbol (struct device *d, Atom atom)
184 Display *display = DEVICE_X_DISPLAY (d);
186 if (! atom) return Qnil;
187 if (atom == XA_PRIMARY) return QPRIMARY;
188 if (atom == XA_SECONDARY) return QSECONDARY;
189 if (atom == XA_STRING) return QSTRING;
190 if (atom == XA_INTEGER) return QINTEGER;
191 if (atom == XA_ATOM) return QATOM;
192 if (atom == DEVICE_XATOM_CLIPBOARD (d)) return QCLIPBOARD;
193 if (atom == DEVICE_XATOM_TIMESTAMP (d)) return QTIMESTAMP;
194 if (atom == DEVICE_XATOM_TEXT (d)) return QTEXT;
195 if (atom == DEVICE_XATOM_DELETE (d)) return QDELETE;
196 if (atom == DEVICE_XATOM_MULTIPLE (d)) return QMULTIPLE;
197 if (atom == DEVICE_XATOM_INCR (d)) return QINCR;
198 if (atom == DEVICE_XATOM_EMACS_TMP (d)) return QEMACS_TMP;
199 if (atom == DEVICE_XATOM_TARGETS (d)) return QTARGETS;
200 if (atom == DEVICE_XATOM_NULL (d)) return QNULL;
201 if (atom == DEVICE_XATOM_ATOM_PAIR (d)) return QATOM_PAIR;
202 if (atom == DEVICE_XATOM_COMPOUND_TEXT (d)) return QCOMPOUND_TEXT;
204 #ifdef CUT_BUFFER_SUPPORT
205 if (atom == XA_CUT_BUFFER0) return QCUT_BUFFER0;
206 if (atom == XA_CUT_BUFFER1) return QCUT_BUFFER1;
207 if (atom == XA_CUT_BUFFER2) return QCUT_BUFFER2;
208 if (atom == XA_CUT_BUFFER3) return QCUT_BUFFER3;
209 if (atom == XA_CUT_BUFFER4) return QCUT_BUFFER4;
210 if (atom == XA_CUT_BUFFER5) return QCUT_BUFFER5;
211 if (atom == XA_CUT_BUFFER6) return QCUT_BUFFER6;
212 if (atom == XA_CUT_BUFFER7) return QCUT_BUFFER7;
217 CONST Bufbyte *intstr;
218 char *str = XGetAtomName (display, atom);
220 if (! str) return Qnil;
222 GET_C_CHARPTR_INT_CTEXT_DATA_ALLOCA (str, intstr);
223 newsym = intern ((char *) intstr);
230 /* Do protocol to assert ourself as a selection owner.
231 Update the Vselection_alist so that we can reply to later requests for
235 x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value)
237 struct device *d = decode_x_device (Qnil);
238 Display *display = DEVICE_X_DISPLAY (d);
239 struct frame *sel_frame = selected_frame ();
240 Window selecting_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
241 /* Use the time of the last-read mouse or keyboard event.
242 For selection purposes, we use this as a sleazy way of knowing what the
243 current time is in server-time. This assumes that the most recently read
244 mouse or keyboard event has something to do with the assertion of the
245 selection, which is probably true.
247 Time thyme = DEVICE_X_MOUSE_TIMESTAMP (d);
250 CHECK_SYMBOL (selection_name);
251 selection_atom = symbol_to_x_atom (d, selection_name, 0);
253 XSetSelectionOwner (display, selection_atom, selecting_window, thyme);
255 /* Now update the local cache */
257 /* We do NOT use time_to_lisp() here any more, like we used to.
258 That assumed equivalence of time_t and Time, which is not
259 necessarily the case (e.g. under OSF on the Alphas, where
260 Time is a 64-bit quantity and time_t is a 32-bit quantity).
262 Opaque pointers are the clean way to go here.
264 Lisp_Object selection_time = make_opaque (sizeof (thyme), (void *) &thyme);
265 Lisp_Object selection_data = list3 (selection_name,
268 Lisp_Object prev_value = assq_no_quit (selection_name, Vselection_alist);
269 Vselection_alist = Fcons (selection_data, Vselection_alist);
271 /* If we already owned the selection, remove the old selection data.
272 Perhaps we should destructively modify it instead.
273 Don't use Fdelq() as that may QUIT;.
275 if (!NILP (prev_value))
277 Lisp_Object rest; /* we know it's not the CAR, so it's easy. */
278 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
279 if (EQ (prev_value, Fcar (XCDR (rest))))
281 XCDR (rest) = Fcdr (XCDR (rest));
285 #ifdef MOTIF_CLIPBOARDS
286 hack_motif_clipboard_selection (selection_atom, selection_value,
287 thyme, display, selecting_window,
294 #ifdef MOTIF_CLIPBOARDS /* Bend over baby. Take it and like it. */
296 # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
297 static void motif_clipboard_cb ();
301 hack_motif_clipboard_selection (Atom selection_atom,
302 Lisp_Object selection_value,
305 Window selecting_window,
308 struct device *d = get_device_from_display (display);
309 /* Those Motif wankers can't be bothered to follow the ICCCM, and do
310 their own non-Xlib non-Xt clipboard processing. So we have to do
311 this so that linked-in Motif widgets don't get themselves wedged.
313 if (selection_atom == DEVICE_XATOM_CLIPBOARD (d)
314 && STRINGP (selection_value)
316 /* If we already own the clipboard, don't own it again in the Motif
317 way. This might lose in some subtle way, since the timestamp won't
318 be current, but owning the selection on the Motif way does a
319 SHITLOAD of X protocol, and it makes killing text be incredibly
320 slow when using an X terminal. ARRRRGGGHHH!!!!
322 /* No, this is no good, because then Motif text fields don't bother
323 to look up the new value, and you can't Copy from a buffer, Paste
324 into a text field, then Copy something else from the buffer and
325 paste it into the text field -- it pastes the first thing again. */
329 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
330 Widget widget = FRAME_X_TEXT_WIDGET (selected_frame());
333 #if XmVersion >= 1002
336 int dataid; /* 1.2 wants long, but 1.1.5 wants int... */
339 String encoding = "STRING";
340 CONST Extbyte *data = XSTRING_DATA (selection_value);
341 Extcount bytes = XSTRING_LENGTH (selection_value);
345 enum { ASCII, LATIN_1, WORLD } chartypes = ASCII;
346 CONST Bufbyte *ptr = data, *end = ptr + bytes;
347 /* Optimize for the common ASCII case */
350 if (BYTE_ASCII_P (*ptr))
356 if ((*ptr) == LEADING_BYTE_LATIN_ISO8859_1 ||
357 (*ptr) == LEADING_BYTE_CONTROL_1)
368 if (chartypes == LATIN_1)
369 GET_STRING_BINARY_DATA_ALLOCA (selection_value, data, bytes);
370 else if (chartypes == WORLD)
372 GET_STRING_CTEXT_DATA_ALLOCA (selection_value, data, bytes);
373 encoding = "COMPOUND_TEXT";
378 fmh = XmStringCreateLtoR ("Clipboard", XmSTRING_DEFAULT_CHARSET);
379 while (ClipboardSuccess !=
380 XmClipboardStartCopy (display, selecting_window, fmh, thyme,
381 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
382 widget, motif_clipboard_cb,
389 while (ClipboardSuccess !=
390 XmClipboardCopy (display, selecting_window, itemid, encoding,
391 #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
392 /* O'Reilly examples say size can be 0,
393 but this clearly is not the case. */
394 0, bytes, (int) selecting_window, /* private id */
395 #else /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
396 (XtPointer) data, bytes, 0,
397 #endif /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
400 while (ClipboardSuccess !=
401 XmClipboardEndCopy (display, selecting_window, itemid))
406 # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
407 /* I tried to treat the clipboard like a real selection, and not send
408 the data until it was requested, but it looks like that just doesn't
409 work at all unless the selection owner and requestor are in different
410 processes. From reading the Motif source, it looks like they never
411 even considered having two widgets in the same application transfer
412 data between each other using "by-name" clipboard values. What a
416 motif_clipboard_cb (Widget widget, int *data_id, int *private_id, int *reason)
420 case XmCR_CLIPBOARD_DATA_REQUEST:
422 Display *dpy = XtDisplay (widget);
423 Window window = (Window) *private_id;
424 Lisp_Object selection = assq_no_quit (QCLIPBOARD, Vselection_alist);
425 if (NILP (selection)) abort ();
426 selection = XCDR (selection);
427 if (!STRINGP (selection)) abort ();
428 XmClipboardCopyByName (dpy, window, *data_id,
429 (char *) XSTRING_DATA (selection),
430 XSTRING_LENGTH (selection) + 1,
434 case XmCR_CLIPBOARD_DATA_DELETE:
436 /* don't need to free anything */
440 # endif /* MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
441 #endif /* MOTIF_CLIPBOARDS */
444 /* Given a selection-name and desired type, this looks up our local copy of
445 the selection value and converts it to the type. It returns nil or a
446 string. This calls random elisp code, and may signal or gc.
449 x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
451 /* This function can GC */
452 Lisp_Object local_value = assq_no_quit (selection_symbol, Vselection_alist);
453 Lisp_Object handler_fn, value, check;
455 if (NILP (local_value)) return Qnil;
457 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
458 if (EQ (target_type, QTIMESTAMP))
461 value = XCAR (XCDR (XCDR (local_value)));
464 #if 0 /* #### MULTIPLE doesn't work yet */
465 else if (CONSP (target_type) &&
466 XCAR (target_type) == QMULTIPLE)
468 Lisp_Object pairs = XCDR (target_type);
469 int len = XVECTOR_LENGTH (pairs);
471 /* If the target is MULTIPLE, then target_type looks like
472 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
473 We modify the second element of each pair in the vector and
474 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
476 for (i = 0; i < len; i++)
478 Lisp_Object pair = XVECTOR_DATA (pairs) [i];
479 XVECTOR_DATA (pair) [1] =
480 x_get_local_selection (XVECTOR_DATA (pair) [0],
481 XVECTOR_DATA (pair) [1]);
488 CHECK_SYMBOL (target_type);
489 handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
490 if (NILP (handler_fn)) return Qnil;
491 value = call3 (handler_fn,
492 selection_symbol, target_type,
493 XCAR (XCDR (local_value)));
496 /* This lets the selection function to return (TYPE . VALUE). For example,
497 when the selected type is LINE_NUMBER, the returned type is SPAN, not
501 if (CONSP (value) && SYMBOLP (XCAR (value)))
502 check = XCDR (value);
504 /* Strings, vectors, and symbols are converted to selection data format in
505 the obvious way. Integers are converted to 16 bit quantities if they're
506 small enough, otherwise 32 bits are used.
508 if (STRINGP (check) ||
516 /* (N . M) or (N M) get turned into a 32 bit quantity. So if you want to
517 always return a small quantity as 32 bits, your converter routine needs
520 else if (CONSP (check) &&
521 INTP (XCAR (check)) &&
522 (INTP (XCDR (check)) ||
523 (CONSP (XCDR (check)) &&
524 INTP (XCAR (XCDR (check))) &&
525 NILP (XCDR (XCDR (check))))))
527 /* Otherwise the lisp converter function returned something unrecognized.
530 signal_error (Qerror,
532 ("unrecognized selection-conversion type"),
536 return Qnil; /* suppress compiler warning */
541 /* Send a SelectionNotify event to the requestor with property=None, meaning
542 we were unable to do what they wanted.
545 x_decline_selection_request (XSelectionRequestEvent *event)
547 XSelectionEvent reply;
548 reply.type = SelectionNotify;
549 reply.display = event->display;
550 reply.requestor = event->requestor;
551 reply.selection = event->selection;
552 reply.time = event->time;
553 reply.target = event->target;
554 reply.property = None;
556 XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
557 XFlush (reply.display);
561 /* Used as an unwind-protect clause so that, if a selection-converter signals
562 an error, we tell the requestor that we were unable to do what they wanted
563 before we throw to top-level or go into the debugger or whatever.
566 x_selection_request_lisp_error (Lisp_Object closure)
568 XSelectionRequestEvent *event = (XSelectionRequestEvent *)
569 get_opaque_ptr (closure);
571 free_opaque_ptr (closure);
572 if (event->type == 0) /* we set this to mean "completed normally" */
574 x_decline_selection_request (event);
579 /* Convert our selection to the requested type, and put that data where the
580 requestor wants it. Then tell them whether we've succeeded.
583 x_reply_selection_request (XSelectionRequestEvent *event, int format,
584 unsigned char *data, int size, Atom type)
586 /* This function can GC */
587 XSelectionEvent reply;
588 Display *display = event->display;
589 struct device *d = get_device_from_display (display);
590 Window window = event->requestor;
592 int format_bytes = format/8;
593 int max_bytes = SELECTION_QUANTUM (display);
594 if (max_bytes > MAX_SELECTION_QUANTUM) max_bytes = MAX_SELECTION_QUANTUM;
596 reply.type = SelectionNotify;
597 reply.display = display;
598 reply.requestor = window;
599 reply.selection = event->selection;
600 reply.time = event->time;
601 reply.target = event->target;
602 reply.property = (event->property == None ? event->target : event->property);
604 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
606 /* Store the data on the requested property.
607 If the selection is large, only store the first N bytes of it.
609 bytes_remaining = size * format_bytes;
610 if (bytes_remaining <= max_bytes)
612 /* Send all the data at once, with minimal handshaking. */
614 stderr_out ("\nStoring all %d\n", bytes_remaining);
616 XChangeProperty (display, window, reply.property, type, format,
617 PropModeReplace, data, size);
618 /* At this point, the selection was successfully stored; ack it. */
619 XSendEvent (display, window, False, 0L, (XEvent *) &reply);
624 /* Send an INCR selection. */
627 if (x_window_to_frame (d, window)) /* #### debug */
628 error ("attempt to transfer an INCR to ourself!");
630 stderr_out ("\nINCR %d\n", bytes_remaining);
632 prop_id = expect_property_change (display, window, reply.property,
635 XChangeProperty (display, window, reply.property, DEVICE_XATOM_INCR (d),
636 32, PropModeReplace, (unsigned char *)
637 &bytes_remaining, 1);
638 XSelectInput (display, window, PropertyChangeMask);
639 /* Tell 'em the INCR data is there... */
640 XSendEvent (display, window, False, 0L, (XEvent *) &reply);
643 /* First, wait for the requestor to ack by deleting the property.
644 This can run random lisp code (process handlers) or signal.
646 wait_for_property_change (prop_id);
648 while (bytes_remaining)
650 int i = ((bytes_remaining < max_bytes)
653 prop_id = expect_property_change (display, window, reply.property,
656 stderr_out (" INCR adding %d\n", i);
658 /* Append the next chunk of data to the property. */
659 XChangeProperty (display, window, reply.property, type, format,
660 PropModeAppend, data, i / format_bytes);
661 bytes_remaining -= i;
664 /* Now wait for the requestor to ack this chunk by deleting the
665 property. This can run random lisp code or signal.
667 wait_for_property_change (prop_id);
669 /* Now write a zero-length chunk to the property to tell the requestor
672 stderr_out (" INCR done\n");
674 if (! waiting_for_other_props_on_window (display, window))
675 XSelectInput (display, window, 0L);
677 XChangeProperty (display, window, reply.property, type, format,
678 PropModeReplace, data, 0);
684 /* Called from the event-loop in response to a SelectionRequest event.
687 x_handle_selection_request (XSelectionRequestEvent *event)
689 /* This function can GC */
690 struct gcpro gcpro1, gcpro2, gcpro3;
691 XSelectionEvent reply;
692 Lisp_Object local_selection_data = Qnil;
693 Lisp_Object selection_symbol;
694 Lisp_Object target_symbol = Qnil;
695 Lisp_Object converted_selection = Qnil;
696 Time local_selection_time;
697 Lisp_Object successful_p = Qnil;
699 struct device *d = get_device_from_display (event->display);
701 GCPRO3 (local_selection_data, converted_selection, target_symbol);
703 reply.type = SelectionNotify; /* Construct the reply event */
704 reply.display = event->display;
705 reply.requestor = event->requestor;
706 reply.selection = event->selection;
707 reply.time = event->time;
708 reply.target = event->target;
709 reply.property = (event->property == None ? event->target : event->property);
711 selection_symbol = x_atom_to_symbol (d, event->selection);
713 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
716 # define CDR(x) (XCDR (x))
717 # define CAR(x) (XCAR (x))
718 /* This list isn't user-visible, so it can't "go bad." */
719 if (!CONSP (local_selection_data)) abort ();
720 if (!CONSP (CDR (local_selection_data))) abort ();
721 if (!CONSP (CDR (CDR (local_selection_data)))) abort ();
722 if (!NILP (CDR (CDR (CDR (local_selection_data))))) abort ();
723 if (!CONSP (CAR (CDR (CDR (local_selection_data))))) abort ();
724 if (!INTP (CAR (CAR (CDR (CDR (local_selection_data)))))) abort ();
725 if (!INTP (CDR (CAR (CDR (CDR (local_selection_data)))))) abort ();
730 if (NILP (local_selection_data))
732 /* Someone asked for the selection, but we don't have it any more.
734 x_decline_selection_request (event);
738 local_selection_time =
739 * (Time *) XOPAQUE_DATA (XCAR (XCDR (XCDR (local_selection_data))));
741 if (event->time != CurrentTime &&
742 local_selection_time > event->time)
744 /* Someone asked for the selection, and we have one, but not the one
747 x_decline_selection_request (event);
751 count = specpdl_depth ();
752 record_unwind_protect (x_selection_request_lisp_error,
753 make_opaque_ptr (event));
754 target_symbol = x_atom_to_symbol (d, event->target);
756 #if 0 /* #### MULTIPLE doesn't work yet */
757 if (EQ (target_symbol, QMULTIPLE))
758 target_symbol = fetch_multiple_target (event);
761 /* Convert lisp objects back into binary data */
763 converted_selection =
764 x_get_local_selection (selection_symbol, target_symbol);
766 if (! NILP (converted_selection))
772 lisp_data_to_selection_data (d, converted_selection,
773 &data, &type, &size, &format);
775 x_reply_selection_request (event, format, data, size, type);
777 /* Tell x_selection_request_lisp_error() it's cool. */
781 unbind_to (count, Qnil);
787 /* Let random lisp code notice that the selection has been asked for. */
790 Lisp_Object val = Vx_sent_selection_hooks;
791 if (!UNBOUNDP (val) && !NILP (val))
793 if (CONSP (val) && !EQ (XCAR (val), Qlambda))
794 for (rest = val; !NILP (rest); rest = Fcdr (rest))
795 call3 (Fcar(rest), selection_symbol, target_symbol,
798 call3 (val, selection_symbol, target_symbol,
805 /* Called from the event-loop in response to a SelectionClear event.
808 x_handle_selection_clear (XSelectionClearEvent *event)
810 Display *display = event->display;
811 struct device *d = get_device_from_display (display);
812 Atom selection = event->selection;
813 Time changed_owner_time = event->time;
815 Lisp_Object selection_symbol, local_selection_data;
816 Time local_selection_time;
818 selection_symbol = x_atom_to_symbol (d, selection);
820 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
822 /* Well, we already believe that we don't own it, so that's just fine. */
823 if (NILP (local_selection_data)) return;
825 local_selection_time =
826 * (Time *) XOPAQUE_DATA (XCAR (XCDR (XCDR (local_selection_data))));
828 /* This SelectionClear is for a selection that we no longer own, so we can
829 disregard it. (That is, we have reasserted the selection since this
830 request was generated.)
832 if (changed_owner_time != CurrentTime &&
833 local_selection_time > changed_owner_time)
836 /* Otherwise, we're really honest and truly being told to drop it.
837 Don't use Fdelq() as that may QUIT;.
839 if (EQ (local_selection_data, Fcar (Vselection_alist)))
840 Vselection_alist = Fcdr (Vselection_alist);
844 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
845 if (EQ (local_selection_data, Fcar (XCDR (rest))))
847 XCDR (rest) = Fcdr (XCDR (rest));
852 /* Let random lisp code notice that the selection has been stolen.
856 Lisp_Object val = Vx_lost_selection_hooks;
857 if (!UNBOUNDP (val) && !NILP (val))
859 if (CONSP (val) && !EQ (XCAR (val), Qlambda))
860 for (rest = val; !NILP (rest); rest = Fcdr (rest))
861 call1 (Fcar (rest), selection_symbol);
863 call1 (val, selection_symbol);
869 /* This stuff is so that INCR selections are reentrant (that is, so we can
870 be servicing multiple INCR selection requests simultaneously). I haven't
871 actually tested that yet.
874 static int prop_location_tick;
876 static struct prop_location {
882 struct prop_location *next;
883 } *for_whom_the_bell_tolls;
887 property_deleted_p (void *tick)
889 struct prop_location *rest = for_whom_the_bell_tolls;
891 if (rest->tick == (long) tick)
899 waiting_for_other_props_on_window (Display *display, Window window)
901 struct prop_location *rest = for_whom_the_bell_tolls;
903 if (rest->display == display && rest->window == window)
912 expect_property_change (Display *display, Window window,
913 Atom property, int state)
915 struct prop_location *pl = xnew (struct prop_location);
916 pl->tick = ++prop_location_tick;
917 pl->display = display;
919 pl->property = property;
920 pl->desired_state = state;
921 pl->next = for_whom_the_bell_tolls;
922 for_whom_the_bell_tolls = pl;
927 unexpect_property_change (int tick)
929 struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
932 if (rest->tick == tick)
935 prev->next = rest->next;
937 for_whom_the_bell_tolls = rest->next;
947 wait_for_property_change (long tick)
949 /* This function can GC */
950 wait_delaying_user_input (property_deleted_p, (void *) tick);
954 /* Called from the event-loop in response to a PropertyNotify event.
957 x_handle_property_notify (XPropertyEvent *event)
959 struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
962 if (rest->property == event->atom &&
963 rest->window == event->window &&
964 rest->display == event->display &&
965 rest->desired_state == event->state)
968 stderr_out ("Saw expected prop-%s on %s\n",
969 (event->state == PropertyDelete ? "delete" : "change"),
970 (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name);
973 prev->next = rest->next;
975 for_whom_the_bell_tolls = rest->next;
983 stderr_out ("Saw UNexpected prop-%s on %s\n",
984 (event->state == PropertyDelete ? "delete" : "change"),
985 (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name));
991 #if 0 /* #### MULTIPLE doesn't work yet */
994 fetch_multiple_target (XSelectionRequestEvent *event)
996 /* This function can GC */
997 Display *display = event->display;
998 Window window = event->requestor;
999 Atom target = event->target;
1000 Atom selection_atom = event->selection;
1005 x_get_window_property_as_lisp_data (display, window, target,
1011 copy_multiple_data (Lisp_Object obj)
1017 return Fcons (XCAR (obj), copy_multiple_data (XCDR (obj)));
1020 len = XVECTOR_LENGTH (obj);
1021 vec = make_vector (len, Qnil);
1022 for (i = 0; i < len; i++)
1024 Lisp_Object vec2 = XVECTOR_DATA (obj) [i];
1025 CHECK_VECTOR (vec2);
1026 if (XVECTOR_LENGTH (vec2) != 2)
1027 signal_error (Qerror, list2 (build_string
1028 ("vectors must be of length 2"),
1030 XVECTOR_DATA (vec) [i] = make_vector (2, Qnil);
1031 XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [0] = XVECTOR_DATA (vec2) [0];
1032 XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [1] = XVECTOR_DATA (vec2) [1];
1040 static Window reading_selection_reply;
1041 static Atom reading_which_selection;
1042 static int selection_reply_timed_out;
1045 selection_reply_done (void *ignore)
1047 return !reading_selection_reply;
1050 static Lisp_Object Qx_selection_reply_timeout_internal;
1052 DEFUN ("x-selection-reply-timeout-internal", Fx_selection_reply_timeout_internal,
1057 selection_reply_timed_out = 1;
1058 reading_selection_reply = 0;
1063 /* Do protocol to read selection-data from the server.
1064 Converts this to lisp data and returns it.
1067 x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
1069 /* This function can GC */
1070 struct device *d = decode_x_device (Qnil);
1071 Display *display = DEVICE_X_DISPLAY (d);
1072 struct frame *sel_frame = selected_frame ();
1073 Window requestor_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
1074 Time requestor_time = DEVICE_X_MOUSE_TIMESTAMP (d);
1075 Atom target_property = DEVICE_XATOM_EMACS_TMP (d);
1076 Atom selection_atom = symbol_to_x_atom (d, selection_symbol, 0);
1078 Atom type_atom = symbol_to_x_atom (d, (CONSP (target_type) ?
1079 XCAR (target_type) : target_type), 0);
1081 XConvertSelection (display, selection_atom, type_atom, target_property,
1082 requestor_window, requestor_time);
1084 /* Block until the reply has been read. */
1085 reading_selection_reply = requestor_window;
1086 reading_which_selection = selection_atom;
1087 selection_reply_timed_out = 0;
1089 speccount = specpdl_depth ();
1091 /* add a timeout handler */
1092 if (x_selection_timeout > 0)
1094 Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout),
1095 Qx_selection_reply_timeout_internal,
1097 record_unwind_protect (Fdisable_timeout, id);
1100 /* This is ^Gable */
1101 wait_delaying_user_input (selection_reply_done, 0);
1103 if (selection_reply_timed_out)
1104 error ("timed out waiting for reply from selection owner");
1106 unbind_to (speccount, Qnil);
1108 /* otherwise, the selection is waiting for us on the requested property. */
1110 x_get_window_property_as_lisp_data (display, requestor_window,
1111 target_property, target_type,
1117 x_get_window_property (Display *display, Window window, Atom property,
1118 unsigned char **data_ret, int *bytes_ret,
1119 Atom *actual_type_ret, int *actual_format_ret,
1120 unsigned long *actual_size_ret, int delete_p)
1123 unsigned long bytes_remaining;
1125 unsigned char *tmp_data = 0;
1127 int buffer_size = SELECTION_QUANTUM (display);
1128 if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
1130 /* First probe the thing to find out how big it is. */
1131 result = XGetWindowProperty (display, window, property,
1132 0, 0, False, AnyPropertyType,
1133 actual_type_ret, actual_format_ret,
1135 &bytes_remaining, &tmp_data);
1136 if (result != Success)
1142 XFree ((char *) tmp_data);
1144 if (*actual_type_ret == None || *actual_format_ret == 0)
1146 if (delete_p) XDeleteProperty (display, window, property);
1152 total_size = bytes_remaining + 1;
1153 *data_ret = (unsigned char *) xmalloc (total_size);
1155 /* Now read, until weve gotten it all. */
1156 while (bytes_remaining)
1159 int last = bytes_remaining;
1162 XGetWindowProperty (display, window, property,
1163 offset/4, buffer_size/4,
1164 (delete_p ? True : False),
1166 actual_type_ret, actual_format_ret,
1167 actual_size_ret, &bytes_remaining, &tmp_data);
1169 stderr_out ("<< read %d\n", last-bytes_remaining);
1171 /* If this doesn't return Success at this point, it means that
1172 some clod deleted the selection while we were in the midst of
1173 reading it. Deal with that, I guess....
1175 if (result != Success) break;
1176 *actual_size_ret *= *actual_format_ret / 8;
1177 memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
1178 offset += *actual_size_ret;
1179 XFree ((char *) tmp_data);
1181 *bytes_ret = offset;
1186 receive_incremental_selection (Display *display, Window window, Atom property,
1187 /* this one is for error messages only */
1188 Lisp_Object target_type,
1189 unsigned int min_size_bytes,
1190 unsigned char **data_ret, int *size_bytes_ret,
1191 Atom *type_ret, int *format_ret,
1192 unsigned long *size_ret)
1194 /* This function can GC */
1197 *size_bytes_ret = min_size_bytes;
1198 *data_ret = (unsigned char *) xmalloc (*size_bytes_ret);
1200 stderr_out ("\nread INCR %d\n", min_size_bytes);
1202 /* At this point, we have read an INCR property, and deleted it (which
1203 is how we ack its receipt: the sending window will be selecting
1204 PropertyNotify events on our window to notice this).
1206 Now, we must loop, waiting for the sending window to put a value on
1207 that property, then reading the property, then deleting it to ack.
1208 We are done when the sender places a property of length 0.
1210 prop_id = expect_property_change (display, window, property,
1214 unsigned char *tmp_data;
1216 wait_for_property_change (prop_id);
1217 /* expect it again immediately, because x_get_window_property may
1218 .. no it wont, I dont get it.
1219 .. Ok, I get it now, the Xt code that implements INCR is broken.
1221 prop_id = expect_property_change (display, window, property,
1223 x_get_window_property (display, window, property,
1224 &tmp_data, &tmp_size_bytes,
1225 type_ret, format_ret, size_ret, 1);
1227 if (tmp_size_bytes == 0) /* we're done */
1230 stderr_out (" read INCR done\n");
1232 unexpect_property_change (prop_id);
1233 if (tmp_data) xfree (tmp_data);
1237 stderr_out (" read INCR %d\n", tmp_size_bytes);
1239 if (*size_bytes_ret < offset + tmp_size_bytes)
1242 stderr_out (" read INCR realloc %d -> %d\n",
1243 *size_bytes_ret, offset + tmp_size_bytes);
1245 *size_bytes_ret = offset + tmp_size_bytes;
1246 *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret);
1248 memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
1249 offset += tmp_size_bytes;
1256 x_get_window_property_as_lisp_data (Display *display,
1259 /* next two for error messages only */
1260 Lisp_Object target_type,
1261 Atom selection_atom)
1263 /* This function can GC */
1266 unsigned long actual_size;
1267 unsigned char *data = NULL;
1270 struct device *d = get_device_from_display (display);
1272 x_get_window_property (display, window, property, &data, &bytes,
1273 &actual_type, &actual_format, &actual_size, 1);
1276 if (XGetSelectionOwner (display, selection_atom))
1277 /* there is a selection owner */
1279 (Qselection_conversion_error,
1280 Fcons (build_string ("selection owner couldn't convert"),
1281 Fcons (x_atom_to_symbol (d, selection_atom),
1283 list2 (target_type, x_atom_to_symbol (d, actual_type)) :
1284 list1 (target_type))));
1286 signal_error (Qerror,
1287 list2 (build_string ("no selection"),
1288 x_atom_to_symbol (d, selection_atom)));
1291 if (actual_type == DEVICE_XATOM_INCR (d))
1293 /* Ok, that data wasn't *the* data, it was just the beginning. */
1295 unsigned int min_size_bytes = * ((unsigned int *) data);
1297 receive_incremental_selection (display, window, property, target_type,
1298 min_size_bytes, &data, &bytes,
1299 &actual_type, &actual_format,
1303 /* It's been read. Now convert it to a lisp object in some semi-rational
1305 val = selection_data_to_lisp_data (d, data, bytes,
1306 actual_type, actual_format);
1312 /* These functions convert from the selection data read from the server into
1313 something that we can use from elisp, and vice versa.
1315 Type: Format: Size: Elisp Type:
1316 ----- ------- ----- -----------
1319 ATOM 32 > 1 Vector of Symbols
1321 * 16 > 1 Vector of Integers
1322 * 32 1 if <=16 bits: Integer
1323 if > 16 bits: Cons of top16, bot16
1324 * 32 > 1 Vector of the above
1326 When converting a Lisp number to C, it is assumed to be of format 16 if
1327 it is an integer, and of format 32 if it is a cons of two integers.
1329 When converting a vector of numbers from Elisp to C, it is assumed to be
1330 of format 16 if every element in the vector is an integer, and is assumed
1331 to be of format 32 if any element is a cons of two integers.
1333 When converting an object to C, it may be of the form (SYMBOL . <data>)
1334 where SYMBOL is what we should claim that the type is. Format and
1335 representation are as above.
1337 NOTE: Under Mule, when someone shoves us a string without a type, we
1338 set the type to 'COMPOUND_TEXT and automatically convert to Compound
1339 Text. If the string has a type, we assume that the user wants the
1340 data sent as-is so we just do "binary" conversion.
1345 selection_data_to_lisp_data (struct device *d,
1346 unsigned char *data,
1351 if (type == DEVICE_XATOM_NULL (d))
1354 /* Convert any 8-bit data to a string, for compactness. */
1355 else if (format == 8)
1356 return make_ext_string (data, size,
1357 type == DEVICE_XATOM_TEXT (d) ||
1358 type == DEVICE_XATOM_COMPOUND_TEXT (d)
1359 ? FORMAT_CTEXT : FORMAT_BINARY);
1361 /* Convert a single atom to a Lisp Symbol. Convert a set of atoms to
1362 a vector of symbols.
1364 else if (type == XA_ATOM)
1366 if (size == sizeof (Atom))
1367 return x_atom_to_symbol (d, *((Atom *) data));
1371 int len = size / sizeof (Atom);
1372 Lisp_Object v = Fmake_vector (make_int (len), Qzero);
1373 for (i = 0; i < len; i++)
1374 Faset (v, make_int (i), x_atom_to_symbol (d, ((Atom *) data) [i]));
1379 /* Convert a single 16 or small 32 bit number to a Lisp Int.
1380 If the number is > 16 bits, convert it to a cons of integers,
1381 16 bits in each half.
1383 else if (format == 32 && size == sizeof (long))
1384 return word_to_lisp (((unsigned long *) data) [0]);
1385 else if (format == 16 && size == sizeof (short))
1386 return make_int ((int) (((unsigned short *) data) [0]));
1388 /* Convert any other kind of data to a vector of numbers, represented
1389 as above (as an integer, or a cons of two 16 bit integers).
1391 #### Perhaps we should return the actual type to lisp as well.
1393 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1396 and perhaps it should be
1398 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1401 Right now the fact that the return type was SPAN is discarded before
1402 lisp code gets to see it.
1404 else if (format == 16)
1407 Lisp_Object v = make_vector (size / 4, Qzero);
1408 for (i = 0; i < (int) size / 4; i++)
1410 int j = (int) ((unsigned short *) data) [i];
1411 Faset (v, make_int (i), make_int (j));
1418 Lisp_Object v = make_vector (size / 4, Qzero);
1419 for (i = 0; i < (int) size / 4; i++)
1421 unsigned long j = ((unsigned long *) data) [i];
1422 Faset (v, make_int (i), word_to_lisp (j));
1430 lisp_data_to_selection_data (struct device *d,
1432 unsigned char **data_ret,
1434 unsigned int *size_ret,
1437 Lisp_Object type = Qnil;
1439 if (CONSP (obj) && SYMBOLP (XCAR (obj)))
1443 if (CONSP (obj) && NILP (XCDR (obj)))
1447 if (EQ (obj, QNULL) || (EQ (type, QNULL)))
1448 { /* This is not the same as declining */
1454 else if (STRINGP (obj))
1456 CONST Extbyte *extval;
1460 GET_STRING_CTEXT_DATA_ALLOCA (obj, extval, extvallen);
1462 GET_STRING_BINARY_DATA_ALLOCA (obj, extval, extvallen);
1464 *size_ret = extvallen;
1465 *data_ret = (unsigned char *) xmalloc (*size_ret);
1466 memcpy (*data_ret, extval, *size_ret);
1468 if (NILP (type)) type = QCOMPOUND_TEXT;
1470 if (NILP (type)) type = QSTRING;
1473 else if (CHARP (obj))
1475 Bufbyte buf[MAX_EMCHAR_LEN];
1477 CONST Extbyte *extval;
1481 len = set_charptr_emchar (buf, XCHAR (obj));
1482 GET_CHARPTR_EXT_CTEXT_DATA_ALLOCA (buf, len, extval, extvallen);
1483 *size_ret = extvallen;
1484 *data_ret = (unsigned char *) xmalloc (*size_ret);
1485 memcpy (*data_ret, extval, *size_ret);
1487 if (NILP (type)) type = QCOMPOUND_TEXT;
1489 if (NILP (type)) type = QSTRING;
1492 else if (SYMBOLP (obj))
1496 *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
1497 (*data_ret) [sizeof (Atom)] = 0;
1498 (*(Atom **) data_ret) [0] = symbol_to_x_atom (d, obj, 0);
1499 if (NILP (type)) type = QATOM;
1501 else if (INTP (obj) &&
1502 XINT (obj) <= 0x7FFF &&
1503 XINT (obj) >= -0x8000)
1507 *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
1508 (*data_ret) [sizeof (short)] = 0;
1509 (*(short **) data_ret) [0] = (short) XINT (obj);
1510 if (NILP (type)) type = QINTEGER;
1512 else if (INTP (obj) || CONSP (obj))
1516 *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
1517 (*data_ret) [sizeof (long)] = 0;
1518 (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
1519 if (NILP (type)) type = QINTEGER;
1521 else if (VECTORP (obj))
1523 /* Lisp Vectors may represent a set of ATOMs;
1524 a set of 16 or 32 bit INTEGERs;
1525 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1529 if (SYMBOLP (XVECTOR_DATA (obj) [0]))
1530 /* This vector is an ATOM set */
1532 if (NILP (type)) type = QATOM;
1533 *size_ret = XVECTOR_LENGTH (obj);
1535 *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
1536 for (i = 0; i < (int) (*size_ret); i++)
1537 if (SYMBOLP (XVECTOR_DATA (obj) [i]))
1538 (*(Atom **) data_ret) [i] =
1539 symbol_to_x_atom (d, XVECTOR_DATA (obj) [i], 0);
1541 signal_error (Qerror, /* Qselection_error */
1543 ("all elements of the vector must be of the same type"),
1546 #if 0 /* #### MULTIPLE doesn't work yet */
1547 else if (VECTORP (XVECTOR_DATA (obj) [0]))
1548 /* This vector is an ATOM_PAIR set */
1550 if (NILP (type)) type = QATOM_PAIR;
1551 *size_ret = XVECTOR_LENGTH (obj);
1553 *data_ret = (unsigned char *)
1554 xmalloc ((*size_ret) * sizeof (Atom) * 2);
1555 for (i = 0; i < *size_ret; i++)
1556 if (VECTORP (XVECTOR_DATA (obj) [i]))
1558 Lisp_Object pair = XVECTOR_DATA (obj) [i];
1559 if (XVECTOR_LENGTH (pair) != 2)
1560 signal_error (Qerror,
1562 ("elements of the vector must be vectors of exactly two elements"),
1565 (*(Atom **) data_ret) [i * 2] =
1566 symbol_to_x_atom (d, XVECTOR_DATA (pair) [0], 0);
1567 (*(Atom **) data_ret) [(i * 2) + 1] =
1568 symbol_to_x_atom (d, XVECTOR_DATA (pair) [1], 0);
1571 signal_error (Qerror,
1573 ("all elements of the vector must be of the same type"),
1578 /* This vector is an INTEGER set, or something like it */
1580 *size_ret = XVECTOR_LENGTH (obj);
1581 if (NILP (type)) type = QINTEGER;
1583 for (i = 0; i < (int) (*size_ret); i++)
1584 if (CONSP (XVECTOR_DATA (obj) [i]))
1586 else if (!INTP (XVECTOR_DATA (obj) [i]))
1587 signal_error (Qerror, /* Qselection_error */
1589 ("all elements of the vector must be integers or conses of integers"),
1592 *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
1593 for (i = 0; i < (int) (*size_ret); i++)
1594 if (*format_ret == 32)
1595 (*((unsigned long **) data_ret)) [i] =
1596 lisp_to_word (XVECTOR_DATA (obj) [i]);
1598 (*((unsigned short **) data_ret)) [i] =
1599 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
1603 signal_error (Qerror, /* Qselection_error */
1604 list2 (build_string ("unrecognized selection data"),
1607 *type_ret = symbol_to_x_atom (d, type, 0);
1611 clean_local_selection_data (Lisp_Object obj)
1614 INTP (XCAR (obj)) &&
1615 CONSP (XCDR (obj)) &&
1616 INTP (XCAR (XCDR (obj))) &&
1617 NILP (XCDR (XCDR (obj))))
1618 obj = Fcons (XCAR (obj), XCDR (obj));
1621 INTP (XCAR (obj)) &&
1624 if (XINT (XCAR (obj)) == 0)
1626 if (XINT (XCAR (obj)) == -1)
1627 return make_int (- XINT (XCDR (obj)));
1632 int len = XVECTOR_LENGTH (obj);
1635 return clean_local_selection_data (XVECTOR_DATA (obj) [0]);
1636 copy = make_vector (len, Qnil);
1637 for (i = 0; i < len; i++)
1638 XVECTOR_DATA (copy) [i] =
1639 clean_local_selection_data (XVECTOR_DATA (obj) [i]);
1646 /* Called from the event loop to handle SelectionNotify events.
1647 I don't think this needs to be reentrant.
1650 x_handle_selection_notify (XSelectionEvent *event)
1652 if (! reading_selection_reply)
1653 message ("received an unexpected SelectionNotify event");
1654 else if (event->requestor != reading_selection_reply)
1655 message ("received a SelectionNotify event for the wrong window");
1656 else if (event->selection != reading_which_selection)
1657 message ("received the wrong selection type in SelectionNotify!");
1659 reading_selection_reply = 0; /* we're done now. */
1663 DEFUN ("x-own-selection-internal", Fx_own_selection_internal, 2, 2, 0, /*
1664 Assert an X selection of the given TYPE with the given VALUE.
1665 TYPE is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD.
1666 VALUE is typically a string, or a cons of two markers, but may be
1667 anything that the functions on selection-converter-alist know about.
1669 (selection_name, selection_value))
1671 CHECK_SYMBOL (selection_name);
1672 if (NILP (selection_value)) error ("selection-value may not be nil.");
1673 x_own_selection (selection_name, selection_value);
1674 return selection_value;
1678 /* Request the selection value from the owner. If we are the owner,
1679 simply return our selection value. If we are not the owner, this
1680 will block until all of the data has arrived.
1682 DEFUN ("x-get-selection-internal", Fx_get_selection_internal, 2, 2, 0, /*
1683 Return text selected from some X window.
1684 SELECTION_SYMBOL is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD.
1685 TARGET_TYPE is the type of data desired, typically STRING or COMPOUND_TEXT.
1686 Under Mule, if the resultant data comes back as 8-bit data in type
1687 TEXT or COMPOUND_TEXT, it will be decoded as Compound Text.
1689 (selection_symbol, target_type))
1691 /* This function can GC */
1692 Lisp_Object val = Qnil;
1693 struct gcpro gcpro1, gcpro2;
1694 GCPRO2 (target_type, val); /* we store newly consed data into these */
1695 CHECK_SYMBOL (selection_symbol);
1697 #if 0 /* #### MULTIPLE doesn't work yet */
1698 if (CONSP (target_type) &&
1699 XCAR (target_type) == QMULTIPLE)
1701 CHECK_VECTOR (XCDR (target_type));
1702 /* So we don't destructively modify this... */
1703 target_type = copy_multiple_data (target_type);
1707 CHECK_SYMBOL (target_type);
1709 val = x_get_local_selection (selection_symbol, target_type);
1713 val = x_get_foreign_selection (selection_symbol, target_type);
1717 if (CONSP (val) && SYMBOLP (XCAR (val)))
1720 if (CONSP (val) && NILP (XCDR (val)))
1723 val = clean_local_selection_data (val);
1729 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal, 1, 2, 0, /*
1730 If we own the named selection, then disown it (make there be no selection).
1732 (selection, timeval))
1734 struct device *d = decode_x_device (Qnil);
1735 Display *display = DEVICE_X_DISPLAY (d);
1737 Atom selection_atom;
1738 XSelectionClearEvent event;
1740 CHECK_SYMBOL (selection);
1742 timestamp = DEVICE_X_MOUSE_TIMESTAMP (d);
1745 /* #### This is bogus. See the comment above about problems
1746 on OSF/1 and DEC Alphas. Yet another reason why it sucks
1747 to have the implementation (i.e. cons of two 16-bit
1748 integers) exposed. */
1750 lisp_to_time (timeval, &the_time);
1751 timestamp = (Time) the_time;
1754 if (NILP (assq_no_quit (selection, Vselection_alist)))
1755 return Qnil; /* Don't disown the selection when we're not the owner. */
1757 selection_atom = symbol_to_x_atom (d, selection, 0);
1759 XSetSelectionOwner (display, selection_atom, None, timestamp);
1761 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1762 generated for a window which owns the selection when that window sets
1763 the selection owner to None. The NCD server does, the MIT Sun4 server
1764 doesn't. So we synthesize one; this means we might get two, but
1765 that's ok, because the second one won't have any effect.
1767 event.display = display;
1768 event.selection = selection_atom;
1769 event.time = timestamp;
1770 x_handle_selection_clear (&event);
1776 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, 0, 1, 0, /*
1777 Return t if current emacs process owns the given X Selection.
1778 The arg should be the name of the selection in question, typically one of
1779 the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, the symbol
1780 nil is the same as PRIMARY, and t is the same as SECONDARY.)
1784 CHECK_SYMBOL (selection);
1785 if (EQ (selection, Qnil)) selection = QPRIMARY;
1786 else if (EQ (selection, Qt)) selection = QSECONDARY;
1788 return NILP (Fassq (selection, Vselection_alist)) ? Qnil : Qt;
1791 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, 0, 1, 0, /*
1792 Whether there is an owner for the given X Selection.
1793 The arg should be the name of the selection in question, typically one of
1794 the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, the symbol
1795 nil is the same as PRIMARY, and t is the same as SECONDARY.)
1799 struct device *d = decode_x_device (Qnil);
1800 Display *dpy = DEVICE_X_DISPLAY (d);
1801 CHECK_SYMBOL (selection);
1802 if (!NILP (Fx_selection_owner_p (selection)))
1804 return XGetSelectionOwner (dpy, symbol_to_x_atom (d, selection, 0)) != None ?
1809 #ifdef CUT_BUFFER_SUPPORT
1811 static int cut_buffers_initialized; /* Whether we're sure they all exist */
1813 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1815 initialize_cut_buffers (Display *display, Window window)
1817 static unsigned CONST char * CONST data = (unsigned CONST char *) "";
1818 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1819 PropModeAppend, data, 0)
1820 FROB (XA_CUT_BUFFER0);
1821 FROB (XA_CUT_BUFFER1);
1822 FROB (XA_CUT_BUFFER2);
1823 FROB (XA_CUT_BUFFER3);
1824 FROB (XA_CUT_BUFFER4);
1825 FROB (XA_CUT_BUFFER5);
1826 FROB (XA_CUT_BUFFER6);
1827 FROB (XA_CUT_BUFFER7);
1829 cut_buffers_initialized = 1;
1832 #define CHECK_CUTBUFFER(symbol) \
1833 { CHECK_SYMBOL (symbol); \
1834 if (!EQ((symbol),QCUT_BUFFER0) && !EQ((symbol),QCUT_BUFFER1) && \
1835 !EQ((symbol),QCUT_BUFFER2) && !EQ((symbol),QCUT_BUFFER3) && \
1836 !EQ((symbol),QCUT_BUFFER4) && !EQ((symbol),QCUT_BUFFER5) && \
1837 !EQ((symbol),QCUT_BUFFER6) && !EQ((symbol),QCUT_BUFFER7)) \
1838 signal_error (Qerror, list2 (build_string ("Doesn't name a cutbuffer"), \
1842 DEFUN ("x-get-cutbuffer-internal", Fx_get_cutbuffer_internal, 1, 1, 0, /*
1843 Return the value of the named CUTBUFFER (typically CUT_BUFFER0).
1847 struct device *d = decode_x_device (Qnil);
1848 Display *display = DEVICE_X_DISPLAY (d);
1849 Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1850 Atom cut_buffer_atom;
1851 unsigned char *data;
1858 CHECK_CUTBUFFER (cutbuffer);
1859 cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1861 x_get_window_property (display, window, cut_buffer_atom, &data, &bytes,
1862 &type, &format, &size, 0);
1863 if (!data) return Qnil;
1865 if (format != 8 || type != XA_STRING)
1866 signal_simple_error_2 ("Cut buffer doesn't contain 8-bit STRING data",
1867 x_atom_to_symbol (d, type),
1870 /* We cheat - if the string contains an ESC character, that's
1871 technically not allowed in a STRING, so we assume it's
1872 COMPOUND_TEXT that we stored there ourselves earlier,
1873 in x-store-cutbuffer-internal */
1875 make_ext_string (data, bytes,
1876 memchr (data, 0x1b, bytes) ?
1877 FORMAT_CTEXT : FORMAT_BINARY)
1884 DEFUN ("x-store-cutbuffer-internal", Fx_store_cutbuffer_internal, 2, 2, 0, /*
1885 Set the value of the named CUTBUFFER (typically CUT_BUFFER0) to STRING.
1887 (cutbuffer, string))
1889 struct device *d = decode_x_device (Qnil);
1890 Display *display = DEVICE_X_DISPLAY (d);
1891 Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1892 Atom cut_buffer_atom;
1893 CONST Extbyte *data = XSTRING_DATA (string);
1894 Extcount bytes = XSTRING_LENGTH (string);
1895 Extcount bytes_remaining;
1896 int max_bytes = SELECTION_QUANTUM (display);
1898 CONST Bufbyte *ptr, *end;
1899 enum { ASCII, LATIN_1, WORLD } chartypes = ASCII;
1902 if (max_bytes > MAX_SELECTION_QUANTUM)
1903 max_bytes = MAX_SELECTION_QUANTUM;
1905 CHECK_CUTBUFFER (cutbuffer);
1906 CHECK_STRING (string);
1907 cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1909 if (! cut_buffers_initialized)
1910 initialize_cut_buffers (display, window);
1912 /* We use the STRING encoding (Latin-1 only) if we can, else COMPOUND_TEXT.
1913 We cheat and use type = `STRING' even when using COMPOUND_TEXT.
1914 The ICCCM requires that this be so, and other clients assume it,
1915 as we do ourselves in initialize_cut_buffers. */
1918 /* Optimize for the common ASCII case */
1919 for (ptr = data, end = ptr + bytes; ptr <= end; )
1921 if (BYTE_ASCII_P (*ptr))
1927 if ((*ptr) == LEADING_BYTE_LATIN_ISO8859_1 ||
1928 (*ptr) == LEADING_BYTE_CONTROL_1)
1930 chartypes = LATIN_1;
1939 if (chartypes == LATIN_1)
1940 GET_STRING_BINARY_DATA_ALLOCA (string, data, bytes);
1941 else if (chartypes == WORLD)
1942 GET_STRING_CTEXT_DATA_ALLOCA (string, data, bytes);
1945 bytes_remaining = bytes;
1947 while (bytes_remaining)
1949 int chunk = bytes_remaining < max_bytes ? bytes_remaining : max_bytes;
1950 XChangeProperty (display, window, cut_buffer_atom, XA_STRING, 8,
1951 (bytes_remaining == bytes
1952 ? PropModeReplace : PropModeAppend),
1955 bytes_remaining -= chunk;
1961 DEFUN ("x-rotate-cutbuffers-internal", Fx_rotate_cutbuffers_internal, 1, 1, 0, /*
1962 Rotate the values of the cutbuffers by the given number of steps;
1963 positive means move values forward, negative means backward.
1967 struct device *d = decode_x_device (Qnil);
1968 Display *display = DEVICE_X_DISPLAY (d);
1969 Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1975 if (! cut_buffers_initialized)
1976 initialize_cut_buffers (display, window);
1977 props[0] = XA_CUT_BUFFER0;
1978 props[1] = XA_CUT_BUFFER1;
1979 props[2] = XA_CUT_BUFFER2;
1980 props[3] = XA_CUT_BUFFER3;
1981 props[4] = XA_CUT_BUFFER4;
1982 props[5] = XA_CUT_BUFFER5;
1983 props[6] = XA_CUT_BUFFER6;
1984 props[7] = XA_CUT_BUFFER7;
1985 XRotateWindowProperties (display, window, props, 8, XINT (n));
1989 #endif /* CUT_BUFFER_SUPPORT */
1993 /************************************************************************/
1994 /* initialization */
1995 /************************************************************************/
1998 syms_of_xselect (void)
2000 DEFSUBR (Fx_get_selection_internal);
2001 DEFSUBR (Fx_own_selection_internal);
2002 DEFSUBR (Fx_disown_selection_internal);
2003 DEFSUBR (Fx_selection_owner_p);
2004 DEFSUBR (Fx_selection_exists_p);
2006 #ifdef CUT_BUFFER_SUPPORT
2007 DEFSUBR (Fx_get_cutbuffer_internal);
2008 DEFSUBR (Fx_store_cutbuffer_internal);
2009 DEFSUBR (Fx_rotate_cutbuffers_internal);
2010 #endif /* CUT_BUFFER_SUPPORT */
2012 /* Unfortunately, timeout handlers must be lisp functions. */
2013 defsymbol (&Qx_selection_reply_timeout_internal,
2014 "x-selection-reply-timeout-internal");
2015 DEFSUBR (Fx_selection_reply_timeout_internal);
2017 defsymbol (&QPRIMARY, "PRIMARY");
2018 defsymbol (&QSECONDARY, "SECONDARY");
2019 defsymbol (&QSTRING, "STRING");
2020 defsymbol (&QINTEGER, "INTEGER");
2021 defsymbol (&QCLIPBOARD, "CLIPBOARD");
2022 defsymbol (&QTIMESTAMP, "TIMESTAMP");
2023 defsymbol (&QTEXT, "TEXT");
2024 defsymbol (&QDELETE, "DELETE");
2025 defsymbol (&QMULTIPLE, "MULTIPLE");
2026 defsymbol (&QINCR, "INCR");
2027 defsymbol (&QEMACS_TMP, "_EMACS_TMP_");
2028 defsymbol (&QTARGETS, "TARGETS");
2029 defsymbol (&QATOM, "ATOM");
2030 defsymbol (&QATOM_PAIR, "ATOM_PAIR");
2031 defsymbol (&QCOMPOUND_TEXT, "COMPOUND_TEXT");
2032 defsymbol (&QNULL, "NULL");
2034 #ifdef CUT_BUFFER_SUPPORT
2035 defsymbol (&QCUT_BUFFER0, "CUT_BUFFER0");
2036 defsymbol (&QCUT_BUFFER1, "CUT_BUFFER1");
2037 defsymbol (&QCUT_BUFFER2, "CUT_BUFFER2");
2038 defsymbol (&QCUT_BUFFER3, "CUT_BUFFER3");
2039 defsymbol (&QCUT_BUFFER4, "CUT_BUFFER4");
2040 defsymbol (&QCUT_BUFFER5, "CUT_BUFFER5");
2041 defsymbol (&QCUT_BUFFER6, "CUT_BUFFER6");
2042 defsymbol (&QCUT_BUFFER7, "CUT_BUFFER7");
2043 #endif /* CUT_BUFFER_SUPPORT */
2045 deferror (&Qselection_conversion_error,
2046 "selection-conversion-error",
2047 "selection-conversion error", Qio_error);
2051 vars_of_xselect (void)
2053 #ifdef CUT_BUFFER_SUPPORT
2054 cut_buffers_initialized = 0;
2055 Fprovide (intern ("cut-buffer"));
2058 reading_selection_reply = 0;
2059 reading_which_selection = 0;
2060 selection_reply_timed_out = 0;
2061 for_whom_the_bell_tolls = 0;
2062 prop_location_tick = 0;
2064 Vselection_alist = Qnil;
2065 staticpro (&Vselection_alist);
2067 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist /*
2068 An alist associating selection-types (such as STRING and TIMESTAMP) with
2069 functions. These functions will be called with three args: the name of the
2070 selection (typically PRIMARY, SECONDARY, or CLIPBOARD); a desired type to
2071 which the selection should be converted; and the local selection value
2072 (whatever had been passed to `x-own-selection'). These functions should
2073 return the value to send to the X server, which should be one of:
2075 -- nil (the conversion could not be done)
2076 -- a cons of a symbol and any of the following values; the symbol
2077 explicitly specifies the type that will be sent.
2078 -- a string (If the type is not specified, then if Mule support exists,
2079 the string will be converted to Compound Text and sent in
2080 the 'COMPOUND_TEXT format; otherwise (no Mule support),
2081 the string will be left as-is and sent in the 'STRING
2082 format. If the type is specified, the string will be
2083 left as-is (or converted to binary format under Mule).
2084 In all cases, 8-bit data it sent.)
2085 -- a character (With Mule support, will be converted to Compound Text
2086 whether or not a type is specified. If a type is not
2087 specified, a type of 'STRING or 'COMPOUND_TEXT will be
2088 sent, as for strings.)
2089 -- the symbol 'NULL (Indicates that there is no meaningful return value.
2090 Empty 32-bit data with a type of 'NULL will be sent.)
2091 -- a symbol (Will be converted into an atom. If the type is not specified,
2092 a type of 'ATOM will be sent.)
2093 -- an integer (Will be converted into a 16-bit or 32-bit integer depending
2094 on the value. If the type is not specified, a type of
2095 'INTEGER will be sent.)
2096 -- a cons (HIGH . LOW) of integers (Will be converted into a 32-bit integer.
2097 If the type is not specified, a type of
2098 'INTEGER will be sent.)
2099 -- a vector of symbols (Will be converted into a list of atoms. If the type
2100 is not specified, a type of 'ATOM will be sent.)
2101 -- a vector of integers (Will be converted into a list of 16-bit integers.
2102 If the type is not specified, a type of 'INTEGER
2104 -- a vector of integers and/or conses (HIGH . LOW) of integers
2105 (Will be converted into a list of 16-bit integers.
2106 If the type is not specified, a type of 'INTEGER
2109 Vselection_converter_alist = Qnil;
2111 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks /*
2112 A function or functions to be called after the X server has notified us
2113 that we have lost the selection. The function(s) will be called with one
2114 argument, a symbol naming the selection (typically PRIMARY, SECONDARY, or
2117 Vx_lost_selection_hooks = Qunbound;
2119 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks /*
2120 A function or functions to be called after we have responded to some
2121 other client's request for the value of a selection that we own. The
2122 function(s) will be called with four arguments:
2123 - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);
2124 - the name of the selection-type which we were requested to convert the
2125 selection into before sending (for example, STRING or LENGTH);
2126 - and whether we successfully transmitted the selection.
2127 We might have failed (and declined the request) for any number of reasons,
2128 including being asked for a selection that we no longer own, or being asked
2129 to convert into a type that we don't know about or that is inappropriate.
2130 This hook doesn't let you change the behavior of emacs's selection replies,
2131 it merely informs you that they have happened.
2133 Vx_sent_selection_hooks = Qunbound;
2135 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout /*
2136 If the selection owner doesn't reply in this many seconds, we give up.
2137 A value of 0 means wait as long as necessary. This is initialized from the
2138 \"*selectionTimeout\" resource (which is expressed in milliseconds).
2140 x_selection_timeout = 0;
2144 Xatoms_of_xselect (struct device *d)
2146 Display *D = DEVICE_X_DISPLAY (d);
2148 /* Non-predefined atoms that we might end up using a lot */
2149 DEVICE_XATOM_CLIPBOARD (d) = XInternAtom (D, "CLIPBOARD", False);
2150 DEVICE_XATOM_TIMESTAMP (d) = XInternAtom (D, "TIMESTAMP", False);
2151 DEVICE_XATOM_TEXT (d) = XInternAtom (D, "TEXT", False);
2152 DEVICE_XATOM_DELETE (d) = XInternAtom (D, "DELETE", False);
2153 DEVICE_XATOM_MULTIPLE (d) = XInternAtom (D, "MULTIPLE", False);
2154 DEVICE_XATOM_INCR (d) = XInternAtom (D, "INCR", False);
2155 DEVICE_XATOM_TARGETS (d) = XInternAtom (D, "TARGETS", False);
2156 DEVICE_XATOM_NULL (d) = XInternAtom (D, "NULL", False);
2157 DEVICE_XATOM_ATOM_PAIR (d) = XInternAtom (D, "ATOM_PAIR", False);
2158 DEVICE_XATOM_COMPOUND_TEXT (d) = XInternAtom (D, "COMPOUND_TEXT", False);
2159 DEVICE_XATOM_EMACS_TMP (d) = XInternAtom (D, "_EMACS_TMP_", False);