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