Mercurial > hg > xemacs-beta

comparison src/xselect.c @ 412:697ef44129c6 r21-2-14

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