(init_display): Treat null string DISPLAY var like not set.
[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 requester 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 requester 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 requester 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 requester
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 /* Delete elements from the beginning of Vselection_alist. */
822 while (!NILP (Vselection_alist)
823 && EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (Vselection_alist)))))))
824 {
825 /* Let random Lisp code notice that the selection has been stolen. */
826 Lisp_Object hooks, selection_symbol;
827
828 hooks = Vx_lost_selection_hooks;
829 selection_symbol = Fcar (Fcar (Vselection_alist));
830
831 if (!EQ (hooks, Qunbound))
832 {
833 for (; CONSP (hooks); hooks = Fcdr (hooks))
834 call1 (Fcar (hooks), selection_symbol);
835 redisplay_preserve_echo_area ();
836 }
837
838 Vselection_alist = Fcdr (Vselection_alist);
839 }
840
841 /* Delete elements after the beginning of Vselection_alist. */
842 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
843 if (EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (XCONS (rest)->cdr)))))))
844 {
845 /* Let random Lisp code notice that the selection has been stolen. */
846 Lisp_Object hooks, selection_symbol;
847
848 hooks = Vx_lost_selection_hooks;
849 selection_symbol = Fcar (Fcar (XCONS (rest)->cdr));
850
851 if (!EQ (hooks, Qunbound))
852 {
853 for (; CONSP (hooks); hooks = Fcdr (hooks))
854 call1 (Fcar (hooks), selection_symbol);
855 redisplay_preserve_echo_area ();
856 }
857 XCONS (rest)->cdr = Fcdr (XCONS (rest)->cdr);
858 break;
859 }
860 }
861 \f
862 /* Nonzero if any properties for DISPLAY and WINDOW
863 are on the list of what we are waiting for. */
864
865 static int
866 waiting_for_other_props_on_window (display, window)
867 Display *display;
868 Window window;
869 {
870 struct prop_location *rest = property_change_wait_list;
871 while (rest)
872 if (rest->display == display && rest->window == window)
873 return 1;
874 else
875 rest = rest->next;
876 return 0;
877 }
878
879 /* Add an entry to the list of property changes we are waiting for.
880 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
881 The return value is a number that uniquely identifies
882 this awaited property change. */
883
884 static struct prop_location *
885 expect_property_change (display, window, property, state)
886 Display *display;
887 Window window;
888 Lisp_Object property;
889 int state;
890 {
891 struct prop_location *pl
892 = (struct prop_location *) xmalloc (sizeof (struct prop_location));
893 pl->identifier = ++prop_location_identifier;
894 pl->display = display;
895 pl->window = window;
896 pl->property = property;
897 pl->desired_state = state;
898 pl->next = property_change_wait_list;
899 pl->arrived = 0;
900 property_change_wait_list = pl;
901 return pl;
902 }
903
904 /* Delete an entry from the list of property changes we are waiting for.
905 IDENTIFIER is the number that uniquely identifies the entry. */
906
907 static void
908 unexpect_property_change (location)
909 struct prop_location *location;
910 {
911 struct prop_location *prev = 0, *rest = property_change_wait_list;
912 while (rest)
913 {
914 if (rest == location)
915 {
916 if (prev)
917 prev->next = rest->next;
918 else
919 property_change_wait_list = rest->next;
920 xfree (rest);
921 return;
922 }
923 prev = rest;
924 rest = rest->next;
925 }
926 }
927
928 /* Remove the property change expectation element for IDENTIFIER. */
929
930 static Lisp_Object
931 wait_for_property_change_unwind (identifierval)
932 Lisp_Object identifierval;
933 {
934 unexpect_property_change ((struct prop_location *)
935 (XFASTINT (XCONS (identifierval)->car) << 16
936 | XFASTINT (XCONS (identifierval)->cdr)));
937 return Qnil;
938 }
939
940 /* Actually wait for a property change.
941 IDENTIFIER should be the value that expect_property_change returned. */
942
943 static void
944 wait_for_property_change (location)
945 struct prop_location *location;
946 {
947 int secs, usecs;
948 int count = specpdl_ptr - specpdl;
949 Lisp_Object tem;
950
951 tem = Fcons (Qnil, Qnil);
952 XSETFASTINT (XCONS (tem)->car, (EMACS_UINT)location >> 16);
953 XSETFASTINT (XCONS (tem)->cdr, (EMACS_UINT)location & 0xffff);
954
955 /* Make sure to do unexpect_property_change if we quit or err. */
956 record_unwind_protect (wait_for_property_change_unwind, tem);
957
958 XCONS (property_change_reply)->car = Qnil;
959
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. */
963 if (! location->arrived)
964 {
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 }
972
973 unbind_to (count, Qnil);
974 }
975
976 /* Called from XTread_socket in response to a PropertyNotify event. */
977
978 void
979 x_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"),
993 (char *) XSYMBOL (x_atom_to_symbol (dpyinfo, event->display,
994 event->atom))
995 ->name->data);
996 #endif
997
998 rest->arrived = 1;
999
1000 /* If this is the one wait_for_property_change is waiting for,
1001 tell it to wake up. */
1002 if (rest == property_change_reply_object)
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"),
1018 (char *) XSYMBOL (x_atom_to_symbol (dpyinfo,
1019 event->display, event->atom))
1020 ->name->data);
1021 #endif
1022 }
1023
1024
1025 \f
1026 #if 0 /* #### MULTIPLE doesn't work yet */
1027
1028 static Lisp_Object
1029 fetch_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
1044 static Lisp_Object
1045 copy_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. */
1077 static Atom reading_which_selection;
1078 static Lisp_Object reading_selection_reply;
1079 static 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
1084 static Lisp_Object
1085 x_get_foreign_selection (selection_symbol, target_type)
1086 Lisp_Object selection_symbol, target_type;
1087 {
1088 Window requestor_window = FRAME_X_WINDOW (selected_frame);
1089 Display *display = FRAME_X_DISPLAY (selected_frame);
1090 struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (selected_frame);
1091 Time requestor_time = last_event_timestamp;
1092 Atom target_property = dpyinfo->Xatom_EMACS_TMP;
1093 Atom selection_atom = symbol_to_x_atom (dpyinfo, display, selection_symbol);
1094 Atom type_atom;
1095 int secs, usecs;
1096 int count = specpdl_ptr - specpdl;
1097 Lisp_Object frame;
1098
1099 if (CONSP (target_type))
1100 type_atom = symbol_to_x_atom (dpyinfo, display, XCONS (target_type)->car);
1101 else
1102 type_atom = symbol_to_x_atom (dpyinfo, display, target_type);
1103
1104 BLOCK_INPUT;
1105 x_catch_errors (display);
1106 XConvertSelection (display, selection_atom, type_atom, target_property,
1107 requestor_window, requestor_time);
1108 XFlush (display);
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;
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 }
1127 UNBLOCK_INPUT;
1128
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);
1133
1134 BLOCK_INPUT;
1135 x_check_errors (display, "Cannot get selection: %s");
1136 x_uncatch_errors (display);
1137 unbind_to (count, Qnil);
1138 UNBLOCK_INPUT;
1139
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
1152 static void
1153 x_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 0L, 0L, False, AnyPropertyType,
1178 actual_type_ret, actual_format_ret,
1179 actual_size_ret,
1180 &bytes_remaining, &tmp_data);
1181 if (result != Success)
1182 {
1183 UNBLOCK_INPUT;
1184 *data_ret = 0;
1185 *bytes_ret = 0;
1186 return;
1187 }
1188 xfree ((char *) tmp_data);
1189
1190 if (*actual_type_ret == None || *actual_format_ret == 0)
1191 {
1192 UNBLOCK_INPUT;
1193 return;
1194 }
1195
1196 total_size = bytes_remaining + 1;
1197 *data_ret = (unsigned char *) xmalloc (total_size);
1198
1199 /* Now read, until we've gotten it all. */
1200 while (bytes_remaining)
1201 {
1202 #if 0
1203 int last = bytes_remaining;
1204 #endif
1205 result
1206 = XGetWindowProperty (display, window, property,
1207 (long)offset/4, (long)buffer_size/4,
1208 False,
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;
1223 xfree ((char *) tmp_data);
1224 }
1225
1226 XFlush (display);
1227 UNBLOCK_INPUT;
1228 *bytes_ret = offset;
1229 }
1230 \f
1231 static void
1232 receive_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;
1247 struct prop_location *wait_object;
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
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.)
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 */
1262 BLOCK_INPUT;
1263 XSelectInput (display, window, STANDARD_EVENT_SET | PropertyChangeMask);
1264 XDeleteProperty (display, window, property);
1265 wait_object = expect_property_change (display, window, property,
1266 PropertyNewValue);
1267 XFlush (display);
1268 UNBLOCK_INPUT;
1269
1270 while (1)
1271 {
1272 unsigned char *tmp_data;
1273 int tmp_size_bytes;
1274 wait_for_property_change (wait_object);
1275 /* expect it again immediately, because x_get_window_property may
1276 .. no it won't, I don't get it.
1277 .. Ok, I get it now, the Xt code that implements INCR is broken.
1278 */
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
1288 if (! waiting_for_other_props_on_window (display, window))
1289 XSelectInput (display, window, STANDARD_EVENT_SET);
1290 unexpect_property_change (wait_object);
1291 if (tmp_data) xfree (tmp_data);
1292 break;
1293 }
1294
1295 BLOCK_INPUT;
1296 XDeleteProperty (display, window, property);
1297 wait_object = expect_property_change (display, window, property,
1298 PropertyNewValue);
1299 XFlush (display);
1300 UNBLOCK_INPUT;
1301
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 }
1314 bcopy (tmp_data, (*data_ret) + offset, tmp_size_bytes);
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
1324 static Lisp_Object
1325 x_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;
1339 struct x_display_info *dpyinfo = x_display_info_for_display (display);
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,
1356 Fcons (x_atom_to_symbol (dpyinfo, display,
1357 actual_type),
1358 Qnil))
1359 : Fcons (target_type, Qnil))
1360 : Fcons (build_string ("no selection"),
1361 Fcons (x_atom_to_symbol (dpyinfo, display,
1362 selection_atom),
1363 Qnil)));
1364 }
1365
1366 if (actual_type == dpyinfo->Xatom_INCR)
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
1380 BLOCK_INPUT;
1381 XDeleteProperty (display, window, property);
1382 XFlush (display);
1383 UNBLOCK_INPUT;
1384
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
1421 static Lisp_Object
1422 selection_data_to_lisp_data (display, data, size, type, format)
1423 Display *display;
1424 unsigned char *data;
1425 Atom type;
1426 int size, format;
1427 {
1428 struct x_display_info *dpyinfo = x_display_info_for_display (display);
1429
1430 if (type == dpyinfo->Xatom_NULL)
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))
1444 return x_atom_to_symbol (dpyinfo, display, *((Atom *) data));
1445 else
1446 {
1447 Lisp_Object v = Fmake_vector (size / sizeof (Atom), 0);
1448 for (i = 0; i < size / sizeof (Atom); i++)
1449 Faset (v, i, x_atom_to_symbol (dpyinfo, display,
1450 ((Atom *) data) [i]));
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
1492 static void
1493 lisp_data_to_selection_data (display, obj,
1494 data_ret, type_ret, size_ret,
1495 format_ret, nofree_ret)
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;
1502 int *nofree_ret;
1503 {
1504 Lisp_Object type = Qnil;
1505 struct x_display_info *dpyinfo = x_display_info_for_display (display);
1506
1507 *nofree_ret = 0;
1508
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;
1528 *data_ret = XSTRING (obj)->data;
1529 *nofree_ret = 1;
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;
1538 (*(Atom **) data_ret) [0] = symbol_to_x_atom (dpyinfo, display, obj);
1539 if (NILP (type)) type = QATOM;
1540 }
1541 else if (INTEGERP (obj)
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 }
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)))))
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]
1583 = symbol_to_x_atom (dpyinfo, display, XVECTOR (obj)->contents [i]);
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]
1610 = symbol_to_x_atom (dpyinfo, display,
1611 XVECTOR (pair)->contents [0]);
1612 (*(Atom **) data_ret) [(i * 2) + 1]
1613 = symbol_to_x_atom (dpyinfo, display,
1614 XVECTOR (pair)->contents [1]);
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;
1633 else if (!INTEGERP (XVECTOR (obj)->contents [i]))
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
1654 *type_ret = symbol_to_x_atom (dpyinfo, display, type);
1655 }
1656
1657 static Lisp_Object
1658 clean_local_selection_data (obj)
1659 Lisp_Object obj;
1660 {
1661 if (CONSP (obj)
1662 && INTEGERP (XCONS (obj)->car)
1663 && CONSP (XCONS (obj)->cdr)
1664 && INTEGERP (XCONS (XCONS (obj)->cdr)->car)
1665 && NILP (XCONS (XCONS (obj)->cdr)->cdr))
1666 obj = Fcons (XCONS (obj)->car, XCONS (obj)->cdr);
1667
1668 if (CONSP (obj)
1669 && INTEGERP (XCONS (obj)->car)
1670 && INTEGERP (XCONS (obj)->cdr))
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
1696 void
1697 x_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
1709 DEFUN ("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\
1713 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1714 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1715 VALUE is typically a string, or a cons of two markers, but may be\n\
1716 anything that the functions on `selection-converter-alist' know about.")
1717 (selection_name, selection_value)
1718 Lisp_Object selection_name, selection_value;
1719 {
1720 check_x ();
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
1732 DEFUN ("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\
1735 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1736 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1737 TYPE is the type of data desired, typically `STRING'.")
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 */
1744 check_x ();
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
1780 DEFUN ("x-disown-selection-internal",
1781 Fx_disown_selection_internal, Sx_disown_selection_internal, 1, 2, 0,
1782 "If we own the selection SELECTION, disown it.\n\
1783 Disowning it means there is no such selection.")
1784 (selection, time)
1785 Lisp_Object selection;
1786 Lisp_Object time;
1787 {
1788 Time timestamp;
1789 Atom selection_atom;
1790 XSelectionClearEvent event;
1791 Display *display;
1792 struct x_display_info *dpyinfo;
1793
1794 check_x ();
1795 display = FRAME_X_DISPLAY (selected_frame);
1796 dpyinfo = FRAME_X_DISPLAY_INFO (selected_frame);
1797 CHECK_SYMBOL (selection, 0);
1798 if (NILP (time))
1799 timestamp = last_event_timestamp;
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
1806 selection_atom = symbol_to_x_atom (dpyinfo, display, selection);
1807
1808 BLOCK_INPUT;
1809 XSetSelectionOwner (display, selection_atom, None, timestamp);
1810 UNBLOCK_INPUT;
1811
1812 /* It doesn't seem to be guaranteed that a SelectionClear event will be
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. */
1817 SELECTION_EVENT_DISPLAY (&event) = display;
1818 SELECTION_EVENT_SELECTION (&event) = selection_atom;
1819 SELECTION_EVENT_TIME (&event) = timestamp;
1820 x_handle_selection_clear (&event);
1821
1822 return Qt;
1823 }
1824
1825 /* Get rid of all the selections in buffer BUFFER.
1826 This is used when we kill a buffer. */
1827
1828 void
1829 x_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 }
1845
1846 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
1847 0, 1, 0,
1848 "Whether the current Emacs process owns the given X Selection.\n\
1849 The arg should be the name of the selection in question, typically one of\n\
1850 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1851 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1852 For convenience, the symbol nil is the same as `PRIMARY',\n\
1853 and t is the same as `SECONDARY'.)")
1854 (selection)
1855 Lisp_Object selection;
1856 {
1857 check_x ();
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
1867 DEFUN ("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\
1870 The arg should be the name of the selection in question, typically one of\n\
1871 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1872 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1873 For convenience, the symbol nil is the same as `PRIMARY',\n\
1874 and t is the same as `SECONDARY'.)")
1875 (selection)
1876 Lisp_Object selection;
1877 {
1878 Window owner;
1879 Atom atom;
1880 Display *dpy;
1881
1882 /* It should be safe to call this before we have an X frame. */
1883 if (! FRAME_X_P (selected_frame))
1884 return Qnil;
1885
1886 dpy = FRAME_X_DISPLAY (selected_frame);
1887 CHECK_SYMBOL (selection, 0);
1888 if (!NILP (Fx_selection_owner_p (selection)))
1889 return Qt;
1890 if (EQ (selection, Qnil)) selection = QPRIMARY;
1891 if (EQ (selection, Qt)) selection = QSECONDARY;
1892 atom = symbol_to_x_atom (FRAME_X_DISPLAY_INFO (selected_frame),
1893 dpy, selection);
1894 if (atom == 0)
1895 return Qnil;
1896 BLOCK_INPUT;
1897 owner = XGetSelectionOwner (dpy, atom);
1898 UNBLOCK_INPUT;
1899 return (owner ? Qt : Qnil);
1900 }
1901
1902 \f
1903 #ifdef CUT_BUFFER_SUPPORT
1904
1905 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1906 static void
1907 initialize_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;
1925 }
1926
1927
1928 #define CHECK_CUT_BUFFER(symbol,n) \
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, \
1935 Fcons (build_string ("doesn't name a cut buffer"), \
1936 Fcons ((symbol), Qnil))); \
1937 }
1938
1939 DEFUN ("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).")
1942 (buffer)
1943 Lisp_Object buffer;
1944 {
1945 Window window;
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;
1953 Display *display;
1954 struct x_display_info *dpyinfo;
1955
1956 check_x ();
1957 display = FRAME_X_DISPLAY (selected_frame);
1958 dpyinfo = FRAME_X_DISPLAY_INFO (selected_frame);
1959 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
1960 CHECK_CUT_BUFFER (buffer, 0);
1961 buffer_atom = symbol_to_x_atom (dpyinfo, display, buffer);
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"),
1970 Fcons (x_atom_to_symbol (dpyinfo, display, type),
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
1979 DEFUN ("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).")
1982 (buffer, string)
1983 Lisp_Object buffer, string;
1984 {
1985 Window window;
1986 Atom buffer_atom;
1987 unsigned char *data;
1988 int bytes;
1989 int bytes_remaining;
1990 int max_bytes;
1991 Display *display;
1992
1993 check_x ();
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
2001 CHECK_CUT_BUFFER (buffer, 0);
2002 CHECK_STRING (string, 0);
2003 buffer_atom = symbol_to_x_atom (FRAME_X_DISPLAY_INFO (selected_frame),
2004 display, buffer);
2005 data = (unsigned char *) XSTRING (string)->data;
2006 bytes = XSTRING (string)->size;
2007 bytes_remaining = bytes;
2008
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 }
2014
2015 BLOCK_INPUT;
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
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
2039 DEFUN ("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\
2042 positive means move values forward, negative means backward.")
2043 (n)
2044 Lisp_Object n;
2045 {
2046 Window window;
2047 Atom props[8];
2048 Display *display;
2049
2050 check_x ();
2051 display = FRAME_X_DISPLAY (selected_frame);
2052 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
2053 CHECK_NUMBER (n, 0);
2054 if (XINT (n) == 0)
2055 return n;
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 }
2061
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
2078 void
2079 syms_of_xselect ()
2080 {
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
2088 defsubr (&Sx_get_cut_buffer_internal);
2089 defsubr (&Sx_store_cut_buffer_internal);
2090 defsubr (&Sx_rotate_cut_buffers_internal);
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;
2099 prop_location_identifier = 0;
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\
2108 These functions are called to convert the selection, with three args:\n\
2109 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
2110 a desired type to which the selection should be converted;\n\
2111 and the local selection value (whatever was given to `x-own-selection').\n\
2112 \n\
2113 The function should return the value to send to the X server\n\
2114 \(typically a string). A return value of nil\n\
2115 means that the conversion could not be done.\n\
2116 A return value which is the symbol `NULL'\n\
2117 means that a side-effect was executed,\n\
2118 and 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\
2124 or when a Lisp program explicitly clears the selection.)\n\
2125 The 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\
2131 The 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\
2136 We might have failed (and declined the request) for any number of reasons,\n\
2137 including being asked for a selection that we no longer own, or being asked\n\
2138 to convert into a type that we don't know about or that is inappropriate.\n\
2139 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
2140 it merely informs you that they have happened.");
2141 Vx_sent_selection_hooks = Qnil;
2142
2143 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout,
2144 "Number of milliseconds to wait for a selection reply.\n\
2145 If the selection owner doesn't reply in this time, we give up.\n\
2146 A value of 0 means wait as long as necessary. This is initialized from the\n\
2147 \"*selectionTimeout\" resource.");
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 }