Mercurial > hg > xemacs-beta

comparison src/select-x.c @ 398:74fd4e045ea6 r21-2-29

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