Mercurial > hg > xemacs-beta

comparison src/select-x.c @ 414:da8ed4261e83 r21-2-15

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