Mercurial > hg > xemacs-beta

comparison src/xselect.c @ 0:376386a54a3c r19-14

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