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 Lisp_Object local_selection_data = Qnil;
692 Lisp_Object selection_symbol;
693 Lisp_Object target_symbol = Qnil;
694 Lisp_Object converted_selection = Qnil;
695 Time local_selection_time;
696 Lisp_Object successful_p = Qnil;
698 struct device *d = get_device_from_display (event->display);
700 GCPRO3 (local_selection_data, converted_selection, target_symbol);
702 selection_symbol = x_atom_to_symbol (d, event->selection);
704 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
707 /* This list isn't user-visible, so it can't "go bad." */
708 assert (CONSP (local_selection_data));
709 assert (CONSP (XCDR (local_selection_data)));
710 assert (CONSP (XCDR (XCDR (local_selection_data))));
711 assert (NILP (XCDR (XCDR (XCDR (local_selection_data)))));
712 assert (CONSP (XCAR (XCDR (XCDR (local_selection_data)))));
713 assert (INTP (XCAR (XCAR (XCDR (XCDR (local_selection_data))))));
714 assert (INTP (XCDR (XCAR (XCDR (XCDR (local_selection_data))))));
717 if (NILP (local_selection_data))
719 /* Someone asked for the selection, but we don't have it any more. */
720 x_decline_selection_request (event);
724 local_selection_time =
725 * (Time *) XOPAQUE_DATA (XCAR (XCDR (XCDR (local_selection_data))));
727 if (event->time != CurrentTime &&
728 local_selection_time > event->time)
730 /* Someone asked for the selection, and we have one, but not the one
731 they're looking for. */
732 x_decline_selection_request (event);
736 count = specpdl_depth ();
737 record_unwind_protect (x_selection_request_lisp_error,
738 make_opaque_ptr (event));
739 target_symbol = x_atom_to_symbol (d, event->target);
741 #if 0 /* #### MULTIPLE doesn't work yet */
742 if (EQ (target_symbol, QMULTIPLE))
743 target_symbol = fetch_multiple_target (event);
746 /* Convert lisp objects back into binary data */
748 converted_selection =
749 x_get_local_selection (selection_symbol, target_symbol);
751 if (! NILP (converted_selection))
757 lisp_data_to_selection_data (d, converted_selection,
758 &data, &type, &size, &format);
760 x_reply_selection_request (event, format, data, size, type);
762 /* Tell x_selection_request_lisp_error() it's cool. */
766 unbind_to (count, Qnil);
772 /* Let random lisp code notice that the selection has been asked for. */
775 Lisp_Object val = Vx_sent_selection_hooks;
776 if (!UNBOUNDP (val) && !NILP (val))
778 if (CONSP (val) && !EQ (XCAR (val), Qlambda))
779 for (rest = val; !NILP (rest); rest = Fcdr (rest))
780 call3 (Fcar(rest), selection_symbol, target_symbol,
783 call3 (val, selection_symbol, target_symbol,
790 /* Called from the event-loop in response to a SelectionClear event.
793 x_handle_selection_clear (XSelectionClearEvent *event)
795 Display *display = event->display;
796 struct device *d = get_device_from_display (display);
797 Atom selection = event->selection;
798 Time changed_owner_time = event->time;
800 Lisp_Object selection_symbol, local_selection_data;
801 Time local_selection_time;
803 selection_symbol = x_atom_to_symbol (d, selection);
805 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
807 /* Well, we already believe that we don't own it, so that's just fine. */
808 if (NILP (local_selection_data)) return;
810 local_selection_time =
811 * (Time *) XOPAQUE_DATA (XCAR (XCDR (XCDR (local_selection_data))));
813 /* This SelectionClear is for a selection that we no longer own, so we can
814 disregard it. (That is, we have reasserted the selection since this
815 request was generated.)
817 if (changed_owner_time != CurrentTime &&
818 local_selection_time > changed_owner_time)
821 /* Otherwise, we're really honest and truly being told to drop it.
822 Don't use Fdelq() as that may QUIT;.
824 if (EQ (local_selection_data, Fcar (Vselection_alist)))
825 Vselection_alist = Fcdr (Vselection_alist);
829 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
830 if (EQ (local_selection_data, Fcar (XCDR (rest))))
832 XCDR (rest) = Fcdr (XCDR (rest));
837 /* Let random lisp code notice that the selection has been stolen.
841 Lisp_Object val = Vx_lost_selection_hooks;
842 if (!UNBOUNDP (val) && !NILP (val))
844 if (CONSP (val) && !EQ (XCAR (val), Qlambda))
845 for (rest = val; !NILP (rest); rest = Fcdr (rest))
846 call1 (Fcar (rest), selection_symbol);
848 call1 (val, selection_symbol);
854 /* This stuff is so that INCR selections are reentrant (that is, so we can
855 be servicing multiple INCR selection requests simultaneously). I haven't
856 actually tested that yet.
859 static int prop_location_tick;
861 static struct prop_location {
867 struct prop_location *next;
868 } *for_whom_the_bell_tolls;
872 property_deleted_p (void *tick)
874 struct prop_location *rest = for_whom_the_bell_tolls;
876 if (rest->tick == (long) tick)
884 waiting_for_other_props_on_window (Display *display, Window window)
886 struct prop_location *rest = for_whom_the_bell_tolls;
888 if (rest->display == display && rest->window == window)
897 expect_property_change (Display *display, Window window,
898 Atom property, int state)
900 struct prop_location *pl = xnew (struct prop_location);
901 pl->tick = ++prop_location_tick;
902 pl->display = display;
904 pl->property = property;
905 pl->desired_state = state;
906 pl->next = for_whom_the_bell_tolls;
907 for_whom_the_bell_tolls = pl;
912 unexpect_property_change (int tick)
914 struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
917 if (rest->tick == tick)
920 prev->next = rest->next;
922 for_whom_the_bell_tolls = rest->next;
932 wait_for_property_change (long tick)
934 /* This function can GC */
935 wait_delaying_user_input (property_deleted_p, (void *) tick);
939 /* Called from the event-loop in response to a PropertyNotify event.
942 x_handle_property_notify (XPropertyEvent *event)
944 struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
947 if (rest->property == event->atom &&
948 rest->window == event->window &&
949 rest->display == event->display &&
950 rest->desired_state == event->state)
953 stderr_out ("Saw expected prop-%s on %s\n",
954 (event->state == PropertyDelete ? "delete" : "change"),
955 (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name);
958 prev->next = rest->next;
960 for_whom_the_bell_tolls = rest->next;
968 stderr_out ("Saw UNexpected 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));
976 #if 0 /* #### MULTIPLE doesn't work yet */
979 fetch_multiple_target (XSelectionRequestEvent *event)
981 /* This function can GC */
982 Display *display = event->display;
983 Window window = event->requestor;
984 Atom target = event->target;
985 Atom selection_atom = event->selection;
990 x_get_window_property_as_lisp_data (display, window, target,
996 copy_multiple_data (Lisp_Object obj)
1002 return Fcons (XCAR (obj), copy_multiple_data (XCDR (obj)));
1005 len = XVECTOR_LENGTH (obj);
1006 vec = make_vector (len, Qnil);
1007 for (i = 0; i < len; i++)
1009 Lisp_Object vec2 = XVECTOR_DATA (obj) [i];
1010 CHECK_VECTOR (vec2);
1011 if (XVECTOR_LENGTH (vec2) != 2)
1012 signal_error (Qerror, list2 (build_string
1013 ("vectors must be of length 2"),
1015 XVECTOR_DATA (vec) [i] = make_vector (2, Qnil);
1016 XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [0] = XVECTOR_DATA (vec2) [0];
1017 XVECTOR_DATA (XVECTOR_DATA (vec) [i]) [1] = XVECTOR_DATA (vec2) [1];
1025 static Window reading_selection_reply;
1026 static Atom reading_which_selection;
1027 static int selection_reply_timed_out;
1030 selection_reply_done (void *ignore)
1032 return !reading_selection_reply;
1035 static Lisp_Object Qx_selection_reply_timeout_internal;
1037 DEFUN ("x-selection-reply-timeout-internal", Fx_selection_reply_timeout_internal,
1042 selection_reply_timed_out = 1;
1043 reading_selection_reply = 0;
1048 /* Do protocol to read selection-data from the server.
1049 Converts this to lisp data and returns it.
1052 x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
1054 /* This function can GC */
1055 struct device *d = decode_x_device (Qnil);
1056 Display *display = DEVICE_X_DISPLAY (d);
1057 struct frame *sel_frame = selected_frame ();
1058 Window requestor_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
1059 Time requestor_time = DEVICE_X_MOUSE_TIMESTAMP (d);
1060 Atom target_property = DEVICE_XATOM_EMACS_TMP (d);
1061 Atom selection_atom = symbol_to_x_atom (d, selection_symbol, 0);
1063 Atom type_atom = symbol_to_x_atom (d, (CONSP (target_type) ?
1064 XCAR (target_type) : target_type), 0);
1066 XConvertSelection (display, selection_atom, type_atom, target_property,
1067 requestor_window, requestor_time);
1069 /* Block until the reply has been read. */
1070 reading_selection_reply = requestor_window;
1071 reading_which_selection = selection_atom;
1072 selection_reply_timed_out = 0;
1074 speccount = specpdl_depth ();
1076 /* add a timeout handler */
1077 if (x_selection_timeout > 0)
1079 Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout),
1080 Qx_selection_reply_timeout_internal,
1082 record_unwind_protect (Fdisable_timeout, id);
1085 /* This is ^Gable */
1086 wait_delaying_user_input (selection_reply_done, 0);
1088 if (selection_reply_timed_out)
1089 error ("timed out waiting for reply from selection owner");
1091 unbind_to (speccount, Qnil);
1093 /* otherwise, the selection is waiting for us on the requested property. */
1095 x_get_window_property_as_lisp_data (display, requestor_window,
1096 target_property, target_type,
1102 x_get_window_property (Display *display, Window window, Atom property,
1103 unsigned char **data_ret, int *bytes_ret,
1104 Atom *actual_type_ret, int *actual_format_ret,
1105 unsigned long *actual_size_ret, int delete_p)
1108 unsigned long bytes_remaining;
1110 unsigned char *tmp_data = 0;
1112 int buffer_size = SELECTION_QUANTUM (display);
1113 if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
1115 /* First probe the thing to find out how big it is. */
1116 result = XGetWindowProperty (display, window, property,
1117 0, 0, False, AnyPropertyType,
1118 actual_type_ret, actual_format_ret,
1120 &bytes_remaining, &tmp_data);
1121 if (result != Success)
1127 XFree ((char *) tmp_data);
1129 if (*actual_type_ret == None || *actual_format_ret == 0)
1131 if (delete_p) XDeleteProperty (display, window, property);
1137 total_size = bytes_remaining + 1;
1138 *data_ret = (unsigned char *) xmalloc (total_size);
1140 /* Now read, until we've gotten it all. */
1141 while (bytes_remaining)
1144 int last = bytes_remaining;
1147 XGetWindowProperty (display, window, property,
1148 offset/4, buffer_size/4,
1149 (delete_p ? True : False),
1151 actual_type_ret, actual_format_ret,
1152 actual_size_ret, &bytes_remaining, &tmp_data);
1154 stderr_out ("<< read %d\n", last-bytes_remaining);
1156 /* If this doesn't return Success at this point, it means that
1157 some clod deleted the selection while we were in the midst of
1158 reading it. Deal with that, I guess....
1160 if (result != Success) break;
1161 *actual_size_ret *= *actual_format_ret / 8;
1162 memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
1163 offset += *actual_size_ret;
1164 XFree ((char *) tmp_data);
1166 *bytes_ret = offset;
1171 receive_incremental_selection (Display *display, Window window, Atom property,
1172 /* this one is for error messages only */
1173 Lisp_Object target_type,
1174 unsigned int min_size_bytes,
1175 unsigned char **data_ret, int *size_bytes_ret,
1176 Atom *type_ret, int *format_ret,
1177 unsigned long *size_ret)
1179 /* This function can GC */
1182 *size_bytes_ret = min_size_bytes;
1183 *data_ret = (unsigned char *) xmalloc (*size_bytes_ret);
1185 stderr_out ("\nread INCR %d\n", min_size_bytes);
1187 /* At this point, we have read an INCR property, and deleted it (which
1188 is how we ack its receipt: the sending window will be selecting
1189 PropertyNotify events on our window to notice this).
1191 Now, we must loop, waiting for the sending window to put a value on
1192 that property, then reading the property, then deleting it to ack.
1193 We are done when the sender places a property of length 0.
1195 prop_id = expect_property_change (display, window, property,
1199 unsigned char *tmp_data;
1201 wait_for_property_change (prop_id);
1202 /* expect it again immediately, because x_get_window_property may
1203 .. no it won't, I don't get it.
1204 .. Ok, I get it now, the Xt code that implements INCR is broken.
1206 prop_id = expect_property_change (display, window, property,
1208 x_get_window_property (display, window, property,
1209 &tmp_data, &tmp_size_bytes,
1210 type_ret, format_ret, size_ret, 1);
1212 if (tmp_size_bytes == 0) /* we're done */
1215 stderr_out (" read INCR done\n");
1217 unexpect_property_change (prop_id);
1218 if (tmp_data) xfree (tmp_data);
1222 stderr_out (" read INCR %d\n", tmp_size_bytes);
1224 if (*size_bytes_ret < offset + tmp_size_bytes)
1227 stderr_out (" read INCR realloc %d -> %d\n",
1228 *size_bytes_ret, offset + tmp_size_bytes);
1230 *size_bytes_ret = offset + tmp_size_bytes;
1231 *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret);
1233 memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
1234 offset += tmp_size_bytes;
1241 x_get_window_property_as_lisp_data (Display *display,
1244 /* next two for error messages only */
1245 Lisp_Object target_type,
1246 Atom selection_atom)
1248 /* This function can GC */
1251 unsigned long actual_size;
1252 unsigned char *data = NULL;
1255 struct device *d = get_device_from_display (display);
1257 x_get_window_property (display, window, property, &data, &bytes,
1258 &actual_type, &actual_format, &actual_size, 1);
1261 if (XGetSelectionOwner (display, selection_atom))
1262 /* there is a selection owner */
1264 (Qselection_conversion_error,
1265 Fcons (build_string ("selection owner couldn't convert"),
1266 Fcons (x_atom_to_symbol (d, selection_atom),
1268 list2 (target_type, x_atom_to_symbol (d, actual_type)) :
1269 list1 (target_type))));
1271 signal_error (Qerror,
1272 list2 (build_string ("no selection"),
1273 x_atom_to_symbol (d, selection_atom)));
1276 if (actual_type == DEVICE_XATOM_INCR (d))
1278 /* Ok, that data wasn't *the* data, it was just the beginning. */
1280 unsigned int min_size_bytes = * ((unsigned int *) data);
1282 receive_incremental_selection (display, window, property, target_type,
1283 min_size_bytes, &data, &bytes,
1284 &actual_type, &actual_format,
1288 /* It's been read. Now convert it to a lisp object in some semi-rational
1290 val = selection_data_to_lisp_data (d, data, bytes,
1291 actual_type, actual_format);
1297 /* These functions convert from the selection data read from the server into
1298 something that we can use from elisp, and vice versa.
1300 Type: Format: Size: Elisp Type:
1301 ----- ------- ----- -----------
1304 ATOM 32 > 1 Vector of Symbols
1306 * 16 > 1 Vector of Integers
1307 * 32 1 if <=16 bits: Integer
1308 if > 16 bits: Cons of top16, bot16
1309 * 32 > 1 Vector of the above
1311 When converting a Lisp number to C, it is assumed to be of format 16 if
1312 it is an integer, and of format 32 if it is a cons of two integers.
1314 When converting a vector of numbers from Elisp to C, it is assumed to be
1315 of format 16 if every element in the vector is an integer, and is assumed
1316 to be of format 32 if any element is a cons of two integers.
1318 When converting an object to C, it may be of the form (SYMBOL . <data>)
1319 where SYMBOL is what we should claim that the type is. Format and
1320 representation are as above.
1322 NOTE: Under Mule, when someone shoves us a string without a type, we
1323 set the type to 'COMPOUND_TEXT and automatically convert to Compound
1324 Text. If the string has a type, we assume that the user wants the
1325 data sent as-is so we just do "binary" conversion.
1330 selection_data_to_lisp_data (struct device *d,
1331 unsigned char *data,
1336 if (type == DEVICE_XATOM_NULL (d))
1339 /* Convert any 8-bit data to a string, for compactness. */
1340 else if (format == 8)
1341 return make_ext_string (data, size,
1342 type == DEVICE_XATOM_TEXT (d) ||
1343 type == DEVICE_XATOM_COMPOUND_TEXT (d)
1344 ? FORMAT_CTEXT : FORMAT_BINARY);
1346 /* Convert a single atom to a Lisp Symbol.
1347 Convert a set of atoms to a vector of symbols. */
1348 else if (type == XA_ATOM)
1350 if (size == sizeof (Atom))
1351 return x_atom_to_symbol (d, *((Atom *) data));
1355 int len = size / sizeof (Atom);
1356 Lisp_Object v = Fmake_vector (make_int (len), Qzero);
1357 for (i = 0; i < len; i++)
1358 Faset (v, make_int (i), x_atom_to_symbol (d, ((Atom *) data) [i]));
1363 /* Convert a single 16 or small 32 bit number to a Lisp Int.
1364 If the number is > 16 bits, convert it to a cons of integers,
1365 16 bits in each half.
1367 else if (format == 32 && size == sizeof (long))
1368 return word_to_lisp (((unsigned long *) data) [0]);
1369 else if (format == 16 && size == sizeof (short))
1370 return make_int ((int) (((unsigned short *) data) [0]));
1372 /* Convert any other kind of data to a vector of numbers, represented
1373 as above (as an integer, or a cons of two 16 bit integers).
1375 #### Perhaps we should return the actual type to lisp as well.
1377 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1380 and perhaps it should be
1382 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
1385 Right now the fact that the return type was SPAN is discarded before
1386 lisp code gets to see it.
1388 else if (format == 16)
1391 Lisp_Object v = make_vector (size / 4, Qzero);
1392 for (i = 0; i < (int) size / 4; i++)
1394 int j = (int) ((unsigned short *) data) [i];
1395 Faset (v, make_int (i), make_int (j));
1402 Lisp_Object v = make_vector (size / 4, Qzero);
1403 for (i = 0; i < (int) size / 4; i++)
1405 unsigned long j = ((unsigned long *) data) [i];
1406 Faset (v, make_int (i), word_to_lisp (j));
1414 lisp_data_to_selection_data (struct device *d,
1416 unsigned char **data_ret,
1418 unsigned int *size_ret,
1421 Lisp_Object type = Qnil;
1423 if (CONSP (obj) && SYMBOLP (XCAR (obj)))
1427 if (CONSP (obj) && NILP (XCDR (obj)))
1431 if (EQ (obj, QNULL) || (EQ (type, QNULL)))
1432 { /* This is not the same as declining */
1438 else if (STRINGP (obj))
1440 CONST Extbyte *extval;
1444 GET_STRING_CTEXT_DATA_ALLOCA (obj, extval, extvallen);
1446 GET_STRING_BINARY_DATA_ALLOCA (obj, extval, extvallen);
1448 *size_ret = extvallen;
1449 *data_ret = (unsigned char *) xmalloc (*size_ret);
1450 memcpy (*data_ret, extval, *size_ret);
1452 if (NILP (type)) type = QCOMPOUND_TEXT;
1454 if (NILP (type)) type = QSTRING;
1457 else if (CHARP (obj))
1459 Bufbyte buf[MAX_EMCHAR_LEN];
1461 CONST Extbyte *extval;
1465 len = set_charptr_emchar (buf, XCHAR (obj));
1466 GET_CHARPTR_EXT_CTEXT_DATA_ALLOCA (buf, len, extval, extvallen);
1467 *size_ret = extvallen;
1468 *data_ret = (unsigned char *) xmalloc (*size_ret);
1469 memcpy (*data_ret, extval, *size_ret);
1471 if (NILP (type)) type = QCOMPOUND_TEXT;
1473 if (NILP (type)) type = QSTRING;
1476 else if (SYMBOLP (obj))
1480 *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
1481 (*data_ret) [sizeof (Atom)] = 0;
1482 (*(Atom **) data_ret) [0] = symbol_to_x_atom (d, obj, 0);
1483 if (NILP (type)) type = QATOM;
1485 else if (INTP (obj) &&
1486 XINT (obj) <= 0x7FFF &&
1487 XINT (obj) >= -0x8000)
1491 *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
1492 (*data_ret) [sizeof (short)] = 0;
1493 (*(short **) data_ret) [0] = (short) XINT (obj);
1494 if (NILP (type)) type = QINTEGER;
1496 else if (INTP (obj) || CONSP (obj))
1500 *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
1501 (*data_ret) [sizeof (long)] = 0;
1502 (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
1503 if (NILP (type)) type = QINTEGER;
1505 else if (VECTORP (obj))
1507 /* Lisp Vectors may represent a set of ATOMs;
1508 a set of 16 or 32 bit INTEGERs;
1509 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1513 if (SYMBOLP (XVECTOR_DATA (obj) [0]))
1514 /* This vector is an ATOM set */
1516 if (NILP (type)) type = QATOM;
1517 *size_ret = XVECTOR_LENGTH (obj);
1519 *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
1520 for (i = 0; i < (int) (*size_ret); i++)
1521 if (SYMBOLP (XVECTOR_DATA (obj) [i]))
1522 (*(Atom **) data_ret) [i] =
1523 symbol_to_x_atom (d, XVECTOR_DATA (obj) [i], 0);
1525 signal_error (Qerror, /* Qselection_error */
1527 ("all elements of the vector must be of the same type"),
1530 #if 0 /* #### MULTIPLE doesn't work yet */
1531 else if (VECTORP (XVECTOR_DATA (obj) [0]))
1532 /* This vector is an ATOM_PAIR set */
1534 if (NILP (type)) type = QATOM_PAIR;
1535 *size_ret = XVECTOR_LENGTH (obj);
1537 *data_ret = (unsigned char *)
1538 xmalloc ((*size_ret) * sizeof (Atom) * 2);
1539 for (i = 0; i < *size_ret; i++)
1540 if (VECTORP (XVECTOR_DATA (obj) [i]))
1542 Lisp_Object pair = XVECTOR_DATA (obj) [i];
1543 if (XVECTOR_LENGTH (pair) != 2)
1544 signal_error (Qerror,
1546 ("elements of the vector must be vectors of exactly two elements"),
1549 (*(Atom **) data_ret) [i * 2] =
1550 symbol_to_x_atom (d, XVECTOR_DATA (pair) [0], 0);
1551 (*(Atom **) data_ret) [(i * 2) + 1] =
1552 symbol_to_x_atom (d, XVECTOR_DATA (pair) [1], 0);
1555 signal_error (Qerror,
1557 ("all elements of the vector must be of the same type"),
1562 /* This vector is an INTEGER set, or something like it */
1564 *size_ret = XVECTOR_LENGTH (obj);
1565 if (NILP (type)) type = QINTEGER;
1567 for (i = 0; i < (int) (*size_ret); i++)
1568 if (CONSP (XVECTOR_DATA (obj) [i]))
1570 else if (!INTP (XVECTOR_DATA (obj) [i]))
1571 signal_error (Qerror, /* Qselection_error */
1573 ("all elements of the vector must be integers or conses of integers"),
1576 *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
1577 for (i = 0; i < (int) (*size_ret); i++)
1578 if (*format_ret == 32)
1579 (*((unsigned long **) data_ret)) [i] =
1580 lisp_to_word (XVECTOR_DATA (obj) [i]);
1582 (*((unsigned short **) data_ret)) [i] =
1583 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
1587 signal_error (Qerror, /* Qselection_error */
1588 list2 (build_string ("unrecognized selection data"),
1591 *type_ret = symbol_to_x_atom (d, type, 0);
1595 clean_local_selection_data (Lisp_Object obj)
1598 INTP (XCAR (obj)) &&
1599 CONSP (XCDR (obj)) &&
1600 INTP (XCAR (XCDR (obj))) &&
1601 NILP (XCDR (XCDR (obj))))
1602 obj = Fcons (XCAR (obj), XCDR (obj));
1605 INTP (XCAR (obj)) &&
1608 if (XINT (XCAR (obj)) == 0)
1610 if (XINT (XCAR (obj)) == -1)
1611 return make_int (- XINT (XCDR (obj)));
1616 int len = XVECTOR_LENGTH (obj);
1619 return clean_local_selection_data (XVECTOR_DATA (obj) [0]);
1620 copy = make_vector (len, Qnil);
1621 for (i = 0; i < len; i++)
1622 XVECTOR_DATA (copy) [i] =
1623 clean_local_selection_data (XVECTOR_DATA (obj) [i]);
1630 /* Called from the event loop to handle SelectionNotify events.
1631 I don't think this needs to be reentrant.
1634 x_handle_selection_notify (XSelectionEvent *event)
1636 if (! reading_selection_reply)
1637 message ("received an unexpected SelectionNotify event");
1638 else if (event->requestor != reading_selection_reply)
1639 message ("received a SelectionNotify event for the wrong window");
1640 else if (event->selection != reading_which_selection)
1641 message ("received the wrong selection type in SelectionNotify!");
1643 reading_selection_reply = 0; /* we're done now. */
1647 DEFUN ("x-own-selection-internal", Fx_own_selection_internal, 2, 2, 0, /*
1648 Assert an X selection of the given TYPE with the given VALUE.
1649 TYPE is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD.
1650 VALUE is typically a string, or a cons of two markers, but may be
1651 anything that the functions on selection-converter-alist know about.
1653 (selection_name, selection_value))
1655 CHECK_SYMBOL (selection_name);
1656 if (NILP (selection_value)) error ("selection-value may not be nil.");
1657 x_own_selection (selection_name, selection_value);
1658 return selection_value;
1662 /* Request the selection value from the owner. If we are the owner,
1663 simply return our selection value. If we are not the owner, this
1664 will block until all of the data has arrived.
1666 DEFUN ("x-get-selection-internal", Fx_get_selection_internal, 2, 2, 0, /*
1667 Return text selected from some X window.
1668 SELECTION_SYMBOL is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD.
1669 TARGET_TYPE is the type of data desired, typically STRING or COMPOUND_TEXT.
1670 Under Mule, if the resultant data comes back as 8-bit data in type
1671 TEXT or COMPOUND_TEXT, it will be decoded as Compound Text.
1673 (selection_symbol, target_type))
1675 /* This function can GC */
1676 Lisp_Object val = Qnil;
1677 struct gcpro gcpro1, gcpro2;
1678 GCPRO2 (target_type, val); /* we store newly consed data into these */
1679 CHECK_SYMBOL (selection_symbol);
1681 #if 0 /* #### MULTIPLE doesn't work yet */
1682 if (CONSP (target_type) &&
1683 XCAR (target_type) == QMULTIPLE)
1685 CHECK_VECTOR (XCDR (target_type));
1686 /* So we don't destructively modify this... */
1687 target_type = copy_multiple_data (target_type);
1691 CHECK_SYMBOL (target_type);
1693 val = x_get_local_selection (selection_symbol, target_type);
1697 val = x_get_foreign_selection (selection_symbol, target_type);
1701 if (CONSP (val) && SYMBOLP (XCAR (val)))
1704 if (CONSP (val) && NILP (XCDR (val)))
1707 val = clean_local_selection_data (val);
1713 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal, 1, 2, 0, /*
1714 If we own the named selection, then disown it (make there be no selection).
1716 (selection, timeval))
1718 struct device *d = decode_x_device (Qnil);
1719 Display *display = DEVICE_X_DISPLAY (d);
1721 Atom selection_atom;
1722 XSelectionClearEvent event;
1724 CHECK_SYMBOL (selection);
1726 timestamp = DEVICE_X_MOUSE_TIMESTAMP (d);
1729 /* #### This is bogus. See the comment above about problems
1730 on OSF/1 and DEC Alphas. Yet another reason why it sucks
1731 to have the implementation (i.e. cons of two 16-bit
1732 integers) exposed. */
1734 lisp_to_time (timeval, &the_time);
1735 timestamp = (Time) the_time;
1738 if (NILP (assq_no_quit (selection, Vselection_alist)))
1739 return Qnil; /* Don't disown the selection when we're not the owner. */
1741 selection_atom = symbol_to_x_atom (d, selection, 0);
1743 XSetSelectionOwner (display, selection_atom, None, timestamp);
1745 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1746 generated for a window which owns the selection when that window sets
1747 the selection owner to None. The NCD server does, the MIT Sun4 server
1748 doesn't. So we synthesize one; this means we might get two, but
1749 that's ok, because the second one won't have any effect.
1751 event.display = display;
1752 event.selection = selection_atom;
1753 event.time = timestamp;
1754 x_handle_selection_clear (&event);
1760 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, 0, 1, 0, /*
1761 Return t if current emacs process owns the given X Selection.
1762 The arg should be the name of the selection in question, typically one of
1763 the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, the symbol
1764 nil is the same as PRIMARY, and t is the same as SECONDARY.)
1768 CHECK_SYMBOL (selection);
1769 if (EQ (selection, Qnil)) selection = QPRIMARY;
1770 else if (EQ (selection, Qt)) selection = QSECONDARY;
1772 return NILP (Fassq (selection, Vselection_alist)) ? Qnil : Qt;
1775 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, 0, 1, 0, /*
1776 Whether there is an owner for the given X Selection.
1777 The arg should be the name of the selection in question, typically one of
1778 the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience, the symbol
1779 nil is the same as PRIMARY, and t is the same as SECONDARY.)
1783 struct device *d = decode_x_device (Qnil);
1784 Display *dpy = DEVICE_X_DISPLAY (d);
1785 CHECK_SYMBOL (selection);
1786 if (!NILP (Fx_selection_owner_p (selection)))
1788 return XGetSelectionOwner (dpy, symbol_to_x_atom (d, selection, 0)) != None ?
1793 #ifdef CUT_BUFFER_SUPPORT
1795 static int cut_buffers_initialized; /* Whether we're sure they all exist */
1797 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1799 initialize_cut_buffers (Display *display, Window window)
1801 static unsigned CONST char * CONST data = (unsigned CONST char *) "";
1802 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1803 PropModeAppend, data, 0)
1804 FROB (XA_CUT_BUFFER0);
1805 FROB (XA_CUT_BUFFER1);
1806 FROB (XA_CUT_BUFFER2);
1807 FROB (XA_CUT_BUFFER3);
1808 FROB (XA_CUT_BUFFER4);
1809 FROB (XA_CUT_BUFFER5);
1810 FROB (XA_CUT_BUFFER6);
1811 FROB (XA_CUT_BUFFER7);
1813 cut_buffers_initialized = 1;
1816 #define CHECK_CUTBUFFER(symbol) \
1817 { CHECK_SYMBOL (symbol); \
1818 if (!EQ((symbol),QCUT_BUFFER0) && !EQ((symbol),QCUT_BUFFER1) && \
1819 !EQ((symbol),QCUT_BUFFER2) && !EQ((symbol),QCUT_BUFFER3) && \
1820 !EQ((symbol),QCUT_BUFFER4) && !EQ((symbol),QCUT_BUFFER5) && \
1821 !EQ((symbol),QCUT_BUFFER6) && !EQ((symbol),QCUT_BUFFER7)) \
1822 signal_error (Qerror, list2 (build_string ("Doesn't name a cutbuffer"), \
1826 DEFUN ("x-get-cutbuffer-internal", Fx_get_cutbuffer_internal, 1, 1, 0, /*
1827 Return the value of the named CUTBUFFER (typically CUT_BUFFER0).
1831 struct device *d = decode_x_device (Qnil);
1832 Display *display = DEVICE_X_DISPLAY (d);
1833 Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1834 Atom cut_buffer_atom;
1835 unsigned char *data;
1842 CHECK_CUTBUFFER (cutbuffer);
1843 cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1845 x_get_window_property (display, window, cut_buffer_atom, &data, &bytes,
1846 &type, &format, &size, 0);
1847 if (!data) return Qnil;
1849 if (format != 8 || type != XA_STRING)
1850 signal_simple_error_2 ("Cut buffer doesn't contain 8-bit STRING data",
1851 x_atom_to_symbol (d, type),
1854 /* We cheat - if the string contains an ESC character, that's
1855 technically not allowed in a STRING, so we assume it's
1856 COMPOUND_TEXT that we stored there ourselves earlier,
1857 in x-store-cutbuffer-internal */
1859 make_ext_string (data, bytes,
1860 memchr (data, 0x1b, bytes) ?
1861 FORMAT_CTEXT : FORMAT_BINARY)
1868 DEFUN ("x-store-cutbuffer-internal", Fx_store_cutbuffer_internal, 2, 2, 0, /*
1869 Set the value of the named CUTBUFFER (typically CUT_BUFFER0) to STRING.
1871 (cutbuffer, string))
1873 struct device *d = decode_x_device (Qnil);
1874 Display *display = DEVICE_X_DISPLAY (d);
1875 Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1876 Atom cut_buffer_atom;
1877 CONST Extbyte *data = XSTRING_DATA (string);
1878 Extcount bytes = XSTRING_LENGTH (string);
1879 Extcount bytes_remaining;
1880 int max_bytes = SELECTION_QUANTUM (display);
1882 CONST Bufbyte *ptr, *end;
1883 enum { ASCII, LATIN_1, WORLD } chartypes = ASCII;
1886 if (max_bytes > MAX_SELECTION_QUANTUM)
1887 max_bytes = MAX_SELECTION_QUANTUM;
1889 CHECK_CUTBUFFER (cutbuffer);
1890 CHECK_STRING (string);
1891 cut_buffer_atom = symbol_to_x_atom (d, cutbuffer, 0);
1893 if (! cut_buffers_initialized)
1894 initialize_cut_buffers (display, window);
1896 /* We use the STRING encoding (Latin-1 only) if we can, else COMPOUND_TEXT.
1897 We cheat and use type = `STRING' even when using COMPOUND_TEXT.
1898 The ICCCM requires that this be so, and other clients assume it,
1899 as we do ourselves in initialize_cut_buffers. */
1902 /* Optimize for the common ASCII case */
1903 for (ptr = data, end = ptr + bytes; ptr <= end; )
1905 if (BYTE_ASCII_P (*ptr))
1911 if ((*ptr) == LEADING_BYTE_LATIN_ISO8859_1 ||
1912 (*ptr) == LEADING_BYTE_CONTROL_1)
1914 chartypes = LATIN_1;
1923 if (chartypes == LATIN_1)
1924 GET_STRING_BINARY_DATA_ALLOCA (string, data, bytes);
1925 else if (chartypes == WORLD)
1926 GET_STRING_CTEXT_DATA_ALLOCA (string, data, bytes);
1929 bytes_remaining = bytes;
1931 while (bytes_remaining)
1933 int chunk = bytes_remaining < max_bytes ? bytes_remaining : max_bytes;
1934 XChangeProperty (display, window, cut_buffer_atom, XA_STRING, 8,
1935 (bytes_remaining == bytes
1936 ? PropModeReplace : PropModeAppend),
1939 bytes_remaining -= chunk;
1945 DEFUN ("x-rotate-cutbuffers-internal", Fx_rotate_cutbuffers_internal, 1, 1, 0, /*
1946 Rotate the values of the cutbuffers by the given number of steps;
1947 positive means move values forward, negative means backward.
1951 struct device *d = decode_x_device (Qnil);
1952 Display *display = DEVICE_X_DISPLAY (d);
1953 Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
1959 if (! cut_buffers_initialized)
1960 initialize_cut_buffers (display, window);
1961 props[0] = XA_CUT_BUFFER0;
1962 props[1] = XA_CUT_BUFFER1;
1963 props[2] = XA_CUT_BUFFER2;
1964 props[3] = XA_CUT_BUFFER3;
1965 props[4] = XA_CUT_BUFFER4;
1966 props[5] = XA_CUT_BUFFER5;
1967 props[6] = XA_CUT_BUFFER6;
1968 props[7] = XA_CUT_BUFFER7;
1969 XRotateWindowProperties (display, window, props, 8, XINT (n));
1973 #endif /* CUT_BUFFER_SUPPORT */
1977 /************************************************************************/
1978 /* initialization */
1979 /************************************************************************/
1982 syms_of_xselect (void)
1984 DEFSUBR (Fx_get_selection_internal);
1985 DEFSUBR (Fx_own_selection_internal);
1986 DEFSUBR (Fx_disown_selection_internal);
1987 DEFSUBR (Fx_selection_owner_p);
1988 DEFSUBR (Fx_selection_exists_p);
1990 #ifdef CUT_BUFFER_SUPPORT
1991 DEFSUBR (Fx_get_cutbuffer_internal);
1992 DEFSUBR (Fx_store_cutbuffer_internal);
1993 DEFSUBR (Fx_rotate_cutbuffers_internal);
1994 #endif /* CUT_BUFFER_SUPPORT */
1996 /* Unfortunately, timeout handlers must be lisp functions. */
1997 defsymbol (&Qx_selection_reply_timeout_internal,
1998 "x-selection-reply-timeout-internal");
1999 DEFSUBR (Fx_selection_reply_timeout_internal);
2001 defsymbol (&QPRIMARY, "PRIMARY");
2002 defsymbol (&QSECONDARY, "SECONDARY");
2003 defsymbol (&QSTRING, "STRING");
2004 defsymbol (&QINTEGER, "INTEGER");
2005 defsymbol (&QCLIPBOARD, "CLIPBOARD");
2006 defsymbol (&QTIMESTAMP, "TIMESTAMP");
2007 defsymbol (&QTEXT, "TEXT");
2008 defsymbol (&QDELETE, "DELETE");
2009 defsymbol (&QMULTIPLE, "MULTIPLE");
2010 defsymbol (&QINCR, "INCR");
2011 defsymbol (&QEMACS_TMP, "_EMACS_TMP_");
2012 defsymbol (&QTARGETS, "TARGETS");
2013 defsymbol (&QATOM, "ATOM");
2014 defsymbol (&QATOM_PAIR, "ATOM_PAIR");
2015 defsymbol (&QCOMPOUND_TEXT, "COMPOUND_TEXT");
2016 defsymbol (&QNULL, "NULL");
2018 #ifdef CUT_BUFFER_SUPPORT
2019 defsymbol (&QCUT_BUFFER0, "CUT_BUFFER0");
2020 defsymbol (&QCUT_BUFFER1, "CUT_BUFFER1");
2021 defsymbol (&QCUT_BUFFER2, "CUT_BUFFER2");
2022 defsymbol (&QCUT_BUFFER3, "CUT_BUFFER3");
2023 defsymbol (&QCUT_BUFFER4, "CUT_BUFFER4");
2024 defsymbol (&QCUT_BUFFER5, "CUT_BUFFER5");
2025 defsymbol (&QCUT_BUFFER6, "CUT_BUFFER6");
2026 defsymbol (&QCUT_BUFFER7, "CUT_BUFFER7");
2027 #endif /* CUT_BUFFER_SUPPORT */
2029 deferror (&Qselection_conversion_error,
2030 "selection-conversion-error",
2031 "selection-conversion error", Qio_error);
2035 vars_of_xselect (void)
2037 #ifdef CUT_BUFFER_SUPPORT
2038 cut_buffers_initialized = 0;
2039 Fprovide (intern ("cut-buffer"));
2042 reading_selection_reply = 0;
2043 reading_which_selection = 0;
2044 selection_reply_timed_out = 0;
2045 for_whom_the_bell_tolls = 0;
2046 prop_location_tick = 0;
2048 Vselection_alist = Qnil;
2049 staticpro (&Vselection_alist);
2051 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist /*
2052 An alist associating selection-types (such as STRING and TIMESTAMP) with
2053 functions. These functions will be called with three args: the name of the
2054 selection (typically PRIMARY, SECONDARY, or CLIPBOARD); a desired type to
2055 which the selection should be converted; and the local selection value
2056 (whatever had been passed to `x-own-selection'). These functions should
2057 return the value to send to the X server, which should be one of:
2059 -- nil (the conversion could not be done)
2060 -- a cons of a symbol and any of the following values; the symbol
2061 explicitly specifies the type that will be sent.
2062 -- a string (If the type is not specified, then if Mule support exists,
2063 the string will be converted to Compound Text and sent in
2064 the 'COMPOUND_TEXT format; otherwise (no Mule support),
2065 the string will be left as-is and sent in the 'STRING
2066 format. If the type is specified, the string will be
2067 left as-is (or converted to binary format under Mule).
2068 In all cases, 8-bit data it sent.)
2069 -- a character (With Mule support, will be converted to Compound Text
2070 whether or not a type is specified. If a type is not
2071 specified, a type of 'STRING or 'COMPOUND_TEXT will be
2072 sent, as for strings.)
2073 -- the symbol 'NULL (Indicates that there is no meaningful return value.
2074 Empty 32-bit data with a type of 'NULL will be sent.)
2075 -- a symbol (Will be converted into an atom. If the type is not specified,
2076 a type of 'ATOM will be sent.)
2077 -- an integer (Will be converted into a 16-bit or 32-bit integer depending
2078 on the value. If the type is not specified, a type of
2079 'INTEGER will be sent.)
2080 -- a cons (HIGH . LOW) of integers (Will be converted into a 32-bit integer.
2081 If the type is not specified, a type of
2082 'INTEGER will be sent.)
2083 -- a vector of symbols (Will be converted into a list of atoms. If the type
2084 is not specified, a type of 'ATOM will be sent.)
2085 -- a vector of integers (Will be converted into a list of 16-bit integers.
2086 If the type is not specified, a type of 'INTEGER
2088 -- a vector of integers and/or conses (HIGH . LOW) of integers
2089 (Will be converted into a list of 16-bit integers.
2090 If the type is not specified, a type of 'INTEGER
2093 Vselection_converter_alist = Qnil;
2095 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks /*
2096 A function or functions to be called after the X server has notified us
2097 that we have lost the selection. The function(s) will be called with one
2098 argument, a symbol naming the selection (typically PRIMARY, SECONDARY, or
2101 Vx_lost_selection_hooks = Qunbound;
2103 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks /*
2104 A function or functions to be called after we have responded to some
2105 other client's request for the value of a selection that we own. The
2106 function(s) will be called with four arguments:
2107 - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);
2108 - the name of the selection-type which we were requested to convert the
2109 selection into before sending (for example, STRING or LENGTH);
2110 - and whether we successfully transmitted the selection.
2111 We might have failed (and declined the request) for any number of reasons,
2112 including being asked for a selection that we no longer own, or being asked
2113 to convert into a type that we don't know about or that is inappropriate.
2114 This hook doesn't let you change the behavior of emacs's selection replies,
2115 it merely informs you that they have happened.
2117 Vx_sent_selection_hooks = Qunbound;
2119 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout /*
2120 If the selection owner doesn't reply in this many seconds, we give up.
2121 A value of 0 means wait as long as necessary. This is initialized from the
2122 \"*selectionTimeout\" resource (which is expressed in milliseconds).
2124 x_selection_timeout = 0;
2128 Xatoms_of_xselect (struct device *d)
2130 Display *D = DEVICE_X_DISPLAY (d);
2132 /* Non-predefined atoms that we might end up using a lot */
2133 DEVICE_XATOM_CLIPBOARD (d) = XInternAtom (D, "CLIPBOARD", False);
2134 DEVICE_XATOM_TIMESTAMP (d) = XInternAtom (D, "TIMESTAMP", False);
2135 DEVICE_XATOM_TEXT (d) = XInternAtom (D, "TEXT", False);
2136 DEVICE_XATOM_DELETE (d) = XInternAtom (D, "DELETE", False);
2137 DEVICE_XATOM_MULTIPLE (d) = XInternAtom (D, "MULTIPLE", False);
2138 DEVICE_XATOM_INCR (d) = XInternAtom (D, "INCR", False);
2139 DEVICE_XATOM_TARGETS (d) = XInternAtom (D, "TARGETS", False);
2140 DEVICE_XATOM_NULL (d) = XInternAtom (D, "NULL", False);
2141 DEVICE_XATOM_ATOM_PAIR (d) = XInternAtom (D, "ATOM_PAIR", False);
2142 DEVICE_XATOM_COMPOUND_TEXT (d) = XInternAtom (D, "COMPOUND_TEXT", False);
2143 DEVICE_XATOM_EMACS_TMP (d) = XInternAtom (D, "_EMACS_TMP_", False);