(Fnumber_to_string, Fstring_to_number):
[bpt/emacs.git] / src / xselect.c
CommitLineData
2408b3a1 1/* X Selection processing for Emacs.
f8c25f1b 2 Copyright (C) 1993, 1994, 1995 Free Software Foundation.
ede4db72
RS
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 2, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
c6c5df7f 20
ede4db72
RS
21/* Rewritten by jwz */
22
18160b98 23#include <config.h>
ede4db72
RS
24#include "lisp.h"
25#include "xterm.h" /* for all of the X includes */
7da64e5c
RS
26#include "dispextern.h" /* frame.h seems to want this */
27#include "frame.h" /* Need this to get the X window of selected_frame */
9ac0d9e0 28#include "blockinput.h"
7da64e5c
RS
29
30#define xfree free
ede4db72
RS
31
32#define CUT_BUFFER_SUPPORT
33
ede4db72
RS
34Lisp_Object QPRIMARY, QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP,
35 QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL,
36 QATOM_PAIR;
37
38#ifdef CUT_BUFFER_SUPPORT
39Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
40 QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
41#endif
42
43Lisp_Object Vx_lost_selection_hooks;
44Lisp_Object Vx_sent_selection_hooks;
45
46/* If this is a smaller number than the max-request-size of the display,
47 emacs will use INCR selection transfer when the selection is larger
48 than this. The max-request-size is usually around 64k, so if you want
49 emacs to use incremental selection transfers when the selection is
50 smaller than that, set this. I added this mostly for debugging the
51 incremental transfer stuff, but it might improve server performance.
52 */
53#define MAX_SELECTION_QUANTUM 0xFFFFFF
54
c3498e64
JB
55#ifdef HAVE_X11R4
56#define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
57#else
58#define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
59#endif
ede4db72 60
7da64e5c
RS
61/* The timestamp of the last input event Emacs received from the X server. */
62unsigned long last_event_timestamp;
ede4db72
RS
63
64/* This is an association list whose elements are of the form
118bd841
RS
65 ( SELECTION-NAME SELECTION-VALUE SELECTION-TIMESTAMP FRAME)
66 SELECTION-NAME is a lisp symbol, whose name is the name of an X Atom.
67 SELECTION-VALUE is the value that emacs owns for that selection.
ede4db72 68 It may be any kind of Lisp object.
118bd841 69 SELECTION-TIMESTAMP is the time at which emacs began owning this selection,
ede4db72 70 as a cons of two 16-bit numbers (making a 32 bit time.)
118bd841
RS
71 FRAME is the frame for which we made the selection.
72 If there is an entry in this alist, then it can be assumed that Emacs owns
ede4db72
RS
73 that selection.
74 The only (eq) parts of this list that are visible from Lisp are the
75 selection-values.
76 */
77Lisp_Object Vselection_alist;
78
79/* This is an alist whose CARs are selection-types (whose names are the same
80 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
81 call to convert the given Emacs selection value to a string representing
82 the given selection type. This is for Lisp-level extension of the emacs
83 selection handling.
84 */
85Lisp_Object Vselection_converter_alist;
86
87/* If the selection owner takes too long to reply to a selection request,
80da0190 88 we give up on it. This is in milliseconds (0 = no timeout.)
ede4db72
RS
89 */
90int x_selection_timeout;
ede4db72
RS
91\f
92/* Utility functions */
93
94static void lisp_data_to_selection_data ();
95static Lisp_Object selection_data_to_lisp_data ();
96static Lisp_Object x_get_window_property_as_lisp_data ();
97
ede4db72
RS
98/* This converts a Lisp symbol to a server Atom, avoiding a server
99 roundtrip whenever possible. */
100
101static Atom
5c3a351a
RS
102symbol_to_x_atom (dpyinfo, display, sym)
103 struct x_display_info *dpyinfo;
ede4db72
RS
104 Display *display;
105 Lisp_Object sym;
106{
107 Atom val;
108 if (NILP (sym)) return 0;
109 if (EQ (sym, QPRIMARY)) return XA_PRIMARY;
110 if (EQ (sym, QSECONDARY)) return XA_SECONDARY;
111 if (EQ (sym, QSTRING)) return XA_STRING;
112 if (EQ (sym, QINTEGER)) return XA_INTEGER;
113 if (EQ (sym, QATOM)) return XA_ATOM;
5c3a351a
RS
114 if (EQ (sym, QCLIPBOARD)) return dpyinfo->Xatom_CLIPBOARD;
115 if (EQ (sym, QTIMESTAMP)) return dpyinfo->Xatom_TIMESTAMP;
116 if (EQ (sym, QTEXT)) return dpyinfo->Xatom_TEXT;
117 if (EQ (sym, QDELETE)) return dpyinfo->Xatom_DELETE;
118 if (EQ (sym, QMULTIPLE)) return dpyinfo->Xatom_MULTIPLE;
119 if (EQ (sym, QINCR)) return dpyinfo->Xatom_INCR;
120 if (EQ (sym, QEMACS_TMP)) return dpyinfo->Xatom_EMACS_TMP;
121 if (EQ (sym, QTARGETS)) return dpyinfo->Xatom_TARGETS;
122 if (EQ (sym, QNULL)) return dpyinfo->Xatom_NULL;
ede4db72
RS
123#ifdef CUT_BUFFER_SUPPORT
124 if (EQ (sym, QCUT_BUFFER0)) return XA_CUT_BUFFER0;
125 if (EQ (sym, QCUT_BUFFER1)) return XA_CUT_BUFFER1;
126 if (EQ (sym, QCUT_BUFFER2)) return XA_CUT_BUFFER2;
127 if (EQ (sym, QCUT_BUFFER3)) return XA_CUT_BUFFER3;
128 if (EQ (sym, QCUT_BUFFER4)) return XA_CUT_BUFFER4;
129 if (EQ (sym, QCUT_BUFFER5)) return XA_CUT_BUFFER5;
130 if (EQ (sym, QCUT_BUFFER6)) return XA_CUT_BUFFER6;
131 if (EQ (sym, QCUT_BUFFER7)) return XA_CUT_BUFFER7;
132#endif
133 if (!SYMBOLP (sym)) abort ();
134
135#if 0
136 fprintf (stderr, " XInternAtom %s\n", (char *) XSYMBOL (sym)->name->data);
137#endif
138 BLOCK_INPUT;
139 val = XInternAtom (display, (char *) XSYMBOL (sym)->name->data, False);
140 UNBLOCK_INPUT;
141 return val;
142}
143
144
145/* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
146 and calls to intern whenever possible. */
147
148static Lisp_Object
5c3a351a
RS
149x_atom_to_symbol (dpyinfo, display, atom)
150 struct x_display_info *dpyinfo;
ede4db72
RS
151 Display *display;
152 Atom atom;
153{
154 char *str;
155 Lisp_Object val;
156 if (! atom) return Qnil;
7da64e5c
RS
157 switch (atom)
158 {
159 case XA_PRIMARY:
160 return QPRIMARY;
161 case XA_SECONDARY:
162 return QSECONDARY;
163 case XA_STRING:
164 return QSTRING;
165 case XA_INTEGER:
166 return QINTEGER;
167 case XA_ATOM:
168 return QATOM;
ede4db72 169#ifdef CUT_BUFFER_SUPPORT
7da64e5c
RS
170 case XA_CUT_BUFFER0:
171 return QCUT_BUFFER0;
172 case XA_CUT_BUFFER1:
173 return QCUT_BUFFER1;
174 case XA_CUT_BUFFER2:
175 return QCUT_BUFFER2;
176 case XA_CUT_BUFFER3:
177 return QCUT_BUFFER3;
178 case XA_CUT_BUFFER4:
179 return QCUT_BUFFER4;
180 case XA_CUT_BUFFER5:
181 return QCUT_BUFFER5;
182 case XA_CUT_BUFFER6:
183 return QCUT_BUFFER6;
184 case XA_CUT_BUFFER7:
185 return QCUT_BUFFER7;
ede4db72 186#endif
7da64e5c
RS
187 }
188
5c3a351a 189 if (atom == dpyinfo->Xatom_CLIPBOARD)
7da64e5c 190 return QCLIPBOARD;
5c3a351a 191 if (atom == dpyinfo->Xatom_TIMESTAMP)
7da64e5c 192 return QTIMESTAMP;
5c3a351a 193 if (atom == dpyinfo->Xatom_TEXT)
7da64e5c 194 return QTEXT;
5c3a351a 195 if (atom == dpyinfo->Xatom_DELETE)
7da64e5c 196 return QDELETE;
5c3a351a 197 if (atom == dpyinfo->Xatom_MULTIPLE)
7da64e5c 198 return QMULTIPLE;
5c3a351a 199 if (atom == dpyinfo->Xatom_INCR)
7da64e5c 200 return QINCR;
5c3a351a 201 if (atom == dpyinfo->Xatom_EMACS_TMP)
7da64e5c 202 return QEMACS_TMP;
5c3a351a 203 if (atom == dpyinfo->Xatom_TARGETS)
7da64e5c 204 return QTARGETS;
5c3a351a 205 if (atom == dpyinfo->Xatom_NULL)
7da64e5c 206 return QNULL;
ede4db72
RS
207
208 BLOCK_INPUT;
209 str = XGetAtomName (display, atom);
210 UNBLOCK_INPUT;
211#if 0
212 fprintf (stderr, " XGetAtomName --> %s\n", str);
213#endif
214 if (! str) return Qnil;
215 val = intern (str);
216 BLOCK_INPUT;
217 XFree (str);
218 UNBLOCK_INPUT;
219 return val;
220}
8a89415e 221\f
ede4db72
RS
222/* Do protocol to assert ourself as a selection owner.
223 Update the Vselection_alist so that we can reply to later requests for
224 our selection. */
225
226static void
227x_own_selection (selection_name, selection_value)
228 Lisp_Object selection_name, selection_value;
229{
ede4db72 230 Window selecting_window = FRAME_X_WINDOW (selected_frame);
3834c318 231 Display *display = FRAME_X_DISPLAY (selected_frame);
7da64e5c 232 Time time = last_event_timestamp;
ede4db72 233 Atom selection_atom;
5c3a351a 234 struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (selected_frame);
ede4db72
RS
235
236 CHECK_SYMBOL (selection_name, 0);
5c3a351a 237 selection_atom = symbol_to_x_atom (dpyinfo, display, selection_name);
ede4db72
RS
238
239 BLOCK_INPUT;
a7b24d46 240 x_catch_errors (display);
ede4db72 241 XSetSelectionOwner (display, selection_atom, selecting_window, time);
a7b24d46
RS
242 x_check_errors (display, "Can't set selection: %s");
243 x_uncatch_errors (display);
ede4db72
RS
244 UNBLOCK_INPUT;
245
246 /* Now update the local cache */
247 {
248 Lisp_Object selection_time;
249 Lisp_Object selection_data;
250 Lisp_Object prev_value;
251
252 selection_time = long_to_cons ((unsigned long) time);
253 selection_data = Fcons (selection_name,
254 Fcons (selection_value,
118bd841
RS
255 Fcons (selection_time,
256 Fcons (Fselected_frame (), Qnil))));
ede4db72
RS
257 prev_value = assq_no_quit (selection_name, Vselection_alist);
258
259 Vselection_alist = Fcons (selection_data, Vselection_alist);
260
261 /* If we already owned the selection, remove the old selection data.
262 Perhaps we should destructively modify it instead.
263 Don't use Fdelq as that may QUIT. */
264 if (!NILP (prev_value))
265 {
266 Lisp_Object rest; /* we know it's not the CAR, so it's easy. */
267 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
268 if (EQ (prev_value, Fcar (XCONS (rest)->cdr)))
269 {
270 XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr);
271 break;
272 }
273 }
274 }
275}
276\f
277/* Given a selection-name and desired type, look up our local copy of
278 the selection value and convert it to the type.
279 The value is nil or a string.
280 This function is used both for remote requests
7da64e5c 281 and for local x-get-selection-internal.
ede4db72
RS
282
283 This calls random Lisp code, and may signal or gc. */
284
285static Lisp_Object
286x_get_local_selection (selection_symbol, target_type)
287 Lisp_Object selection_symbol, target_type;
288{
289 Lisp_Object local_value;
290 Lisp_Object handler_fn, value, type, check;
291 int count;
292
293 local_value = assq_no_quit (selection_symbol, Vselection_alist);
294
295 if (NILP (local_value)) return Qnil;
296
297 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
298 if (EQ (target_type, QTIMESTAMP))
299 {
300 handler_fn = Qnil;
301 value = XCONS (XCONS (XCONS (local_value)->cdr)->cdr)->car;
302 }
303#if 0
304 else if (EQ (target_type, QDELETE))
305 {
306 handler_fn = Qnil;
307 Fx_disown_selection_internal
308 (selection_symbol,
309 XCONS (XCONS (XCONS (local_value)->cdr)->cdr)->car);
310 value = QNULL;
311 }
312#endif
313
314#if 0 /* #### MULTIPLE doesn't work yet */
315 else if (CONSP (target_type)
316 && XCONS (target_type)->car == QMULTIPLE)
317 {
9d2d1dd8
KH
318 Lisp_Object pairs;
319 int size;
ede4db72 320 int i;
9d2d1dd8
KH
321 pairs = XCONS (target_type)->cdr;
322 size = XVECTOR (pairs)->size;
ede4db72
RS
323 /* If the target is MULTIPLE, then target_type looks like
324 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
325 We modify the second element of each pair in the vector and
326 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
327 */
328 for (i = 0; i < size; i++)
329 {
9d2d1dd8
KH
330 Lisp_Object pair;
331 pair = XVECTOR (pairs)->contents [i];
ede4db72
RS
332 XVECTOR (pair)->contents [1]
333 = x_get_local_selection (XVECTOR (pair)->contents [0],
334 XVECTOR (pair)->contents [1]);
335 }
336 return pairs;
337 }
338#endif
339 else
340 {
341 /* Don't allow a quit within the converter.
342 When the user types C-g, he would be surprised
343 if by luck it came during a converter. */
344 count = specpdl_ptr - specpdl;
345 specbind (Qinhibit_quit, Qt);
346
347 CHECK_SYMBOL (target_type, 0);
348 handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
1eb4d468
RS
349 if (!NILP (handler_fn))
350 value = call3 (handler_fn,
351 selection_symbol, target_type,
352 XCONS (XCONS (local_value)->cdr)->car);
353 else
354 value = Qnil;
ede4db72
RS
355 unbind_to (count, Qnil);
356 }
357
358 /* Make sure this value is of a type that we could transmit
359 to another X client. */
a87ed99c 360
ede4db72
RS
361 check = value;
362 if (CONSP (value)
363 && SYMBOLP (XCONS (value)->car))
364 type = XCONS (value)->car,
365 check = XCONS (value)->cdr;
366
367 if (STRINGP (check)
368 || VECTORP (check)
369 || SYMBOLP (check)
7da64e5c 370 || INTEGERP (check)
ede4db72
RS
371 || NILP (value))
372 return value;
a87ed99c 373 /* Check for a value that cons_to_long could handle. */
ede4db72 374 else if (CONSP (check)
7da64e5c
RS
375 && INTEGERP (XCONS (check)->car)
376 && (INTEGERP (XCONS (check)->cdr)
ede4db72
RS
377 ||
378 (CONSP (XCONS (check)->cdr)
7da64e5c 379 && INTEGERP (XCONS (XCONS (check)->cdr)->car)
ede4db72
RS
380 && NILP (XCONS (XCONS (check)->cdr)->cdr))))
381 return value;
382 else
383 return
384 Fsignal (Qerror,
a87ed99c 385 Fcons (build_string ("invalid data returned by selection-conversion function"),
ede4db72
RS
386 Fcons (handler_fn, Fcons (value, Qnil))));
387}
388\f
389/* Subroutines of x_reply_selection_request. */
390
391/* Send a SelectionNotify event to the requestor with property=None,
392 meaning we were unable to do what they wanted. */
393
394static void
395x_decline_selection_request (event)
396 struct input_event *event;
397{
398 XSelectionEvent reply;
399 reply.type = SelectionNotify;
400 reply.display = SELECTION_EVENT_DISPLAY (event);
401 reply.requestor = SELECTION_EVENT_REQUESTOR (event);
402 reply.selection = SELECTION_EVENT_SELECTION (event);
403 reply.time = SELECTION_EVENT_TIME (event);
404 reply.target = SELECTION_EVENT_TARGET (event);
405 reply.property = None;
406
407 BLOCK_INPUT;
7ffb2841
RS
408 XSendEvent (reply.display, reply.requestor, False, 0L,
409 (XEvent *) &reply);
5c3a351a 410 XFlush (reply.display);
ede4db72
RS
411 UNBLOCK_INPUT;
412}
413
414/* This is the selection request currently being processed.
415 It is set to zero when the request is fully processed. */
416static struct input_event *x_selection_current_request;
417
418/* Used as an unwind-protect clause so that, if a selection-converter signals
419 an error, we tell the requestor that we were unable to do what they wanted
420 before we throw to top-level or go into the debugger or whatever. */
421
422static Lisp_Object
423x_selection_request_lisp_error (ignore)
424 Lisp_Object ignore;
425{
426 if (x_selection_current_request != 0)
427 x_decline_selection_request (x_selection_current_request);
428 return Qnil;
429}
430\f
d1f21a66
RS
431
432/* This stuff is so that INCR selections are reentrant (that is, so we can
433 be servicing multiple INCR selection requests simultaneously.) I haven't
434 actually tested that yet. */
435
436/* Keep a list of the property changes that are awaited. */
437
438struct prop_location
439{
440 int identifier;
441 Display *display;
442 Window window;
443 Atom property;
444 int desired_state;
445 int arrived;
446 struct prop_location *next;
447};
448
449static struct prop_location *expect_property_change ();
450static void wait_for_property_change ();
451static void unexpect_property_change ();
452static int waiting_for_other_props_on_window ();
453
454static int prop_location_identifier;
455
456static Lisp_Object property_change_reply;
457
458static struct prop_location *property_change_reply_object;
459
460static struct prop_location *property_change_wait_list;
55b2d45d
RS
461
462static Lisp_Object
463queue_selection_requests_unwind (frame)
464 Lisp_Object frame;
465{
466 FRAME_PTR f = XFRAME (frame);
467
468 if (! NILP (frame))
469 x_stop_queuing_selection_requests (FRAME_X_DISPLAY (f));
470}
471
472/* Return some frame whose display info is DPYINFO.
473 Return nil if there is none. */
474
475static Lisp_Object
476some_frame_on_display (dpyinfo)
477 struct x_display_info *dpyinfo;
478{
479 Lisp_Object list, frame;
480
481 FOR_EACH_FRAME (list, frame)
482 {
483 if (FRAME_X_DISPLAY_INFO (XFRAME (frame)) == dpyinfo)
484 return frame;
485 }
486
487 return Qnil;
488}
d1f21a66 489\f
ede4db72
RS
490/* Send the reply to a selection request event EVENT.
491 TYPE is the type of selection data requested.
492 DATA and SIZE describe the data to send, already converted.
493 FORMAT is the unit-size (in bits) of the data to be transmitted. */
494
495static void
496x_reply_selection_request (event, format, data, size, type)
497 struct input_event *event;
498 int format, size;
499 unsigned char *data;
500 Atom type;
501{
502 XSelectionEvent reply;
503 Display *display = SELECTION_EVENT_DISPLAY (event);
504 Window window = SELECTION_EVENT_REQUESTOR (event);
505 int bytes_remaining;
506 int format_bytes = format/8;
507 int max_bytes = SELECTION_QUANTUM (display);
5c3a351a 508 struct x_display_info *dpyinfo = x_display_info_for_display (display);
ede4db72
RS
509
510 if (max_bytes > MAX_SELECTION_QUANTUM)
511 max_bytes = MAX_SELECTION_QUANTUM;
512
513 reply.type = SelectionNotify;
514 reply.display = display;
515 reply.requestor = window;
516 reply.selection = SELECTION_EVENT_SELECTION (event);
517 reply.time = SELECTION_EVENT_TIME (event);
518 reply.target = SELECTION_EVENT_TARGET (event);
519 reply.property = SELECTION_EVENT_PROPERTY (event);
520 if (reply.property == None)
521 reply.property = reply.target;
522
523 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
afe1529d
RS
524 BLOCK_INPUT;
525 x_catch_errors (display);
ede4db72 526
ede4db72
RS
527 /* Store the data on the requested property.
528 If the selection is large, only store the first N bytes of it.
529 */
530 bytes_remaining = size * format_bytes;
531 if (bytes_remaining <= max_bytes)
532 {
533 /* Send all the data at once, with minimal handshaking. */
534#if 0
535 fprintf (stderr,"\nStoring all %d\n", bytes_remaining);
536#endif
537 XChangeProperty (display, window, reply.property, type, format,
538 PropModeReplace, data, size);
539 /* At this point, the selection was successfully stored; ack it. */
2f65feb6 540 XSendEvent (display, window, False, 0L, (XEvent *) &reply);
ede4db72
RS
541 }
542 else
543 {
544 /* Send an INCR selection. */
d1f21a66 545 struct prop_location *wait_object;
afe1529d 546 int had_errors;
55b2d45d
RS
547 int count = specpdl_ptr - specpdl;
548 Lisp_Object frame;
ede4db72 549
55b2d45d
RS
550 frame = some_frame_on_display (dpyinfo);
551
552 /* If the display no longer has frames, we can't expect
553 to get many more selection requests from it, so don't
554 bother trying to queue them. */
555 if (!NILP (frame))
556 {
557 x_start_queuing_selection_requests (display);
558
559 record_unwind_protect (queue_selection_requests_unwind,
560 frame);
561 }
2f65feb6 562
19126e11 563 if (x_window_to_frame (dpyinfo, window)) /* #### debug */
ede4db72
RS
564 error ("attempt to transfer an INCR to ourself!");
565#if 0
566 fprintf (stderr, "\nINCR %d\n", bytes_remaining);
567#endif
d1f21a66
RS
568 wait_object = expect_property_change (display, window, reply.property,
569 PropertyDelete);
ede4db72 570
5c3a351a 571 XChangeProperty (display, window, reply.property, dpyinfo->Xatom_INCR,
55b2d45d
RS
572 32, PropModeReplace,
573 (unsigned char *) &bytes_remaining, 1);
ede4db72
RS
574 XSelectInput (display, window, PropertyChangeMask);
575 /* Tell 'em the INCR data is there... */
55b2d45d 576 XSendEvent (display, window, False, 0L, (XEvent *) &reply);
5c3a351a 577 XFlush (display);
afe1529d
RS
578
579 had_errors = x_had_errors_p (display);
2f65feb6 580 UNBLOCK_INPUT;
ede4db72
RS
581
582 /* First, wait for the requestor to ack by deleting the property.
583 This can run random lisp code (process handlers) or signal. */
afe1529d
RS
584 if (! had_errors)
585 wait_for_property_change (wait_object);
ede4db72
RS
586
587 while (bytes_remaining)
588 {
589 int i = ((bytes_remaining < max_bytes)
590 ? bytes_remaining
591 : max_bytes);
2f65feb6
RS
592
593 BLOCK_INPUT;
594
d1f21a66
RS
595 wait_object
596 = expect_property_change (display, window, reply.property,
597 PropertyDelete);
ede4db72
RS
598#if 0
599 fprintf (stderr," INCR adding %d\n", i);
600#endif
601 /* Append the next chunk of data to the property. */
602 XChangeProperty (display, window, reply.property, type, format,
603 PropModeAppend, data, i / format_bytes);
604 bytes_remaining -= i;
605 data += i;
5c3a351a 606 XFlush (display);
afe1529d 607 had_errors = x_had_errors_p (display);
2f65feb6 608 UNBLOCK_INPUT;
ede4db72 609
afe1529d
RS
610 if (had_errors)
611 break;
612
ede4db72
RS
613 /* Now wait for the requestor to ack this chunk by deleting the
614 property. This can run random lisp code or signal.
615 */
d1f21a66 616 wait_for_property_change (wait_object);
ede4db72
RS
617 }
618 /* Now write a zero-length chunk to the property to tell the requestor
619 that we're done. */
620#if 0
621 fprintf (stderr," INCR done\n");
622#endif
2f65feb6 623 BLOCK_INPUT;
ede4db72
RS
624 if (! waiting_for_other_props_on_window (display, window))
625 XSelectInput (display, window, 0L);
626
627 XChangeProperty (display, window, reply.property, type, format,
628 PropModeReplace, data, 0);
55b2d45d
RS
629
630 unbind_to (count, Qnil);
ede4db72 631 }
afe1529d
RS
632
633 XFlush (display);
634 x_uncatch_errors (display);
635 UNBLOCK_INPUT;
ede4db72
RS
636}
637\f
638/* Handle a SelectionRequest event EVENT.
639 This is called from keyboard.c when such an event is found in the queue. */
640
641void
642x_handle_selection_request (event)
643 struct input_event *event;
644{
645 struct gcpro gcpro1, gcpro2, gcpro3;
9d2d1dd8 646 Lisp_Object local_selection_data;
ede4db72 647 Lisp_Object selection_symbol;
9d2d1dd8
KH
648 Lisp_Object target_symbol;
649 Lisp_Object converted_selection;
ede4db72 650 Time local_selection_time;
9d2d1dd8 651 Lisp_Object successful_p;
ede4db72 652 int count;
5c3a351a
RS
653 struct x_display_info *dpyinfo
654 = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));
ede4db72 655
9d2d1dd8
KH
656 local_selection_data = Qnil;
657 target_symbol = Qnil;
658 converted_selection = Qnil;
659 successful_p = Qnil;
660
ede4db72
RS
661 GCPRO3 (local_selection_data, converted_selection, target_symbol);
662
5c3a351a
RS
663 selection_symbol = x_atom_to_symbol (dpyinfo,
664 SELECTION_EVENT_DISPLAY (event),
ede4db72
RS
665 SELECTION_EVENT_SELECTION (event));
666
667 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
ede4db72
RS
668
669 if (NILP (local_selection_data))
670 {
671 /* Someone asked for the selection, but we don't have it any more.
672 */
673 x_decline_selection_request (event);
674 goto DONE;
675 }
676
677 local_selection_time = (Time)
678 cons_to_long (XCONS (XCONS (XCONS (local_selection_data)->cdr)->cdr)->car);
679
680 if (SELECTION_EVENT_TIME (event) != CurrentTime
7da64e5c 681 && local_selection_time > SELECTION_EVENT_TIME (event))
ede4db72
RS
682 {
683 /* Someone asked for the selection, and we have one, but not the one
684 they're looking for.
685 */
686 x_decline_selection_request (event);
687 goto DONE;
688 }
689
690 count = specpdl_ptr - specpdl;
691 x_selection_current_request = event;
692 record_unwind_protect (x_selection_request_lisp_error, Qnil);
693
5c3a351a 694 target_symbol = x_atom_to_symbol (dpyinfo, SELECTION_EVENT_DISPLAY (event),
ede4db72
RS
695 SELECTION_EVENT_TARGET (event));
696
697#if 0 /* #### MULTIPLE doesn't work yet */
698 if (EQ (target_symbol, QMULTIPLE))
699 target_symbol = fetch_multiple_target (event);
700#endif
701
702 /* Convert lisp objects back into binary data */
703
704 converted_selection
705 = x_get_local_selection (selection_symbol, target_symbol);
706
707 if (! NILP (converted_selection))
708 {
709 unsigned char *data;
710 unsigned int size;
711 int format;
712 Atom type;
aca39f42
RS
713 int nofree;
714
2f65feb6
RS
715 lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event),
716 converted_selection,
aca39f42 717 &data, &type, &size, &format, &nofree);
ede4db72
RS
718
719 x_reply_selection_request (event, format, data, size, type);
720 successful_p = Qt;
721
722 /* Indicate we have successfully processed this event. */
7da64e5c 723 x_selection_current_request = 0;
ede4db72 724
aca39f42
RS
725 if (!nofree)
726 xfree (data);
ede4db72
RS
727 }
728 unbind_to (count, Qnil);
729
730 DONE:
731
732 UNGCPRO;
733
734 /* Let random lisp code notice that the selection has been asked for. */
735 {
9d2d1dd8
KH
736 Lisp_Object rest;
737 rest = Vx_sent_selection_hooks;
ede4db72
RS
738 if (!EQ (rest, Qunbound))
739 for (; CONSP (rest); rest = Fcdr (rest))
740 call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
741 }
742}
743\f
744/* Handle a SelectionClear event EVENT, which indicates that some other
745 client cleared out our previously asserted selection.
746 This is called from keyboard.c when such an event is found in the queue. */
747
748void
749x_handle_selection_clear (event)
750 struct input_event *event;
751{
752 Display *display = SELECTION_EVENT_DISPLAY (event);
753 Atom selection = SELECTION_EVENT_SELECTION (event);
754 Time changed_owner_time = SELECTION_EVENT_TIME (event);
755
756 Lisp_Object selection_symbol, local_selection_data;
757 Time local_selection_time;
5c3a351a 758 struct x_display_info *dpyinfo = x_display_info_for_display (display);
ede4db72 759
5c3a351a 760 selection_symbol = x_atom_to_symbol (dpyinfo, display, selection);
ede4db72
RS
761
762 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
763
764 /* Well, we already believe that we don't own it, so that's just fine. */
765 if (NILP (local_selection_data)) return;
766
767 local_selection_time = (Time)
768 cons_to_long (XCONS (XCONS (XCONS (local_selection_data)->cdr)->cdr)->car);
769
770 /* This SelectionClear is for a selection that we no longer own, so we can
771 disregard it. (That is, we have reasserted the selection since this
772 request was generated.) */
773
774 if (changed_owner_time != CurrentTime
775 && local_selection_time > changed_owner_time)
776 return;
777
778 /* Otherwise, we're really honest and truly being told to drop it.
779 Don't use Fdelq as that may QUIT;. */
780
781 if (EQ (local_selection_data, Fcar (Vselection_alist)))
782 Vselection_alist = Fcdr (Vselection_alist);
783 else
784 {
785 Lisp_Object rest;
786 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
787 if (EQ (local_selection_data, Fcar (XCONS (rest)->cdr)))
788 {
789 XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr);
790 break;
791 }
792 }
793
794 /* Let random lisp code notice that the selection has been stolen. */
795
796 {
d1f21a66
RS
797 Lisp_Object rest;
798 rest = Vx_lost_selection_hooks;
ede4db72 799 if (!EQ (rest, Qunbound))
d1f21a66
RS
800 {
801 for (; CONSP (rest); rest = Fcdr (rest))
802 call1 (Fcar (rest), selection_symbol);
7c6b2ea4 803 prepare_menu_bars ();
d1f21a66
RS
804 redisplay_preserve_echo_area ();
805 }
ede4db72
RS
806 }
807}
808
118bd841
RS
809/* Clear all selections that were made from frame F.
810 We do this when about to delete a frame. */
811
812void
813x_clear_frame_selections (f)
814 FRAME_PTR f;
815{
816 Lisp_Object frame;
817 Lisp_Object rest;
818
90851bbe 819 XSETFRAME (frame, f);
118bd841
RS
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 while (!NILP (Vselection_alist)
825 && EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (Vselection_alist)))))))
826 {
827 /* Let random Lisp code notice that the selection has been stolen. */
828 Lisp_Object hooks, selection_symbol;
829
830 hooks = Vx_lost_selection_hooks;
831 selection_symbol = Fcar (Vselection_alist);
832
833 if (!EQ (hooks, Qunbound))
834 {
835 for (; CONSP (hooks); hooks = Fcdr (hooks))
836 call1 (Fcar (hooks), selection_symbol);
837 redisplay_preserve_echo_area ();
838 }
839
840 Vselection_alist = Fcdr (Vselection_alist);
841 }
842
843 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
844 if (EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (XCONS (rest)->cdr)))))))
845 {
846 /* Let random Lisp code notice that the selection has been stolen. */
847 Lisp_Object hooks, selection_symbol;
848
849 hooks = Vx_lost_selection_hooks;
850 selection_symbol = Fcar (XCONS (rest)->cdr);
851
852 if (!EQ (hooks, Qunbound))
853 {
854 for (; CONSP (hooks); hooks = Fcdr (hooks))
855 call1 (Fcar (hooks), selection_symbol);
856 redisplay_preserve_echo_area ();
857 }
858 XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr);
859 break;
860 }
861}
ede4db72 862\f
ede4db72
RS
863/* Nonzero if any properties for DISPLAY and WINDOW
864 are on the list of what we are waiting for. */
865
866static int
867waiting_for_other_props_on_window (display, window)
868 Display *display;
869 Window window;
870{
871 struct prop_location *rest = property_change_wait_list;
872 while (rest)
873 if (rest->display == display && rest->window == window)
874 return 1;
875 else
876 rest = rest->next;
877 return 0;
878}
879
880/* Add an entry to the list of property changes we are waiting for.
881 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
882 The return value is a number that uniquely identifies
883 this awaited property change. */
884
d1f21a66 885static struct prop_location *
ede4db72
RS
886expect_property_change (display, window, property, state)
887 Display *display;
888 Window window;
889 Lisp_Object property;
890 int state;
891{
892 struct prop_location *pl
893 = (struct prop_location *) xmalloc (sizeof (struct prop_location));
2f65feb6 894 pl->identifier = ++prop_location_identifier;
ede4db72
RS
895 pl->display = display;
896 pl->window = window;
897 pl->property = property;
898 pl->desired_state = state;
899 pl->next = property_change_wait_list;
d1f21a66 900 pl->arrived = 0;
ede4db72 901 property_change_wait_list = pl;
d1f21a66 902 return pl;
ede4db72
RS
903}
904
905/* Delete an entry from the list of property changes we are waiting for.
2f65feb6 906 IDENTIFIER is the number that uniquely identifies the entry. */
ede4db72
RS
907
908static void
d1f21a66
RS
909unexpect_property_change (location)
910 struct prop_location *location;
ede4db72
RS
911{
912 struct prop_location *prev = 0, *rest = property_change_wait_list;
913 while (rest)
914 {
d1f21a66 915 if (rest == location)
ede4db72
RS
916 {
917 if (prev)
918 prev->next = rest->next;
919 else
920 property_change_wait_list = rest->next;
921 xfree (rest);
922 return;
923 }
924 prev = rest;
925 rest = rest->next;
926 }
927}
928
2f65feb6
RS
929/* Remove the property change expectation element for IDENTIFIER. */
930
931static Lisp_Object
932wait_for_property_change_unwind (identifierval)
933 Lisp_Object identifierval;
934{
c4898489
KH
935 unexpect_property_change ((struct prop_location *)
936 (XFASTINT (XCONS (identifierval)->car) << 16
937 | XFASTINT (XCONS (identifierval)->cdr)));
2f65feb6
RS
938}
939
ede4db72 940/* Actually wait for a property change.
2f65feb6 941 IDENTIFIER should be the value that expect_property_change returned. */
ede4db72
RS
942
943static void
d1f21a66
RS
944wait_for_property_change (location)
945 struct prop_location *location;
ede4db72 946{
2f65feb6
RS
947 int secs, usecs;
948 int count = specpdl_ptr - specpdl;
d1f21a66
RS
949 Lisp_Object tem;
950
c4898489
KH
951 tem = Fcons (Qnil, Qnil);
952 XSETFASTINT (XCONS (tem)->car, (EMACS_UINT)location >> 16);
953 XSETFASTINT (XCONS (tem)->cdr, (EMACS_UINT)location & 0xffff);
2f65feb6
RS
954
955 /* Make sure to do unexpect_property_change if we quit or err. */
d1f21a66 956 record_unwind_protect (wait_for_property_change_unwind, tem);
2f65feb6 957
ede4db72 958 XCONS (property_change_reply)->car = Qnil;
2f65feb6 959
afe1529d
RS
960 property_change_reply_object = location;
961 /* If the event we are waiting for arrives beyond here, it will set
962 property_change_reply, because property_change_reply_object says so. */
d1f21a66
RS
963 if (! location->arrived)
964 {
d1f21a66
RS
965 secs = x_selection_timeout / 1000;
966 usecs = (x_selection_timeout % 1000) * 1000;
967 wait_reading_process_input (secs, usecs, property_change_reply, 0);
968
969 if (NILP (XCONS (property_change_reply)->car))
970 error ("timed out waiting for property-notify event");
971 }
2f65feb6
RS
972
973 unbind_to (count, Qnil);
ede4db72
RS
974}
975
976/* Called from XTread_socket in response to a PropertyNotify event. */
977
978void
979x_handle_property_notify (event)
980 XPropertyEvent *event;
981{
982 struct prop_location *prev = 0, *rest = property_change_wait_list;
983 while (rest)
984 {
985 if (rest->property == event->atom
986 && rest->window == event->window
987 && rest->display == event->display
988 && rest->desired_state == event->state)
989 {
990#if 0
991 fprintf (stderr, "Saw expected prop-%s on %s\n",
992 (event->state == PropertyDelete ? "delete" : "change"),
5c3a351a 993 (char *) XSYMBOL (x_atom_to_symbol (dpyinfo, event->display,
ede4db72
RS
994 event->atom))
995 ->name->data);
996#endif
997
d1f21a66
RS
998 rest->arrived = 1;
999
ede4db72
RS
1000 /* If this is the one wait_for_property_change is waiting for,
1001 tell it to wake up. */
d1f21a66 1002 if (rest == property_change_reply_object)
ede4db72
RS
1003 XCONS (property_change_reply)->car = Qt;
1004
1005 if (prev)
1006 prev->next = rest->next;
1007 else
1008 property_change_wait_list = rest->next;
1009 xfree (rest);
1010 return;
1011 }
1012 prev = rest;
1013 rest = rest->next;
1014 }
1015#if 0
1016 fprintf (stderr, "Saw UNexpected prop-%s on %s\n",
1017 (event->state == PropertyDelete ? "delete" : "change"),
5c3a351a
RS
1018 (char *) XSYMBOL (x_atom_to_symbol (dpyinfo,
1019 event->display, event->atom))
ede4db72
RS
1020 ->name->data);
1021#endif
1022}
1023
1024
1025\f
1026#if 0 /* #### MULTIPLE doesn't work yet */
1027
1028static Lisp_Object
1029fetch_multiple_target (event)
1030 XSelectionRequestEvent *event;
1031{
1032 Display *display = event->display;
1033 Window window = event->requestor;
1034 Atom target = event->target;
1035 Atom selection_atom = event->selection;
1036 int result;
1037
1038 return
1039 Fcons (QMULTIPLE,
1040 x_get_window_property_as_lisp_data (display, window, target,
1041 QMULTIPLE, selection_atom));
1042}
1043
1044static Lisp_Object
1045copy_multiple_data (obj)
1046 Lisp_Object obj;
1047{
1048 Lisp_Object vec;
1049 int i;
1050 int size;
1051 if (CONSP (obj))
1052 return Fcons (XCONS (obj)->car, copy_multiple_data (XCONS (obj)->cdr));
1053
1054 CHECK_VECTOR (obj, 0);
1055 vec = Fmake_vector (size = XVECTOR (obj)->size, Qnil);
1056 for (i = 0; i < size; i++)
1057 {
1058 Lisp_Object vec2 = XVECTOR (obj)->contents [i];
1059 CHECK_VECTOR (vec2, 0);
1060 if (XVECTOR (vec2)->size != 2)
1061 /* ??? Confusing error message */
1062 Fsignal (Qerror, Fcons (build_string ("vectors must be of length 2"),
1063 Fcons (vec2, Qnil)));
1064 XVECTOR (vec)->contents [i] = Fmake_vector (2, Qnil);
1065 XVECTOR (XVECTOR (vec)->contents [i])->contents [0]
1066 = XVECTOR (vec2)->contents [0];
1067 XVECTOR (XVECTOR (vec)->contents [i])->contents [1]
1068 = XVECTOR (vec2)->contents [1];
1069 }
1070 return vec;
1071}
1072
1073#endif
1074
1075\f
1076/* Variables for communication with x_handle_selection_notify. */
1077static Atom reading_which_selection;
1078static Lisp_Object reading_selection_reply;
1079static Window reading_selection_window;
1080
1081/* Do protocol to read selection-data from the server.
1082 Converts this to Lisp data and returns it. */
1083
1084static Lisp_Object
1085x_get_foreign_selection (selection_symbol, target_type)
1086 Lisp_Object selection_symbol, target_type;
1087{
7da64e5c 1088 Window requestor_window = FRAME_X_WINDOW (selected_frame);
3834c318 1089 Display *display = FRAME_X_DISPLAY (selected_frame);
5c3a351a 1090 struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (selected_frame);
7da64e5c 1091 Time requestor_time = last_event_timestamp;
5c3a351a
RS
1092 Atom target_property = dpyinfo->Xatom_EMACS_TMP;
1093 Atom selection_atom = symbol_to_x_atom (dpyinfo, display, selection_symbol);
ede4db72 1094 Atom type_atom;
80da0190 1095 int secs, usecs;
55b2d45d
RS
1096 int count = specpdl_ptr - specpdl;
1097 Lisp_Object frame;
ede4db72
RS
1098
1099 if (CONSP (target_type))
5c3a351a 1100 type_atom = symbol_to_x_atom (dpyinfo, display, XCONS (target_type)->car);
ede4db72 1101 else
5c3a351a 1102 type_atom = symbol_to_x_atom (dpyinfo, display, target_type);
ede4db72
RS
1103
1104 BLOCK_INPUT;
a7b24d46 1105 x_catch_errors (display);
ede4db72
RS
1106 XConvertSelection (display, selection_atom, type_atom, target_property,
1107 requestor_window, requestor_time);
5c3a351a 1108 XFlush (display);
ede4db72
RS
1109
1110 /* Prepare to block until the reply has been read. */
1111 reading_selection_window = requestor_window;
1112 reading_which_selection = selection_atom;
1113 XCONS (reading_selection_reply)->car = Qnil;
55b2d45d
RS
1114
1115 frame = some_frame_on_display (dpyinfo);
1116
1117 /* If the display no longer has frames, we can't expect
1118 to get many more selection requests from it, so don't
1119 bother trying to queue them. */
1120 if (!NILP (frame))
1121 {
1122 x_start_queuing_selection_requests (display);
1123
1124 record_unwind_protect (queue_selection_requests_unwind,
1125 frame);
1126 }
ede4db72
RS
1127 UNBLOCK_INPUT;
1128
80da0190
RS
1129 /* This allows quits. Also, don't wait forever. */
1130 secs = x_selection_timeout / 1000;
1131 usecs = (x_selection_timeout % 1000) * 1000;
1132 wait_reading_process_input (secs, usecs, reading_selection_reply, 0);
ede4db72 1133
7c6b2ea4 1134 BLOCK_INPUT;
a7b24d46
RS
1135 x_check_errors (display, "Cannot get selection: %s");
1136 x_uncatch_errors (display);
55b2d45d 1137 unbind_to (count, Qnil);
7c6b2ea4
RS
1138 UNBLOCK_INPUT;
1139
ede4db72
RS
1140 if (NILP (XCONS (reading_selection_reply)->car))
1141 error ("timed out waiting for reply from selection owner");
1142
1143 /* Otherwise, the selection is waiting for us on the requested property. */
1144 return
1145 x_get_window_property_as_lisp_data (display, requestor_window,
1146 target_property, target_type,
1147 selection_atom);
1148}
1149\f
1150/* Subroutines of x_get_window_property_as_lisp_data */
1151
1152static void
1153x_get_window_property (display, window, property, data_ret, bytes_ret,
1154 actual_type_ret, actual_format_ret, actual_size_ret,
1155 delete_p)
1156 Display *display;
1157 Window window;
1158 Atom property;
1159 unsigned char **data_ret;
1160 int *bytes_ret;
1161 Atom *actual_type_ret;
1162 int *actual_format_ret;
1163 unsigned long *actual_size_ret;
1164 int delete_p;
1165{
1166 int total_size;
1167 unsigned long bytes_remaining;
1168 int offset = 0;
1169 unsigned char *tmp_data = 0;
1170 int result;
1171 int buffer_size = SELECTION_QUANTUM (display);
1172 if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
1173
1174 BLOCK_INPUT;
1175 /* First probe the thing to find out how big it is. */
1176 result = XGetWindowProperty (display, window, property,
1177 0, 0, False, AnyPropertyType,
1178 actual_type_ret, actual_format_ret,
1179 actual_size_ret,
1180 &bytes_remaining, &tmp_data);
ede4db72
RS
1181 if (result != Success)
1182 {
2f65feb6 1183 UNBLOCK_INPUT;
ede4db72
RS
1184 *data_ret = 0;
1185 *bytes_ret = 0;
1186 return;
1187 }
2f65feb6 1188 xfree ((char *) tmp_data);
ede4db72
RS
1189
1190 if (*actual_type_ret == None || *actual_format_ret == 0)
1191 {
2f65feb6 1192 UNBLOCK_INPUT;
ede4db72
RS
1193 return;
1194 }
1195
1196 total_size = bytes_remaining + 1;
1197 *data_ret = (unsigned char *) xmalloc (total_size);
1198
1199 /* Now read, until weve gotten it all. */
ede4db72
RS
1200 while (bytes_remaining)
1201 {
1202#if 0
1203 int last = bytes_remaining;
1204#endif
1205 result
1206 = XGetWindowProperty (display, window, property,
1207 offset/4, buffer_size/4,
2f65feb6 1208 False,
ede4db72
RS
1209 AnyPropertyType,
1210 actual_type_ret, actual_format_ret,
1211 actual_size_ret, &bytes_remaining, &tmp_data);
1212#if 0
1213 fprintf (stderr, "<< read %d\n", last-bytes_remaining);
1214#endif
1215 /* If this doesn't return Success at this point, it means that
1216 some clod deleted the selection while we were in the midst of
1217 reading it. Deal with that, I guess....
1218 */
1219 if (result != Success) break;
1220 *actual_size_ret *= *actual_format_ret / 8;
1221 bcopy (tmp_data, (*data_ret) + offset, *actual_size_ret);
1222 offset += *actual_size_ret;
2f65feb6 1223 xfree ((char *) tmp_data);
ede4db72 1224 }
2f65feb6 1225
5c3a351a 1226 XFlush (display);
ede4db72
RS
1227 UNBLOCK_INPUT;
1228 *bytes_ret = offset;
1229}
1230\f
1231static void
1232receive_incremental_selection (display, window, property, target_type,
1233 min_size_bytes, data_ret, size_bytes_ret,
1234 type_ret, format_ret, size_ret)
1235 Display *display;
1236 Window window;
1237 Atom property;
1238 Lisp_Object target_type; /* for error messages only */
1239 unsigned int min_size_bytes;
1240 unsigned char **data_ret;
1241 int *size_bytes_ret;
1242 Atom *type_ret;
1243 unsigned long *size_ret;
1244 int *format_ret;
1245{
1246 int offset = 0;
d1f21a66 1247 struct prop_location *wait_object;
ede4db72
RS
1248 *size_bytes_ret = min_size_bytes;
1249 *data_ret = (unsigned char *) xmalloc (*size_bytes_ret);
1250#if 0
1251 fprintf (stderr, "\nread INCR %d\n", min_size_bytes);
1252#endif
2f65feb6
RS
1253
1254 /* At this point, we have read an INCR property.
1255 Delete the property to ack it.
1256 (But first, prepare to receive the next event in this handshake.)
ede4db72
RS
1257
1258 Now, we must loop, waiting for the sending window to put a value on
1259 that property, then reading the property, then deleting it to ack.
1260 We are done when the sender places a property of length 0.
1261 */
2f65feb6
RS
1262 BLOCK_INPUT;
1263 XSelectInput (display, window, STANDARD_EVENT_SET | PropertyChangeMask);
1264 XDeleteProperty (display, window, property);
d1f21a66
RS
1265 wait_object = expect_property_change (display, window, property,
1266 PropertyNewValue);
5c3a351a 1267 XFlush (display);
2f65feb6
RS
1268 UNBLOCK_INPUT;
1269
ede4db72
RS
1270 while (1)
1271 {
1272 unsigned char *tmp_data;
1273 int tmp_size_bytes;
d1f21a66 1274 wait_for_property_change (wait_object);
ede4db72
RS
1275 /* expect it again immediately, because x_get_window_property may
1276 .. no it wont, I dont get it.
1277 .. Ok, I get it now, the Xt code that implements INCR is broken.
1278 */
ede4db72
RS
1279 x_get_window_property (display, window, property,
1280 &tmp_data, &tmp_size_bytes,
1281 type_ret, format_ret, size_ret, 1);
1282
1283 if (tmp_size_bytes == 0) /* we're done */
1284 {
1285#if 0
1286 fprintf (stderr, " read INCR done\n");
1287#endif
2f65feb6
RS
1288 if (! waiting_for_other_props_on_window (display, window))
1289 XSelectInput (display, window, STANDARD_EVENT_SET);
d1f21a66 1290 unexpect_property_change (wait_object);
ede4db72
RS
1291 if (tmp_data) xfree (tmp_data);
1292 break;
1293 }
2f65feb6
RS
1294
1295 BLOCK_INPUT;
1296 XDeleteProperty (display, window, property);
d1f21a66
RS
1297 wait_object = expect_property_change (display, window, property,
1298 PropertyNewValue);
5c3a351a 1299 XFlush (display);
2f65feb6
RS
1300 UNBLOCK_INPUT;
1301
ede4db72
RS
1302#if 0
1303 fprintf (stderr, " read INCR %d\n", tmp_size_bytes);
1304#endif
1305 if (*size_bytes_ret < offset + tmp_size_bytes)
1306 {
1307#if 0
1308 fprintf (stderr, " read INCR realloc %d -> %d\n",
1309 *size_bytes_ret, offset + tmp_size_bytes);
1310#endif
1311 *size_bytes_ret = offset + tmp_size_bytes;
1312 *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret);
1313 }
018cfa07 1314 bcopy (tmp_data, (*data_ret) + offset, tmp_size_bytes);
ede4db72
RS
1315 offset += tmp_size_bytes;
1316 xfree (tmp_data);
1317 }
1318}
1319\f
1320/* Once a requested selection is "ready" (we got a SelectionNotify event),
1321 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1322 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1323
1324static Lisp_Object
1325x_get_window_property_as_lisp_data (display, window, property, target_type,
1326 selection_atom)
1327 Display *display;
1328 Window window;
1329 Atom property;
1330 Lisp_Object target_type; /* for error messages only */
1331 Atom selection_atom; /* for error messages only */
1332{
1333 Atom actual_type;
1334 int actual_format;
1335 unsigned long actual_size;
1336 unsigned char *data = 0;
1337 int bytes = 0;
1338 Lisp_Object val;
5c3a351a 1339 struct x_display_info *dpyinfo = x_display_info_for_display (display);
ede4db72
RS
1340
1341 x_get_window_property (display, window, property, &data, &bytes,
1342 &actual_type, &actual_format, &actual_size, 1);
1343 if (! data)
1344 {
1345 int there_is_a_selection_owner;
1346 BLOCK_INPUT;
1347 there_is_a_selection_owner
1348 = XGetSelectionOwner (display, selection_atom);
1349 UNBLOCK_INPUT;
1350 while (1) /* Note debugger can no longer return, so this is obsolete */
1351 Fsignal (Qerror,
1352 there_is_a_selection_owner ?
1353 Fcons (build_string ("selection owner couldn't convert"),
1354 actual_type
1355 ? Fcons (target_type,
5c3a351a
RS
1356 Fcons (x_atom_to_symbol (dpyinfo, display,
1357 actual_type),
ede4db72
RS
1358 Qnil))
1359 : Fcons (target_type, Qnil))
1360 : Fcons (build_string ("no selection"),
5c3a351a
RS
1361 Fcons (x_atom_to_symbol (dpyinfo, display,
1362 selection_atom),
ede4db72
RS
1363 Qnil)));
1364 }
1365
5c3a351a 1366 if (actual_type == dpyinfo->Xatom_INCR)
ede4db72
RS
1367 {
1368 /* That wasn't really the data, just the beginning. */
1369
1370 unsigned int min_size_bytes = * ((unsigned int *) data);
1371 BLOCK_INPUT;
1372 XFree ((char *) data);
1373 UNBLOCK_INPUT;
1374 receive_incremental_selection (display, window, property, target_type,
1375 min_size_bytes, &data, &bytes,
1376 &actual_type, &actual_format,
1377 &actual_size);
1378 }
1379
2f65feb6
RS
1380 BLOCK_INPUT;
1381 XDeleteProperty (display, window, property);
5c3a351a 1382 XFlush (display);
2f65feb6
RS
1383 UNBLOCK_INPUT;
1384
ede4db72
RS
1385 /* It's been read. Now convert it to a lisp object in some semi-rational
1386 manner. */
1387 val = selection_data_to_lisp_data (display, data, bytes,
1388 actual_type, actual_format);
1389
1390 xfree ((char *) data);
1391 return val;
1392}
1393\f
1394/* These functions convert from the selection data read from the server into
1395 something that we can use from Lisp, and vice versa.
1396
1397 Type: Format: Size: Lisp Type:
1398 ----- ------- ----- -----------
1399 * 8 * String
1400 ATOM 32 1 Symbol
1401 ATOM 32 > 1 Vector of Symbols
1402 * 16 1 Integer
1403 * 16 > 1 Vector of Integers
1404 * 32 1 if <=16 bits: Integer
1405 if > 16 bits: Cons of top16, bot16
1406 * 32 > 1 Vector of the above
1407
1408 When converting a Lisp number to C, it is assumed to be of format 16 if
1409 it is an integer, and of format 32 if it is a cons of two integers.
1410
1411 When converting a vector of numbers from Lisp to C, it is assumed to be
1412 of format 16 if every element in the vector is an integer, and is assumed
1413 to be of format 32 if any element is a cons of two integers.
1414
1415 When converting an object to C, it may be of the form (SYMBOL . <data>)
1416 where SYMBOL is what we should claim that the type is. Format and
1417 representation are as above. */
1418
1419
1420
1421static Lisp_Object
1422selection_data_to_lisp_data (display, data, size, type, format)
1423 Display *display;
1424 unsigned char *data;
1425 Atom type;
1426 int size, format;
1427{
5c3a351a 1428 struct x_display_info *dpyinfo = x_display_info_for_display (display);
ede4db72 1429
5c3a351a 1430 if (type == dpyinfo->Xatom_NULL)
ede4db72
RS
1431 return QNULL;
1432
1433 /* Convert any 8-bit data to a string, for compactness. */
1434 else if (format == 8)
1435 return make_string ((char *) data, size);
1436
1437 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1438 a vector of symbols.
1439 */
1440 else if (type == XA_ATOM)
1441 {
1442 int i;
1443 if (size == sizeof (Atom))
5c3a351a 1444 return x_atom_to_symbol (dpyinfo, display, *((Atom *) data));
ede4db72
RS
1445 else
1446 {
1447 Lisp_Object v = Fmake_vector (size / sizeof (Atom), 0);
1448 for (i = 0; i < size / sizeof (Atom); i++)
5c3a351a
RS
1449 Faset (v, i, x_atom_to_symbol (dpyinfo, display,
1450 ((Atom *) data) [i]));
ede4db72
RS
1451 return v;
1452 }
1453 }
1454
1455 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1456 If the number is > 16 bits, convert it to a cons of integers,
1457 16 bits in each half.
1458 */
1459 else if (format == 32 && size == sizeof (long))
1460 return long_to_cons (((unsigned long *) data) [0]);
1461 else if (format == 16 && size == sizeof (short))
1462 return make_number ((int) (((unsigned short *) data) [0]));
1463
1464 /* Convert any other kind of data to a vector of numbers, represented
1465 as above (as an integer, or a cons of two 16 bit integers.)
1466 */
1467 else if (format == 16)
1468 {
1469 int i;
1470 Lisp_Object v = Fmake_vector (size / 4, 0);
1471 for (i = 0; i < size / 4; i++)
1472 {
1473 int j = (int) ((unsigned short *) data) [i];
1474 Faset (v, i, make_number (j));
1475 }
1476 return v;
1477 }
1478 else
1479 {
1480 int i;
1481 Lisp_Object v = Fmake_vector (size / 4, 0);
1482 for (i = 0; i < size / 4; i++)
1483 {
1484 unsigned long j = ((unsigned long *) data) [i];
1485 Faset (v, i, long_to_cons (j));
1486 }
1487 return v;
1488 }
1489}
1490
1491
1492static void
1493lisp_data_to_selection_data (display, obj,
aca39f42
RS
1494 data_ret, type_ret, size_ret,
1495 format_ret, nofree_ret)
ede4db72
RS
1496 Display *display;
1497 Lisp_Object obj;
1498 unsigned char **data_ret;
1499 Atom *type_ret;
1500 unsigned int *size_ret;
1501 int *format_ret;
aca39f42 1502 int *nofree_ret;
ede4db72
RS
1503{
1504 Lisp_Object type = Qnil;
5c3a351a 1505 struct x_display_info *dpyinfo = x_display_info_for_display (display);
aca39f42
RS
1506
1507 *nofree_ret = 0;
1508
ede4db72
RS
1509 if (CONSP (obj) && SYMBOLP (XCONS (obj)->car))
1510 {
1511 type = XCONS (obj)->car;
1512 obj = XCONS (obj)->cdr;
1513 if (CONSP (obj) && NILP (XCONS (obj)->cdr))
1514 obj = XCONS (obj)->car;
1515 }
1516
1517 if (EQ (obj, QNULL) || (EQ (type, QNULL)))
1518 { /* This is not the same as declining */
1519 *format_ret = 32;
1520 *size_ret = 0;
1521 *data_ret = 0;
1522 type = QNULL;
1523 }
1524 else if (STRINGP (obj))
1525 {
1526 *format_ret = 8;
1527 *size_ret = XSTRING (obj)->size;
aca39f42
RS
1528 *data_ret = XSTRING (obj)->data;
1529 *nofree_ret = 1;
ede4db72
RS
1530 if (NILP (type)) type = QSTRING;
1531 }
1532 else if (SYMBOLP (obj))
1533 {
1534 *format_ret = 32;
1535 *size_ret = 1;
1536 *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
1537 (*data_ret) [sizeof (Atom)] = 0;
5c3a351a 1538 (*(Atom **) data_ret) [0] = symbol_to_x_atom (dpyinfo, display, obj);
ede4db72
RS
1539 if (NILP (type)) type = QATOM;
1540 }
7da64e5c 1541 else if (INTEGERP (obj)
ede4db72
RS
1542 && XINT (obj) < 0xFFFF
1543 && XINT (obj) > -0xFFFF)
1544 {
1545 *format_ret = 16;
1546 *size_ret = 1;
1547 *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
1548 (*data_ret) [sizeof (short)] = 0;
1549 (*(short **) data_ret) [0] = (short) XINT (obj);
1550 if (NILP (type)) type = QINTEGER;
1551 }
a87ed99c
RS
1552 else if (INTEGERP (obj)
1553 || (CONSP (obj) && INTEGERP (XCONS (obj)->car)
1554 && (INTEGERP (XCONS (obj)->cdr)
1555 || (CONSP (XCONS (obj)->cdr)
1556 && INTEGERP (XCONS (XCONS (obj)->cdr)->car)))))
ede4db72
RS
1557 {
1558 *format_ret = 32;
1559 *size_ret = 1;
1560 *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
1561 (*data_ret) [sizeof (long)] = 0;
1562 (*(unsigned long **) data_ret) [0] = cons_to_long (obj);
1563 if (NILP (type)) type = QINTEGER;
1564 }
1565 else if (VECTORP (obj))
1566 {
1567 /* Lisp_Vectors may represent a set of ATOMs;
1568 a set of 16 or 32 bit INTEGERs;
1569 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1570 */
1571 int i;
1572
1573 if (SYMBOLP (XVECTOR (obj)->contents [0]))
1574 /* This vector is an ATOM set */
1575 {
1576 if (NILP (type)) type = QATOM;
1577 *size_ret = XVECTOR (obj)->size;
1578 *format_ret = 32;
1579 *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
1580 for (i = 0; i < *size_ret; i++)
1581 if (SYMBOLP (XVECTOR (obj)->contents [i]))
1582 (*(Atom **) data_ret) [i]
5c3a351a 1583 = symbol_to_x_atom (dpyinfo, display, XVECTOR (obj)->contents [i]);
ede4db72
RS
1584 else
1585 Fsignal (Qerror, /* Qselection_error */
1586 Fcons (build_string
1587 ("all elements of selection vector must have same type"),
1588 Fcons (obj, Qnil)));
1589 }
1590#if 0 /* #### MULTIPLE doesn't work yet */
1591 else if (VECTORP (XVECTOR (obj)->contents [0]))
1592 /* This vector is an ATOM_PAIR set */
1593 {
1594 if (NILP (type)) type = QATOM_PAIR;
1595 *size_ret = XVECTOR (obj)->size;
1596 *format_ret = 32;
1597 *data_ret = (unsigned char *)
1598 xmalloc ((*size_ret) * sizeof (Atom) * 2);
1599 for (i = 0; i < *size_ret; i++)
1600 if (VECTORP (XVECTOR (obj)->contents [i]))
1601 {
1602 Lisp_Object pair = XVECTOR (obj)->contents [i];
1603 if (XVECTOR (pair)->size != 2)
1604 Fsignal (Qerror,
1605 Fcons (build_string
1606 ("elements of the vector must be vectors of exactly two elements"),
1607 Fcons (pair, Qnil)));
1608
1609 (*(Atom **) data_ret) [i * 2]
5c3a351a
RS
1610 = symbol_to_x_atom (dpyinfo, display,
1611 XVECTOR (pair)->contents [0]);
ede4db72 1612 (*(Atom **) data_ret) [(i * 2) + 1]
5c3a351a
RS
1613 = symbol_to_x_atom (dpyinfo, display,
1614 XVECTOR (pair)->contents [1]);
ede4db72
RS
1615 }
1616 else
1617 Fsignal (Qerror,
1618 Fcons (build_string
1619 ("all elements of the vector must be of the same type"),
1620 Fcons (obj, Qnil)));
1621
1622 }
1623#endif
1624 else
1625 /* This vector is an INTEGER set, or something like it */
1626 {
1627 *size_ret = XVECTOR (obj)->size;
1628 if (NILP (type)) type = QINTEGER;
1629 *format_ret = 16;
1630 for (i = 0; i < *size_ret; i++)
1631 if (CONSP (XVECTOR (obj)->contents [i]))
1632 *format_ret = 32;
7da64e5c 1633 else if (!INTEGERP (XVECTOR (obj)->contents [i]))
ede4db72
RS
1634 Fsignal (Qerror, /* Qselection_error */
1635 Fcons (build_string
1636 ("elements of selection vector must be integers or conses of integers"),
1637 Fcons (obj, Qnil)));
1638
1639 *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
1640 for (i = 0; i < *size_ret; i++)
1641 if (*format_ret == 32)
1642 (*((unsigned long **) data_ret)) [i]
1643 = cons_to_long (XVECTOR (obj)->contents [i]);
1644 else
1645 (*((unsigned short **) data_ret)) [i]
1646 = (unsigned short) cons_to_long (XVECTOR (obj)->contents [i]);
1647 }
1648 }
1649 else
1650 Fsignal (Qerror, /* Qselection_error */
1651 Fcons (build_string ("unrecognised selection data"),
1652 Fcons (obj, Qnil)));
1653
5c3a351a 1654 *type_ret = symbol_to_x_atom (dpyinfo, display, type);
ede4db72
RS
1655}
1656
1657static Lisp_Object
1658clean_local_selection_data (obj)
1659 Lisp_Object obj;
1660{
1661 if (CONSP (obj)
7da64e5c 1662 && INTEGERP (XCONS (obj)->car)
ede4db72 1663 && CONSP (XCONS (obj)->cdr)
7da64e5c 1664 && INTEGERP (XCONS (XCONS (obj)->cdr)->car)
ede4db72
RS
1665 && NILP (XCONS (XCONS (obj)->cdr)->cdr))
1666 obj = Fcons (XCONS (obj)->car, XCONS (obj)->cdr);
1667
1668 if (CONSP (obj)
7da64e5c
RS
1669 && INTEGERP (XCONS (obj)->car)
1670 && INTEGERP (XCONS (obj)->cdr))
ede4db72
RS
1671 {
1672 if (XINT (XCONS (obj)->car) == 0)
1673 return XCONS (obj)->cdr;
1674 if (XINT (XCONS (obj)->car) == -1)
1675 return make_number (- XINT (XCONS (obj)->cdr));
1676 }
1677 if (VECTORP (obj))
1678 {
1679 int i;
1680 int size = XVECTOR (obj)->size;
1681 Lisp_Object copy;
1682 if (size == 1)
1683 return clean_local_selection_data (XVECTOR (obj)->contents [0]);
1684 copy = Fmake_vector (size, Qnil);
1685 for (i = 0; i < size; i++)
1686 XVECTOR (copy)->contents [i]
1687 = clean_local_selection_data (XVECTOR (obj)->contents [i]);
1688 return copy;
1689 }
1690 return obj;
1691}
1692\f
1693/* Called from XTread_socket to handle SelectionNotify events.
1694 If it's the selection we are waiting for, stop waiting. */
1695
1696void
1697x_handle_selection_notify (event)
1698 XSelectionEvent *event;
1699{
1700 if (event->requestor != reading_selection_window)
1701 return;
1702 if (event->selection != reading_which_selection)
1703 return;
1704
1705 XCONS (reading_selection_reply)->car = Qt;
1706}
1707
1708\f
1709DEFUN ("x-own-selection-internal",
1710 Fx_own_selection_internal, Sx_own_selection_internal,
1711 2, 2, 0,
1712 "Assert an X selection of the given TYPE with the given VALUE.\n\
1713TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1714\(Those are literal upper-case symbol names, since that's what X expects.)\n\
1715VALUE is typically a string, or a cons of two markers, but may be\n\
a87ed99c 1716anything that the functions on `selection-converter-alist' know about.")
ede4db72
RS
1717 (selection_name, selection_value)
1718 Lisp_Object selection_name, selection_value;
1719{
703e0710 1720 check_x ();
ede4db72
RS
1721 CHECK_SYMBOL (selection_name, 0);
1722 if (NILP (selection_value)) error ("selection-value may not be nil.");
1723 x_own_selection (selection_name, selection_value);
1724 return selection_value;
1725}
1726
1727
1728/* Request the selection value from the owner. If we are the owner,
1729 simply return our selection value. If we are not the owner, this
1730 will block until all of the data has arrived. */
1731
1732DEFUN ("x-get-selection-internal",
1733 Fx_get_selection_internal, Sx_get_selection_internal, 2, 2, 0,
1734 "Return text selected from some X window.\n\
1735SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1736\(Those are literal upper-case symbol names, since that's what X expects.)\n\
a87ed99c 1737TYPE is the type of data desired, typically `STRING'.")
ede4db72
RS
1738 (selection_symbol, target_type)
1739 Lisp_Object selection_symbol, target_type;
1740{
1741 Lisp_Object val = Qnil;
1742 struct gcpro gcpro1, gcpro2;
1743 GCPRO2 (target_type, val); /* we store newly consed data into these */
703e0710 1744 check_x ();
ede4db72
RS
1745 CHECK_SYMBOL (selection_symbol, 0);
1746
1747#if 0 /* #### MULTIPLE doesn't work yet */
1748 if (CONSP (target_type)
1749 && XCONS (target_type)->car == QMULTIPLE)
1750 {
1751 CHECK_VECTOR (XCONS (target_type)->cdr, 0);
1752 /* So we don't destructively modify this... */
1753 target_type = copy_multiple_data (target_type);
1754 }
1755 else
1756#endif
1757 CHECK_SYMBOL (target_type, 0);
1758
1759 val = x_get_local_selection (selection_symbol, target_type);
1760
1761 if (NILP (val))
1762 {
1763 val = x_get_foreign_selection (selection_symbol, target_type);
1764 goto DONE;
1765 }
1766
1767 if (CONSP (val)
1768 && SYMBOLP (XCONS (val)->car))
1769 {
1770 val = XCONS (val)->cdr;
1771 if (CONSP (val) && NILP (XCONS (val)->cdr))
1772 val = XCONS (val)->car;
1773 }
1774 val = clean_local_selection_data (val);
1775 DONE:
1776 UNGCPRO;
1777 return val;
1778}
1779
1780DEFUN ("x-disown-selection-internal",
1781 Fx_disown_selection_internal, Sx_disown_selection_internal, 1, 2, 0,
a87ed99c
RS
1782 "If we own the selection SELECTION, disown it.\n\
1783Disowning it means there is no such selection.")
ede4db72
RS
1784 (selection, time)
1785 Lisp_Object selection;
1786 Lisp_Object time;
1787{
ede4db72
RS
1788 Time timestamp;
1789 Atom selection_atom;
1790 XSelectionClearEvent event;
3834c318 1791 Display *display;
5c3a351a 1792 struct x_display_info *dpyinfo;
ede4db72 1793
703e0710 1794 check_x ();
3834c318 1795 display = FRAME_X_DISPLAY (selected_frame);
5c3a351a 1796 dpyinfo = FRAME_X_DISPLAY_INFO (selected_frame);
ede4db72
RS
1797 CHECK_SYMBOL (selection, 0);
1798 if (NILP (time))
7da64e5c 1799 timestamp = last_event_timestamp;
ede4db72
RS
1800 else
1801 timestamp = cons_to_long (time);
1802
1803 if (NILP (assq_no_quit (selection, Vselection_alist)))
1804 return Qnil; /* Don't disown the selection when we're not the owner. */
1805
5c3a351a 1806 selection_atom = symbol_to_x_atom (dpyinfo, display, selection);
ede4db72
RS
1807
1808 BLOCK_INPUT;
1809 XSetSelectionOwner (display, selection_atom, None, timestamp);
1810 UNBLOCK_INPUT;
1811
eb8c3be9 1812 /* It doesn't seem to be guaranteed that a SelectionClear event will be
ede4db72
RS
1813 generated for a window which owns the selection when that window sets
1814 the selection owner to None. The NCD server does, the MIT Sun4 server
1815 doesn't. So we synthesize one; this means we might get two, but
1816 that's ok, because the second one won't have any effect. */
8d47f8c4
RS
1817 SELECTION_EVENT_DISPLAY (&event) = display;
1818 SELECTION_EVENT_SELECTION (&event) = selection_atom;
1819 SELECTION_EVENT_TIME (&event) = timestamp;
ede4db72
RS
1820 x_handle_selection_clear (&event);
1821
1822 return Qt;
1823}
1824
a87ed99c
RS
1825/* Get rid of all the selections in buffer BUFFER.
1826 This is used when we kill a buffer. */
1827
1828void
1829x_disown_buffer_selections (buffer)
1830 Lisp_Object buffer;
1831{
1832 Lisp_Object tail;
1833 struct buffer *buf = XBUFFER (buffer);
1834
1835 for (tail = Vselection_alist; CONSP (tail); tail = XCONS (tail)->cdr)
1836 {
1837 Lisp_Object elt, value;
1838 elt = XCONS (tail)->car;
1839 value = XCONS (elt)->cdr;
1840 if (CONSP (value) && MARKERP (XCONS (value)->car)
1841 && XMARKER (XCONS (value)->car)->buffer == buf)
1842 Fx_disown_selection_internal (XCONS (elt)->car, Qnil);
1843 }
1844}
ede4db72
RS
1845
1846DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
1847 0, 1, 0,
a87ed99c 1848 "Whether the current Emacs process owns the given X Selection.\n\
ede4db72
RS
1849The arg should be the name of the selection in question, typically one of\n\
1850the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1851\(Those are literal upper-case symbol names, since that's what X expects.)\n\
1852For convenience, the symbol nil is the same as `PRIMARY',\n\
1853and t is the same as `SECONDARY'.)")
1854 (selection)
1855 Lisp_Object selection;
1856{
703e0710 1857 check_x ();
ede4db72
RS
1858 CHECK_SYMBOL (selection, 0);
1859 if (EQ (selection, Qnil)) selection = QPRIMARY;
1860 if (EQ (selection, Qt)) selection = QSECONDARY;
1861
1862 if (NILP (Fassq (selection, Vselection_alist)))
1863 return Qnil;
1864 return Qt;
1865}
1866
1867DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
1868 0, 1, 0,
1869 "Whether there is an owner for the given X Selection.\n\
1870The arg should be the name of the selection in question, typically one of\n\
1871the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1872\(Those are literal upper-case symbol names, since that's what X expects.)\n\
1873For convenience, the symbol nil is the same as `PRIMARY',\n\
1874and t is the same as `SECONDARY'.)")
1875 (selection)
1876 Lisp_Object selection;
1877{
1878 Window owner;
356ba514 1879 Atom atom;
3834c318
RS
1880 Display *dpy;
1881
b8c70430 1882 /* It should be safe to call this before we have an X frame. */
c6423dc1 1883 if (! FRAME_X_P (selected_frame))
b8c70430
RS
1884 return Qnil;
1885
3834c318 1886 dpy = FRAME_X_DISPLAY (selected_frame);
ede4db72
RS
1887 CHECK_SYMBOL (selection, 0);
1888 if (!NILP (Fx_selection_owner_p (selection)))
1889 return Qt;
356ba514
RS
1890 if (EQ (selection, Qnil)) selection = QPRIMARY;
1891 if (EQ (selection, Qt)) selection = QSECONDARY;
5c3a351a
RS
1892 atom = symbol_to_x_atom (FRAME_X_DISPLAY_INFO (selected_frame),
1893 dpy, selection);
356ba514
RS
1894 if (atom == 0)
1895 return Qnil;
ede4db72 1896 BLOCK_INPUT;
356ba514 1897 owner = XGetSelectionOwner (dpy, atom);
ede4db72
RS
1898 UNBLOCK_INPUT;
1899 return (owner ? Qt : Qnil);
1900}
1901
1902\f
1903#ifdef CUT_BUFFER_SUPPORT
1904
ede4db72
RS
1905/* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1906static void
1907initialize_cut_buffers (display, window)
1908 Display *display;
1909 Window window;
1910{
1911 unsigned char *data = (unsigned char *) "";
1912 BLOCK_INPUT;
1913#define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1914 PropModeAppend, data, 0)
1915 FROB (XA_CUT_BUFFER0);
1916 FROB (XA_CUT_BUFFER1);
1917 FROB (XA_CUT_BUFFER2);
1918 FROB (XA_CUT_BUFFER3);
1919 FROB (XA_CUT_BUFFER4);
1920 FROB (XA_CUT_BUFFER5);
1921 FROB (XA_CUT_BUFFER6);
1922 FROB (XA_CUT_BUFFER7);
1923#undef FROB
1924 UNBLOCK_INPUT;
ede4db72
RS
1925}
1926
1927
a87ed99c 1928#define CHECK_CUT_BUFFER(symbol,n) \
ede4db72
RS
1929 { CHECK_SYMBOL ((symbol), (n)); \
1930 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1931 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1932 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1933 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1934 Fsignal (Qerror, \
a87ed99c 1935 Fcons (build_string ("doesn't name a cut buffer"), \
ede4db72
RS
1936 Fcons ((symbol), Qnil))); \
1937 }
1938
a87ed99c
RS
1939DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal,
1940 Sx_get_cut_buffer_internal, 1, 1, 0,
1941 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
ede4db72
RS
1942 (buffer)
1943 Lisp_Object buffer;
1944{
3834c318 1945 Window window;
ede4db72
RS
1946 Atom buffer_atom;
1947 unsigned char *data;
1948 int bytes;
1949 Atom type;
1950 int format;
1951 unsigned long size;
1952 Lisp_Object ret;
3834c318 1953 Display *display;
5c3a351a 1954 struct x_display_info *dpyinfo;
ede4db72 1955
703e0710 1956 check_x ();
3834c318 1957 display = FRAME_X_DISPLAY (selected_frame);
5c3a351a 1958 dpyinfo = FRAME_X_DISPLAY_INFO (selected_frame);
3834c318 1959 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
a87ed99c 1960 CHECK_CUT_BUFFER (buffer, 0);
5c3a351a 1961 buffer_atom = symbol_to_x_atom (dpyinfo, display, buffer);
ede4db72
RS
1962
1963 x_get_window_property (display, window, buffer_atom, &data, &bytes,
1964 &type, &format, &size, 0);
1965 if (!data) return Qnil;
1966
1967 if (format != 8 || type != XA_STRING)
1968 Fsignal (Qerror,
1969 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
5c3a351a 1970 Fcons (x_atom_to_symbol (dpyinfo, display, type),
ede4db72
RS
1971 Fcons (make_number (format), Qnil))));
1972
1973 ret = (bytes ? make_string ((char *) data, bytes) : Qnil);
1974 xfree (data);
1975 return ret;
1976}
1977
1978
a87ed99c
RS
1979DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal,
1980 Sx_store_cut_buffer_internal, 2, 2, 0,
1981 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
ede4db72
RS
1982 (buffer, string)
1983 Lisp_Object buffer, string;
1984{
3834c318 1985 Window window;
ede4db72
RS
1986 Atom buffer_atom;
1987 unsigned char *data;
1988 int bytes;
1989 int bytes_remaining;
3834c318
RS
1990 int max_bytes;
1991 Display *display;
ede4db72 1992
703e0710 1993 check_x ();
3834c318
RS
1994 display = FRAME_X_DISPLAY (selected_frame);
1995 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
1996
1997 max_bytes = SELECTION_QUANTUM (display);
1998 if (max_bytes > MAX_SELECTION_QUANTUM)
1999 max_bytes = MAX_SELECTION_QUANTUM;
2000
a87ed99c 2001 CHECK_CUT_BUFFER (buffer, 0);
ede4db72 2002 CHECK_STRING (string, 0);
5c3a351a
RS
2003 buffer_atom = symbol_to_x_atom (FRAME_X_DISPLAY_INFO (selected_frame),
2004 display, buffer);
ede4db72
RS
2005 data = (unsigned char *) XSTRING (string)->data;
2006 bytes = XSTRING (string)->size;
2007 bytes_remaining = bytes;
2008
04649dbc
KH
2009 if (! FRAME_X_DISPLAY_INFO (selected_frame)->cut_buffers_initialized)
2010 {
2011 initialize_cut_buffers (display, window);
2012 FRAME_X_DISPLAY_INFO (selected_frame)->cut_buffers_initialized = 1;
2013 }
ede4db72
RS
2014
2015 BLOCK_INPUT;
10608c8c
RS
2016
2017 /* Don't mess up with an empty value. */
2018 if (!bytes_remaining)
2019 XChangeProperty (display, window, buffer_atom, XA_STRING, 8,
2020 PropModeReplace, data, 0);
2021
ede4db72
RS
2022 while (bytes_remaining)
2023 {
2024 int chunk = (bytes_remaining < max_bytes
2025 ? bytes_remaining : max_bytes);
2026 XChangeProperty (display, window, buffer_atom, XA_STRING, 8,
2027 (bytes_remaining == bytes
2028 ? PropModeReplace
2029 : PropModeAppend),
2030 data, chunk);
2031 data += chunk;
2032 bytes_remaining -= chunk;
2033 }
2034 UNBLOCK_INPUT;
2035 return string;
2036}
2037
2038
a87ed99c
RS
2039DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal,
2040 Sx_rotate_cut_buffers_internal, 1, 1, 0,
2041 "Rotate the values of the cut buffers by the given number of steps;\n\
ede4db72
RS
2042positive means move values forward, negative means backward.")
2043 (n)
2044 Lisp_Object n;
2045{
3834c318
RS
2046 Window window;
2047 Atom props[8];
2048 Display *display;
ede4db72 2049
703e0710 2050 check_x ();
3834c318
RS
2051 display = FRAME_X_DISPLAY (selected_frame);
2052 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
7da64e5c 2053 CHECK_NUMBER (n, 0);
3834c318
RS
2054 if (XINT (n) == 0)
2055 return n;
04649dbc
KH
2056 if (! FRAME_X_DISPLAY_INFO (selected_frame)->cut_buffers_initialized)
2057 {
2058 initialize_cut_buffers (display, window);
2059 FRAME_X_DISPLAY_INFO (selected_frame)->cut_buffers_initialized = 1;
2060 }
3834c318 2061
ede4db72
RS
2062 props[0] = XA_CUT_BUFFER0;
2063 props[1] = XA_CUT_BUFFER1;
2064 props[2] = XA_CUT_BUFFER2;
2065 props[3] = XA_CUT_BUFFER3;
2066 props[4] = XA_CUT_BUFFER4;
2067 props[5] = XA_CUT_BUFFER5;
2068 props[6] = XA_CUT_BUFFER6;
2069 props[7] = XA_CUT_BUFFER7;
2070 BLOCK_INPUT;
2071 XRotateWindowProperties (display, window, props, 8, XINT (n));
2072 UNBLOCK_INPUT;
2073 return n;
2074}
2075
2076#endif
2077\f
ede4db72
RS
2078void
2079syms_of_xselect ()
2080{
ede4db72
RS
2081 defsubr (&Sx_get_selection_internal);
2082 defsubr (&Sx_own_selection_internal);
2083 defsubr (&Sx_disown_selection_internal);
2084 defsubr (&Sx_selection_owner_p);
2085 defsubr (&Sx_selection_exists_p);
2086
2087#ifdef CUT_BUFFER_SUPPORT
a87ed99c
RS
2088 defsubr (&Sx_get_cut_buffer_internal);
2089 defsubr (&Sx_store_cut_buffer_internal);
2090 defsubr (&Sx_rotate_cut_buffers_internal);
ede4db72
RS
2091#endif
2092
2093 reading_selection_reply = Fcons (Qnil, Qnil);
2094 staticpro (&reading_selection_reply);
2095 reading_selection_window = 0;
2096 reading_which_selection = 0;
2097
2098 property_change_wait_list = 0;
2f65feb6 2099 prop_location_identifier = 0;
ede4db72
RS
2100 property_change_reply = Fcons (Qnil, Qnil);
2101 staticpro (&property_change_reply);
2102
2103 Vselection_alist = Qnil;
2104 staticpro (&Vselection_alist);
2105
2106 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
2107 "An alist associating X Windows selection-types with functions.\n\
2108These functions are called to convert the selection, with three args:\n\
2109the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
2110a desired type to which the selection should be converted;\n\
2111and the local selection value (whatever was given to `x-own-selection').\n\
2112\n\
2113The function should return the value to send to the X server\n\
2114\(typically a string). A return value of nil\n\
2115means that the conversion could not be done.\n\
2116A return value which is the symbol `NULL'\n\
2117means that a side-effect was executed,\n\
2118and there is no meaningful selection value.");
2119 Vselection_converter_alist = Qnil;
2120
2121 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks,
2122 "A list of functions to be called when Emacs loses an X selection.\n\
2123\(This happens when some other X client makes its own selection\n\
2124or when a Lisp program explicitly clears the selection.)\n\
2125The functions are called with one argument, the selection type\n\
2126\(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
2127 Vx_lost_selection_hooks = Qnil;
2128
2129 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks,
2130 "A list of functions to be called when Emacs answers a selection request.\n\
2131The functions are called with four arguments:\n\
2132 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
2133 - the selection-type which Emacs was asked to convert the\n\
2134 selection into before sending (for example, `STRING' or `LENGTH');\n\
2135 - a flag indicating success or failure for responding to the request.\n\
2136We might have failed (and declined the request) for any number of reasons,\n\
2137including being asked for a selection that we no longer own, or being asked\n\
2138to convert into a type that we don't know about or that is inappropriate.\n\
2139This hook doesn't let you change the behavior of Emacs's selection replies,\n\
2140it merely informs you that they have happened.");
2141 Vx_sent_selection_hooks = Qnil;
2142
2143 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout,
80da0190
RS
2144 "Number of milliseconds to wait for a selection reply.\n\
2145If the selection owner doens't reply in this time, we give up.\n\
ede4db72 2146A value of 0 means wait as long as necessary. This is initialized from the\n\
80da0190 2147\"*selectionTimeout\" resource.");
ede4db72
RS
2148 x_selection_timeout = 0;
2149
2150 QPRIMARY = intern ("PRIMARY"); staticpro (&QPRIMARY);
2151 QSECONDARY = intern ("SECONDARY"); staticpro (&QSECONDARY);
2152 QSTRING = intern ("STRING"); staticpro (&QSTRING);
2153 QINTEGER = intern ("INTEGER"); staticpro (&QINTEGER);
2154 QCLIPBOARD = intern ("CLIPBOARD"); staticpro (&QCLIPBOARD);
2155 QTIMESTAMP = intern ("TIMESTAMP"); staticpro (&QTIMESTAMP);
2156 QTEXT = intern ("TEXT"); staticpro (&QTEXT);
2157 QTIMESTAMP = intern ("TIMESTAMP"); staticpro (&QTIMESTAMP);
2158 QDELETE = intern ("DELETE"); staticpro (&QDELETE);
2159 QMULTIPLE = intern ("MULTIPLE"); staticpro (&QMULTIPLE);
2160 QINCR = intern ("INCR"); staticpro (&QINCR);
2161 QEMACS_TMP = intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP);
2162 QTARGETS = intern ("TARGETS"); staticpro (&QTARGETS);
2163 QATOM = intern ("ATOM"); staticpro (&QATOM);
2164 QATOM_PAIR = intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR);
2165 QNULL = intern ("NULL"); staticpro (&QNULL);
2166
2167#ifdef CUT_BUFFER_SUPPORT
2168 QCUT_BUFFER0 = intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0);
2169 QCUT_BUFFER1 = intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1);
2170 QCUT_BUFFER2 = intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2);
2171 QCUT_BUFFER3 = intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3);
2172 QCUT_BUFFER4 = intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4);
2173 QCUT_BUFFER5 = intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5);
2174 QCUT_BUFFER6 = intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6);
2175 QCUT_BUFFER7 = intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7);
2176#endif
2177
2178}