]> code.delx.au - gnu-emacs/blob - src/xselect.c
(archive-l-e): New optional argument `float' means generate a float value.
[gnu-emacs] / src / xselect.c
1 /* X Selection processing for Emacs.
2 Copyright (C) 1993, 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
3 2004, 2005, 2006 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
21
22
23 /* Rewritten by jwz */
24
25 #include <config.h>
26 #include <stdio.h> /* termhooks.h needs this */
27
28 #ifdef HAVE_SYS_TYPES_H
29 #include <sys/types.h>
30 #endif
31 #ifdef HAVE_UNISTD_H
32 #include <unistd.h>
33 #endif
34
35 #include "lisp.h"
36 #include "xterm.h" /* for all of the X includes */
37 #include "dispextern.h" /* frame.h seems to want this */
38 #include "frame.h" /* Need this to get the X window of selected_frame */
39 #include "blockinput.h"
40 #include "buffer.h"
41 #include "process.h"
42 #include "termhooks.h"
43 #include "keyboard.h"
44
45 #include <X11/Xproto.h>
46
47 struct prop_location;
48
49 static Lisp_Object x_atom_to_symbol P_ ((Display *dpy, Atom atom));
50 static Atom symbol_to_x_atom P_ ((struct x_display_info *, Display *,
51 Lisp_Object));
52 static void x_own_selection P_ ((Lisp_Object, Lisp_Object));
53 static Lisp_Object x_get_local_selection P_ ((Lisp_Object, Lisp_Object, int));
54 static void x_decline_selection_request P_ ((struct input_event *));
55 static Lisp_Object x_selection_request_lisp_error P_ ((Lisp_Object));
56 static Lisp_Object queue_selection_requests_unwind P_ ((Lisp_Object));
57 static Lisp_Object some_frame_on_display P_ ((struct x_display_info *));
58 static Lisp_Object x_catch_errors_unwind P_ ((Lisp_Object));
59 static void x_reply_selection_request P_ ((struct input_event *, int,
60 unsigned char *, int, Atom));
61 static int waiting_for_other_props_on_window P_ ((Display *, Window));
62 static struct prop_location *expect_property_change P_ ((Display *, Window,
63 Atom, int));
64 static void unexpect_property_change P_ ((struct prop_location *));
65 static Lisp_Object wait_for_property_change_unwind P_ ((Lisp_Object));
66 static void wait_for_property_change P_ ((struct prop_location *));
67 static Lisp_Object x_get_foreign_selection P_ ((Lisp_Object,
68 Lisp_Object,
69 Lisp_Object));
70 static void x_get_window_property P_ ((Display *, Window, Atom,
71 unsigned char **, int *,
72 Atom *, int *, unsigned long *, int));
73 static void receive_incremental_selection P_ ((Display *, Window, Atom,
74 Lisp_Object, unsigned,
75 unsigned char **, int *,
76 Atom *, int *, unsigned long *));
77 static Lisp_Object x_get_window_property_as_lisp_data P_ ((Display *,
78 Window, Atom,
79 Lisp_Object, Atom));
80 static Lisp_Object selection_data_to_lisp_data P_ ((Display *, unsigned char *,
81 int, Atom, int));
82 static void lisp_data_to_selection_data P_ ((Display *, Lisp_Object,
83 unsigned char **, Atom *,
84 unsigned *, int *, int *));
85 static Lisp_Object clean_local_selection_data P_ ((Lisp_Object));
86 static void initialize_cut_buffers P_ ((Display *, Window));
87
88
89 /* Printing traces to stderr. */
90
91 #ifdef TRACE_SELECTION
92 #define TRACE0(fmt) \
93 fprintf (stderr, "%d: " fmt "\n", getpid ())
94 #define TRACE1(fmt, a0) \
95 fprintf (stderr, "%d: " fmt "\n", getpid (), a0)
96 #define TRACE2(fmt, a0, a1) \
97 fprintf (stderr, "%d: " fmt "\n", getpid (), a0, a1)
98 #define TRACE3(fmt, a0, a1, a2) \
99 fprintf (stderr, "%d: " fmt "\n", getpid (), a0, a1, a2)
100 #else
101 #define TRACE0(fmt) (void) 0
102 #define TRACE1(fmt, a0) (void) 0
103 #define TRACE2(fmt, a0, a1) (void) 0
104 #define TRACE3(fmt, a0, a1) (void) 0
105 #endif
106
107
108 #define CUT_BUFFER_SUPPORT
109
110 Lisp_Object QPRIMARY, QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP,
111 QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL,
112 QATOM_PAIR;
113
114 Lisp_Object QCOMPOUND_TEXT; /* This is a type of selection. */
115 Lisp_Object QUTF8_STRING; /* This is a type of selection. */
116
117 Lisp_Object Qcompound_text_with_extensions;
118
119 #ifdef CUT_BUFFER_SUPPORT
120 Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
121 QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
122 #endif
123
124 static Lisp_Object Vx_lost_selection_functions;
125 static Lisp_Object Vx_sent_selection_functions;
126 /* Coding system for communicating with other X clients via cutbuffer,
127 selection, and clipboard. */
128 static Lisp_Object Vselection_coding_system;
129
130 /* Coding system for the next communicating with other X clients. */
131 static Lisp_Object Vnext_selection_coding_system;
132
133 static Lisp_Object Qforeign_selection;
134
135 /* If this is a smaller number than the max-request-size of the display,
136 emacs will use INCR selection transfer when the selection is larger
137 than this. The max-request-size is usually around 64k, so if you want
138 emacs to use incremental selection transfers when the selection is
139 smaller than that, set this. I added this mostly for debugging the
140 incremental transfer stuff, but it might improve server performance. */
141 #define MAX_SELECTION_QUANTUM 0xFFFFFF
142
143 #ifdef HAVE_X11R4
144 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
145 #else
146 #define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
147 #endif
148
149 /* The timestamp of the last input event Emacs received from the X server. */
150 /* Defined in keyboard.c. */
151 extern unsigned long last_event_timestamp;
152
153 /* This is an association list whose elements are of the form
154 ( SELECTION-NAME SELECTION-VALUE SELECTION-TIMESTAMP FRAME)
155 SELECTION-NAME is a lisp symbol, whose name is the name of an X Atom.
156 SELECTION-VALUE is the value that emacs owns for that selection.
157 It may be any kind of Lisp object.
158 SELECTION-TIMESTAMP is the time at which emacs began owning this selection,
159 as a cons of two 16-bit numbers (making a 32 bit time.)
160 FRAME is the frame for which we made the selection.
161 If there is an entry in this alist, then it can be assumed that Emacs owns
162 that selection.
163 The only (eq) parts of this list that are visible from Lisp are the
164 selection-values. */
165 static Lisp_Object Vselection_alist;
166
167 /* This is an alist whose CARs are selection-types (whose names are the same
168 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
169 call to convert the given Emacs selection value to a string representing
170 the given selection type. This is for Lisp-level extension of the emacs
171 selection handling. */
172 static Lisp_Object Vselection_converter_alist;
173
174 /* If the selection owner takes too long to reply to a selection request,
175 we give up on it. This is in milliseconds (0 = no timeout.) */
176 static EMACS_INT x_selection_timeout;
177
178
179 \f
180 /* Define a queue to save up SELECTION_REQUEST_EVENT events for later
181 handling. */
182
183 struct selection_event_queue
184 {
185 struct input_event event;
186 struct selection_event_queue *next;
187 };
188
189 static struct selection_event_queue *selection_queue;
190
191 /* Nonzero means queue up SELECTION_REQUEST_EVENT events. */
192
193 static int x_queue_selection_requests;
194
195 /* Queue up an SELECTION_REQUEST_EVENT *EVENT, to be processed later. */
196
197 static void
198 x_queue_event (event)
199 struct input_event *event;
200 {
201 struct selection_event_queue *queue_tmp;
202
203 /* Don't queue repeated requests.
204 This only happens for large requests which uses the incremental protocol. */
205 for (queue_tmp = selection_queue; queue_tmp; queue_tmp = queue_tmp->next)
206 {
207 if (!bcmp (&queue_tmp->event, event, sizeof (*event)))
208 {
209 TRACE1 ("DECLINE DUP SELECTION EVENT %08lx", (unsigned long)queue_tmp);
210 x_decline_selection_request (event);
211 return;
212 }
213 }
214
215 queue_tmp
216 = (struct selection_event_queue *) xmalloc (sizeof (struct selection_event_queue));
217
218 if (queue_tmp != NULL)
219 {
220 TRACE1 ("QUEUE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
221 queue_tmp->event = *event;
222 queue_tmp->next = selection_queue;
223 selection_queue = queue_tmp;
224 }
225 }
226
227 /* Start queuing SELECTION_REQUEST_EVENT events. */
228
229 static void
230 x_start_queuing_selection_requests ()
231 {
232 if (x_queue_selection_requests)
233 abort ();
234
235 x_queue_selection_requests++;
236 TRACE1 ("x_start_queuing_selection_requests %d", x_queue_selection_requests);
237 }
238
239 /* Stop queuing SELECTION_REQUEST_EVENT events. */
240
241 static void
242 x_stop_queuing_selection_requests ()
243 {
244 TRACE1 ("x_stop_queuing_selection_requests %d", x_queue_selection_requests);
245 --x_queue_selection_requests;
246
247 /* Take all the queued events and put them back
248 so that they get processed afresh. */
249
250 while (selection_queue != NULL)
251 {
252 struct selection_event_queue *queue_tmp = selection_queue;
253 TRACE1 ("RESTORE SELECTION EVENT %08lx", (unsigned long)queue_tmp);
254 kbd_buffer_unget_event (&queue_tmp->event);
255 selection_queue = queue_tmp->next;
256 xfree ((char *)queue_tmp);
257 }
258 }
259 \f
260
261 /* This converts a Lisp symbol to a server Atom, avoiding a server
262 roundtrip whenever possible. */
263
264 static Atom
265 symbol_to_x_atom (dpyinfo, display, sym)
266 struct x_display_info *dpyinfo;
267 Display *display;
268 Lisp_Object sym;
269 {
270 Atom val;
271 if (NILP (sym)) return 0;
272 if (EQ (sym, QPRIMARY)) return XA_PRIMARY;
273 if (EQ (sym, QSECONDARY)) return XA_SECONDARY;
274 if (EQ (sym, QSTRING)) return XA_STRING;
275 if (EQ (sym, QINTEGER)) return XA_INTEGER;
276 if (EQ (sym, QATOM)) return XA_ATOM;
277 if (EQ (sym, QCLIPBOARD)) return dpyinfo->Xatom_CLIPBOARD;
278 if (EQ (sym, QTIMESTAMP)) return dpyinfo->Xatom_TIMESTAMP;
279 if (EQ (sym, QTEXT)) return dpyinfo->Xatom_TEXT;
280 if (EQ (sym, QCOMPOUND_TEXT)) return dpyinfo->Xatom_COMPOUND_TEXT;
281 if (EQ (sym, QUTF8_STRING)) return dpyinfo->Xatom_UTF8_STRING;
282 if (EQ (sym, QDELETE)) return dpyinfo->Xatom_DELETE;
283 if (EQ (sym, QMULTIPLE)) return dpyinfo->Xatom_MULTIPLE;
284 if (EQ (sym, QINCR)) return dpyinfo->Xatom_INCR;
285 if (EQ (sym, QEMACS_TMP)) return dpyinfo->Xatom_EMACS_TMP;
286 if (EQ (sym, QTARGETS)) return dpyinfo->Xatom_TARGETS;
287 if (EQ (sym, QNULL)) return dpyinfo->Xatom_NULL;
288 #ifdef CUT_BUFFER_SUPPORT
289 if (EQ (sym, QCUT_BUFFER0)) return XA_CUT_BUFFER0;
290 if (EQ (sym, QCUT_BUFFER1)) return XA_CUT_BUFFER1;
291 if (EQ (sym, QCUT_BUFFER2)) return XA_CUT_BUFFER2;
292 if (EQ (sym, QCUT_BUFFER3)) return XA_CUT_BUFFER3;
293 if (EQ (sym, QCUT_BUFFER4)) return XA_CUT_BUFFER4;
294 if (EQ (sym, QCUT_BUFFER5)) return XA_CUT_BUFFER5;
295 if (EQ (sym, QCUT_BUFFER6)) return XA_CUT_BUFFER6;
296 if (EQ (sym, QCUT_BUFFER7)) return XA_CUT_BUFFER7;
297 #endif
298 if (!SYMBOLP (sym)) abort ();
299
300 TRACE1 (" XInternAtom %s", (char *) SDATA (SYMBOL_NAME (sym)));
301 BLOCK_INPUT;
302 val = XInternAtom (display, (char *) SDATA (SYMBOL_NAME (sym)), False);
303 UNBLOCK_INPUT;
304 return val;
305 }
306
307
308 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
309 and calls to intern whenever possible. */
310
311 static Lisp_Object
312 x_atom_to_symbol (dpy, atom)
313 Display *dpy;
314 Atom atom;
315 {
316 struct x_display_info *dpyinfo;
317 char *str;
318 Lisp_Object val;
319
320 if (! atom)
321 return Qnil;
322
323 switch (atom)
324 {
325 case XA_PRIMARY:
326 return QPRIMARY;
327 case XA_SECONDARY:
328 return QSECONDARY;
329 case XA_STRING:
330 return QSTRING;
331 case XA_INTEGER:
332 return QINTEGER;
333 case XA_ATOM:
334 return QATOM;
335 #ifdef CUT_BUFFER_SUPPORT
336 case XA_CUT_BUFFER0:
337 return QCUT_BUFFER0;
338 case XA_CUT_BUFFER1:
339 return QCUT_BUFFER1;
340 case XA_CUT_BUFFER2:
341 return QCUT_BUFFER2;
342 case XA_CUT_BUFFER3:
343 return QCUT_BUFFER3;
344 case XA_CUT_BUFFER4:
345 return QCUT_BUFFER4;
346 case XA_CUT_BUFFER5:
347 return QCUT_BUFFER5;
348 case XA_CUT_BUFFER6:
349 return QCUT_BUFFER6;
350 case XA_CUT_BUFFER7:
351 return QCUT_BUFFER7;
352 #endif
353 }
354
355 dpyinfo = x_display_info_for_display (dpy);
356 if (atom == dpyinfo->Xatom_CLIPBOARD)
357 return QCLIPBOARD;
358 if (atom == dpyinfo->Xatom_TIMESTAMP)
359 return QTIMESTAMP;
360 if (atom == dpyinfo->Xatom_TEXT)
361 return QTEXT;
362 if (atom == dpyinfo->Xatom_COMPOUND_TEXT)
363 return QCOMPOUND_TEXT;
364 if (atom == dpyinfo->Xatom_UTF8_STRING)
365 return QUTF8_STRING;
366 if (atom == dpyinfo->Xatom_DELETE)
367 return QDELETE;
368 if (atom == dpyinfo->Xatom_MULTIPLE)
369 return QMULTIPLE;
370 if (atom == dpyinfo->Xatom_INCR)
371 return QINCR;
372 if (atom == dpyinfo->Xatom_EMACS_TMP)
373 return QEMACS_TMP;
374 if (atom == dpyinfo->Xatom_TARGETS)
375 return QTARGETS;
376 if (atom == dpyinfo->Xatom_NULL)
377 return QNULL;
378
379 BLOCK_INPUT;
380 str = XGetAtomName (dpy, atom);
381 UNBLOCK_INPUT;
382 TRACE1 ("XGetAtomName --> %s", str);
383 if (! str) return Qnil;
384 val = intern (str);
385 BLOCK_INPUT;
386 /* This was allocated by Xlib, so use XFree. */
387 XFree (str);
388 UNBLOCK_INPUT;
389 return val;
390 }
391 \f
392 /* Do protocol to assert ourself as a selection owner.
393 Update the Vselection_alist so that we can reply to later requests for
394 our selection. */
395
396 static void
397 x_own_selection (selection_name, selection_value)
398 Lisp_Object selection_name, selection_value;
399 {
400 struct frame *sf = SELECTED_FRAME ();
401 Window selecting_window = FRAME_X_WINDOW (sf);
402 Display *display = FRAME_X_DISPLAY (sf);
403 Time time = last_event_timestamp;
404 Atom selection_atom;
405 struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (sf);
406
407 CHECK_SYMBOL (selection_name);
408 selection_atom = symbol_to_x_atom (dpyinfo, display, selection_name);
409
410 BLOCK_INPUT;
411 x_catch_errors (display);
412 XSetSelectionOwner (display, selection_atom, selecting_window, time);
413 x_check_errors (display, "Can't set selection: %s");
414 x_uncatch_errors ();
415 UNBLOCK_INPUT;
416
417 /* Now update the local cache */
418 {
419 Lisp_Object selection_time;
420 Lisp_Object selection_data;
421 Lisp_Object prev_value;
422
423 selection_time = long_to_cons ((unsigned long) time);
424 selection_data = Fcons (selection_name,
425 Fcons (selection_value,
426 Fcons (selection_time,
427 Fcons (selected_frame, Qnil))));
428 prev_value = assq_no_quit (selection_name, Vselection_alist);
429
430 Vselection_alist = Fcons (selection_data, Vselection_alist);
431
432 /* If we already owned the selection, remove the old selection data.
433 Perhaps we should destructively modify it instead.
434 Don't use Fdelq as that may QUIT. */
435 if (!NILP (prev_value))
436 {
437 Lisp_Object rest; /* we know it's not the CAR, so it's easy. */
438 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
439 if (EQ (prev_value, Fcar (XCDR (rest))))
440 {
441 XSETCDR (rest, Fcdr (XCDR (rest)));
442 break;
443 }
444 }
445 }
446 }
447 \f
448 /* Given a selection-name and desired type, look up our local copy of
449 the selection value and convert it to the type.
450 The value is nil or a string.
451 This function is used both for remote requests (LOCAL_REQUEST is zero)
452 and for local x-get-selection-internal (LOCAL_REQUEST is nonzero).
453
454 This calls random Lisp code, and may signal or gc. */
455
456 static Lisp_Object
457 x_get_local_selection (selection_symbol, target_type, local_request)
458 Lisp_Object selection_symbol, target_type;
459 int local_request;
460 {
461 Lisp_Object local_value;
462 Lisp_Object handler_fn, value, type, check;
463 int count;
464
465 local_value = assq_no_quit (selection_symbol, Vselection_alist);
466
467 if (NILP (local_value)) return Qnil;
468
469 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
470 if (EQ (target_type, QTIMESTAMP))
471 {
472 handler_fn = Qnil;
473 value = XCAR (XCDR (XCDR (local_value)));
474 }
475 #if 0
476 else if (EQ (target_type, QDELETE))
477 {
478 handler_fn = Qnil;
479 Fx_disown_selection_internal
480 (selection_symbol,
481 XCAR (XCDR (XCDR (local_value))));
482 value = QNULL;
483 }
484 #endif
485
486 #if 0 /* #### MULTIPLE doesn't work yet */
487 else if (CONSP (target_type)
488 && XCAR (target_type) == QMULTIPLE)
489 {
490 Lisp_Object pairs;
491 int size;
492 int i;
493 pairs = XCDR (target_type);
494 size = XVECTOR (pairs)->size;
495 /* If the target is MULTIPLE, then target_type looks like
496 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
497 We modify the second element of each pair in the vector and
498 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
499 */
500 for (i = 0; i < size; i++)
501 {
502 Lisp_Object pair;
503 pair = XVECTOR (pairs)->contents [i];
504 XVECTOR (pair)->contents [1]
505 = x_get_local_selection (XVECTOR (pair)->contents [0],
506 XVECTOR (pair)->contents [1],
507 local_request);
508 }
509 return pairs;
510 }
511 #endif
512 else
513 {
514 /* Don't allow a quit within the converter.
515 When the user types C-g, he would be surprised
516 if by luck it came during a converter. */
517 count = SPECPDL_INDEX ();
518 specbind (Qinhibit_quit, Qt);
519
520 CHECK_SYMBOL (target_type);
521 handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
522 /* gcpro is not needed here since nothing but HANDLER_FN
523 is live, and that ought to be a symbol. */
524
525 if (!NILP (handler_fn))
526 value = call3 (handler_fn,
527 selection_symbol, (local_request ? Qnil : target_type),
528 XCAR (XCDR (local_value)));
529 else
530 value = Qnil;
531 unbind_to (count, Qnil);
532 }
533
534 /* Make sure this value is of a type that we could transmit
535 to another X client. */
536
537 check = value;
538 if (CONSP (value)
539 && SYMBOLP (XCAR (value)))
540 type = XCAR (value),
541 check = XCDR (value);
542
543 if (STRINGP (check)
544 || VECTORP (check)
545 || SYMBOLP (check)
546 || INTEGERP (check)
547 || NILP (value))
548 return value;
549 /* Check for a value that cons_to_long could handle. */
550 else if (CONSP (check)
551 && INTEGERP (XCAR (check))
552 && (INTEGERP (XCDR (check))
553 ||
554 (CONSP (XCDR (check))
555 && INTEGERP (XCAR (XCDR (check)))
556 && NILP (XCDR (XCDR (check))))))
557 return value;
558 else
559 return
560 Fsignal (Qerror,
561 Fcons (build_string ("invalid data returned by selection-conversion function"),
562 Fcons (handler_fn, Fcons (value, Qnil))));
563 }
564 \f
565 /* Subroutines of x_reply_selection_request. */
566
567 /* Send a SelectionNotify event to the requestor with property=None,
568 meaning we were unable to do what they wanted. */
569
570 static void
571 x_decline_selection_request (event)
572 struct input_event *event;
573 {
574 XSelectionEvent reply;
575
576 reply.type = SelectionNotify;
577 reply.display = SELECTION_EVENT_DISPLAY (event);
578 reply.requestor = SELECTION_EVENT_REQUESTOR (event);
579 reply.selection = SELECTION_EVENT_SELECTION (event);
580 reply.time = SELECTION_EVENT_TIME (event);
581 reply.target = SELECTION_EVENT_TARGET (event);
582 reply.property = None;
583
584 /* The reason for the error may be that the receiver has
585 died in the meantime. Handle that case. */
586 BLOCK_INPUT;
587 x_catch_errors (reply.display);
588 XSendEvent (reply.display, reply.requestor, False, 0L, (XEvent *) &reply);
589 XFlush (reply.display);
590 x_uncatch_errors ();
591 UNBLOCK_INPUT;
592 }
593
594 /* This is the selection request currently being processed.
595 It is set to zero when the request is fully processed. */
596 static struct input_event *x_selection_current_request;
597
598 /* Display info in x_selection_request. */
599
600 static struct x_display_info *selection_request_dpyinfo;
601
602 /* Used as an unwind-protect clause so that, if a selection-converter signals
603 an error, we tell the requester that we were unable to do what they wanted
604 before we throw to top-level or go into the debugger or whatever. */
605
606 static Lisp_Object
607 x_selection_request_lisp_error (ignore)
608 Lisp_Object ignore;
609 {
610 if (x_selection_current_request != 0
611 && selection_request_dpyinfo->display)
612 x_decline_selection_request (x_selection_current_request);
613 return Qnil;
614 }
615
616 static Lisp_Object
617 x_catch_errors_unwind (dummy)
618 Lisp_Object dummy;
619 {
620 BLOCK_INPUT;
621 x_uncatch_errors ();
622 UNBLOCK_INPUT;
623 return Qnil;
624 }
625 \f
626
627 /* This stuff is so that INCR selections are reentrant (that is, so we can
628 be servicing multiple INCR selection requests simultaneously.) I haven't
629 actually tested that yet. */
630
631 /* Keep a list of the property changes that are awaited. */
632
633 struct prop_location
634 {
635 int identifier;
636 Display *display;
637 Window window;
638 Atom property;
639 int desired_state;
640 int arrived;
641 struct prop_location *next;
642 };
643
644 static struct prop_location *expect_property_change ();
645 static void wait_for_property_change ();
646 static void unexpect_property_change ();
647 static int waiting_for_other_props_on_window ();
648
649 static int prop_location_identifier;
650
651 static Lisp_Object property_change_reply;
652
653 static struct prop_location *property_change_reply_object;
654
655 static struct prop_location *property_change_wait_list;
656
657 static Lisp_Object
658 queue_selection_requests_unwind (tem)
659 Lisp_Object tem;
660 {
661 x_stop_queuing_selection_requests ();
662 return Qnil;
663 }
664
665 /* Return some frame whose display info is DPYINFO.
666 Return nil if there is none. */
667
668 static Lisp_Object
669 some_frame_on_display (dpyinfo)
670 struct x_display_info *dpyinfo;
671 {
672 Lisp_Object list, frame;
673
674 FOR_EACH_FRAME (list, frame)
675 {
676 if (FRAME_X_DISPLAY_INFO (XFRAME (frame)) == dpyinfo)
677 return frame;
678 }
679
680 return Qnil;
681 }
682 \f
683 /* Send the reply to a selection request event EVENT.
684 TYPE is the type of selection data requested.
685 DATA and SIZE describe the data to send, already converted.
686 FORMAT is the unit-size (in bits) of the data to be transmitted. */
687
688 static void
689 x_reply_selection_request (event, format, data, size, type)
690 struct input_event *event;
691 int format, size;
692 unsigned char *data;
693 Atom type;
694 {
695 XSelectionEvent reply;
696 Display *display = SELECTION_EVENT_DISPLAY (event);
697 Window window = SELECTION_EVENT_REQUESTOR (event);
698 int bytes_remaining;
699 int format_bytes = format/8;
700 int max_bytes = SELECTION_QUANTUM (display);
701 struct x_display_info *dpyinfo = x_display_info_for_display (display);
702 int count = SPECPDL_INDEX ();
703
704 if (max_bytes > MAX_SELECTION_QUANTUM)
705 max_bytes = MAX_SELECTION_QUANTUM;
706
707 reply.type = SelectionNotify;
708 reply.display = display;
709 reply.requestor = window;
710 reply.selection = SELECTION_EVENT_SELECTION (event);
711 reply.time = SELECTION_EVENT_TIME (event);
712 reply.target = SELECTION_EVENT_TARGET (event);
713 reply.property = SELECTION_EVENT_PROPERTY (event);
714 if (reply.property == None)
715 reply.property = reply.target;
716
717 BLOCK_INPUT;
718 /* The protected block contains wait_for_property_change, which can
719 run random lisp code (process handlers) or signal. Therefore, we
720 put the x_uncatch_errors call in an unwind. */
721 record_unwind_protect (x_catch_errors_unwind, Qnil);
722 x_catch_errors (display);
723
724 #ifdef TRACE_SELECTION
725 {
726 static int cnt;
727 char *sel = XGetAtomName (display, reply.selection);
728 char *tgt = XGetAtomName (display, reply.target);
729 TRACE3 ("%s, target %s (%d)", sel, tgt, ++cnt);
730 if (sel) XFree (sel);
731 if (tgt) XFree (tgt);
732 }
733 #endif /* TRACE_SELECTION */
734
735 /* Store the data on the requested property.
736 If the selection is large, only store the first N bytes of it.
737 */
738 bytes_remaining = size * format_bytes;
739 if (bytes_remaining <= max_bytes)
740 {
741 /* Send all the data at once, with minimal handshaking. */
742 TRACE1 ("Sending all %d bytes", bytes_remaining);
743 XChangeProperty (display, window, reply.property, type, format,
744 PropModeReplace, data, size);
745 /* At this point, the selection was successfully stored; ack it. */
746 XSendEvent (display, window, False, 0L, (XEvent *) &reply);
747 }
748 else
749 {
750 /* Send an INCR selection. */
751 struct prop_location *wait_object;
752 int had_errors;
753 Lisp_Object frame;
754
755 frame = some_frame_on_display (dpyinfo);
756
757 /* If the display no longer has frames, we can't expect
758 to get many more selection requests from it, so don't
759 bother trying to queue them. */
760 if (!NILP (frame))
761 {
762 x_start_queuing_selection_requests ();
763
764 record_unwind_protect (queue_selection_requests_unwind,
765 Qnil);
766 }
767
768 if (x_window_to_frame (dpyinfo, window)) /* #### debug */
769 error ("Attempt to transfer an INCR to ourself!");
770
771 TRACE2 ("Start sending %d bytes incrementally (%s)",
772 bytes_remaining, XGetAtomName (display, reply.property));
773 wait_object = expect_property_change (display, window, reply.property,
774 PropertyDelete);
775
776 TRACE1 ("Set %s to number of bytes to send",
777 XGetAtomName (display, reply.property));
778 {
779 /* XChangeProperty expects an array of long even if long is more than
780 32 bits. */
781 long value[1];
782
783 value[0] = bytes_remaining;
784 XChangeProperty (display, window, reply.property, dpyinfo->Xatom_INCR,
785 32, PropModeReplace,
786 (unsigned char *) value, 1);
787 }
788
789 XSelectInput (display, window, PropertyChangeMask);
790
791 /* Tell 'em the INCR data is there... */
792 TRACE0 ("Send SelectionNotify event");
793 XSendEvent (display, window, False, 0L, (XEvent *) &reply);
794 XFlush (display);
795
796 had_errors = x_had_errors_p (display);
797 UNBLOCK_INPUT;
798
799 /* First, wait for the requester to ack by deleting the property.
800 This can run random lisp code (process handlers) or signal. */
801 if (! had_errors)
802 {
803 TRACE1 ("Waiting for ACK (deletion of %s)",
804 XGetAtomName (display, reply.property));
805 wait_for_property_change (wait_object);
806 }
807 else
808 unexpect_property_change (wait_object);
809
810 TRACE0 ("Got ACK");
811 while (bytes_remaining)
812 {
813 int i = ((bytes_remaining < max_bytes)
814 ? bytes_remaining
815 : max_bytes);
816
817 BLOCK_INPUT;
818
819 wait_object
820 = expect_property_change (display, window, reply.property,
821 PropertyDelete);
822
823 TRACE1 ("Sending increment of %d bytes", i);
824 TRACE1 ("Set %s to increment data",
825 XGetAtomName (display, reply.property));
826
827 /* Append the next chunk of data to the property. */
828 XChangeProperty (display, window, reply.property, type, format,
829 PropModeAppend, data, i / format_bytes);
830 bytes_remaining -= i;
831 data += i;
832 XFlush (display);
833 had_errors = x_had_errors_p (display);
834 UNBLOCK_INPUT;
835
836 if (had_errors)
837 break;
838
839 /* Now wait for the requester to ack this chunk by deleting the
840 property. This can run random lisp code or signal. */
841 TRACE1 ("Waiting for increment ACK (deletion of %s)",
842 XGetAtomName (display, reply.property));
843 wait_for_property_change (wait_object);
844 }
845
846 /* Now write a zero-length chunk to the property to tell the
847 requester that we're done. */
848 BLOCK_INPUT;
849 if (! waiting_for_other_props_on_window (display, window))
850 XSelectInput (display, window, 0L);
851
852 TRACE1 ("Set %s to a 0-length chunk to indicate EOF",
853 XGetAtomName (display, reply.property));
854 XChangeProperty (display, window, reply.property, type, format,
855 PropModeReplace, data, 0);
856 TRACE0 ("Done sending incrementally");
857 }
858
859 /* rms, 2003-01-03: I think I have fixed this bug. */
860 /* The window we're communicating with may have been deleted
861 in the meantime (that's a real situation from a bug report).
862 In this case, there may be events in the event queue still
863 refering to the deleted window, and we'll get a BadWindow error
864 in XTread_socket when processing the events. I don't have
865 an idea how to fix that. gerd, 2001-01-98. */
866 /* 2004-09-10: XSync and UNBLOCK so that possible protocol errors are
867 delivered before uncatch errors. */
868 XSync (display, False);
869 UNBLOCK_INPUT;
870
871 /* GTK queues events in addition to the queue in Xlib. So we
872 UNBLOCK to enter the event loop and get possible errors delivered,
873 and then BLOCK again because x_uncatch_errors requires it. */
874 BLOCK_INPUT;
875 /* This calls x_uncatch_errors. */
876 unbind_to (count, Qnil);
877 UNBLOCK_INPUT;
878 }
879 \f
880 /* Handle a SelectionRequest event EVENT.
881 This is called from keyboard.c when such an event is found in the queue. */
882
883 static void
884 x_handle_selection_request (event)
885 struct input_event *event;
886 {
887 struct gcpro gcpro1, gcpro2, gcpro3;
888 Lisp_Object local_selection_data;
889 Lisp_Object selection_symbol;
890 Lisp_Object target_symbol;
891 Lisp_Object converted_selection;
892 Time local_selection_time;
893 Lisp_Object successful_p;
894 int count;
895 struct x_display_info *dpyinfo
896 = x_display_info_for_display (SELECTION_EVENT_DISPLAY (event));
897
898 TRACE2 ("x_handle_selection_request, from=0x%08lx time=%lu",
899 (unsigned long) SELECTION_EVENT_REQUESTOR (event),
900 (unsigned long) SELECTION_EVENT_TIME (event));
901
902 local_selection_data = Qnil;
903 target_symbol = Qnil;
904 converted_selection = Qnil;
905 successful_p = Qnil;
906
907 GCPRO3 (local_selection_data, converted_selection, target_symbol);
908
909 selection_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
910 SELECTION_EVENT_SELECTION (event));
911
912 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
913
914 if (NILP (local_selection_data))
915 {
916 /* Someone asked for the selection, but we don't have it any more.
917 */
918 x_decline_selection_request (event);
919 goto DONE;
920 }
921
922 local_selection_time = (Time)
923 cons_to_long (XCAR (XCDR (XCDR (local_selection_data))));
924
925 if (SELECTION_EVENT_TIME (event) != CurrentTime
926 && local_selection_time > SELECTION_EVENT_TIME (event))
927 {
928 /* Someone asked for the selection, and we have one, but not the one
929 they're looking for.
930 */
931 x_decline_selection_request (event);
932 goto DONE;
933 }
934
935 x_selection_current_request = event;
936 count = SPECPDL_INDEX ();
937 selection_request_dpyinfo = dpyinfo;
938 record_unwind_protect (x_selection_request_lisp_error, Qnil);
939
940 target_symbol = x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event),
941 SELECTION_EVENT_TARGET (event));
942
943 #if 0 /* #### MULTIPLE doesn't work yet */
944 if (EQ (target_symbol, QMULTIPLE))
945 target_symbol = fetch_multiple_target (event);
946 #endif
947
948 /* Convert lisp objects back into binary data */
949
950 converted_selection
951 = x_get_local_selection (selection_symbol, target_symbol, 0);
952
953 if (! NILP (converted_selection))
954 {
955 unsigned char *data;
956 unsigned int size;
957 int format;
958 Atom type;
959 int nofree;
960
961 lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event),
962 converted_selection,
963 &data, &type, &size, &format, &nofree);
964
965 x_reply_selection_request (event, format, data, size, type);
966 successful_p = Qt;
967
968 /* Indicate we have successfully processed this event. */
969 x_selection_current_request = 0;
970
971 /* Use xfree, not XFree, because lisp_data_to_selection_data
972 calls xmalloc itself. */
973 if (!nofree)
974 xfree (data);
975 }
976 unbind_to (count, Qnil);
977
978 DONE:
979
980 /* Let random lisp code notice that the selection has been asked for. */
981 {
982 Lisp_Object rest;
983 rest = Vx_sent_selection_functions;
984 if (!EQ (rest, Qunbound))
985 for (; CONSP (rest); rest = Fcdr (rest))
986 call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
987 }
988
989 UNGCPRO;
990 }
991 \f
992 /* Handle a SelectionClear event EVENT, which indicates that some
993 client cleared out our previously asserted selection.
994 This is called from keyboard.c when such an event is found in the queue. */
995
996 static void
997 x_handle_selection_clear (event)
998 struct input_event *event;
999 {
1000 Display *display = SELECTION_EVENT_DISPLAY (event);
1001 Atom selection = SELECTION_EVENT_SELECTION (event);
1002 Time changed_owner_time = SELECTION_EVENT_TIME (event);
1003
1004 Lisp_Object selection_symbol, local_selection_data;
1005 Time local_selection_time;
1006 struct x_display_info *dpyinfo = x_display_info_for_display (display);
1007 struct x_display_info *t_dpyinfo;
1008
1009 TRACE0 ("x_handle_selection_clear");
1010
1011 /* If the new selection owner is also Emacs,
1012 don't clear the new selection. */
1013 BLOCK_INPUT;
1014 /* Check each display on the same terminal,
1015 to see if this Emacs job now owns the selection
1016 through that display. */
1017 for (t_dpyinfo = x_display_list; t_dpyinfo; t_dpyinfo = t_dpyinfo->next)
1018 if (t_dpyinfo->kboard == dpyinfo->kboard)
1019 {
1020 Window owner_window
1021 = XGetSelectionOwner (t_dpyinfo->display, selection);
1022 if (x_window_to_frame (t_dpyinfo, owner_window) != 0)
1023 {
1024 UNBLOCK_INPUT;
1025 return;
1026 }
1027 }
1028 UNBLOCK_INPUT;
1029
1030 selection_symbol = x_atom_to_symbol (display, selection);
1031
1032 local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
1033
1034 /* Well, we already believe that we don't own it, so that's just fine. */
1035 if (NILP (local_selection_data)) return;
1036
1037 local_selection_time = (Time)
1038 cons_to_long (XCAR (XCDR (XCDR (local_selection_data))));
1039
1040 /* This SelectionClear is for a selection that we no longer own, so we can
1041 disregard it. (That is, we have reasserted the selection since this
1042 request was generated.) */
1043
1044 if (changed_owner_time != CurrentTime
1045 && local_selection_time > changed_owner_time)
1046 return;
1047
1048 /* Otherwise, we're really honest and truly being told to drop it.
1049 Don't use Fdelq as that may QUIT;. */
1050
1051 if (EQ (local_selection_data, Fcar (Vselection_alist)))
1052 Vselection_alist = Fcdr (Vselection_alist);
1053 else
1054 {
1055 Lisp_Object rest;
1056 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
1057 if (EQ (local_selection_data, Fcar (XCDR (rest))))
1058 {
1059 XSETCDR (rest, Fcdr (XCDR (rest)));
1060 break;
1061 }
1062 }
1063
1064 /* Let random lisp code notice that the selection has been stolen. */
1065
1066 {
1067 Lisp_Object rest;
1068 rest = Vx_lost_selection_functions;
1069 if (!EQ (rest, Qunbound))
1070 {
1071 for (; CONSP (rest); rest = Fcdr (rest))
1072 call1 (Fcar (rest), selection_symbol);
1073 prepare_menu_bars ();
1074 redisplay_preserve_echo_area (20);
1075 }
1076 }
1077 }
1078
1079 void
1080 x_handle_selection_event (event)
1081 struct input_event *event;
1082 {
1083 TRACE0 ("x_handle_selection_event");
1084
1085 if (event->kind == SELECTION_REQUEST_EVENT)
1086 {
1087 if (x_queue_selection_requests)
1088 x_queue_event (event);
1089 else
1090 x_handle_selection_request (event);
1091 }
1092 else
1093 x_handle_selection_clear (event);
1094 }
1095
1096
1097 /* Clear all selections that were made from frame F.
1098 We do this when about to delete a frame. */
1099
1100 void
1101 x_clear_frame_selections (f)
1102 FRAME_PTR f;
1103 {
1104 Lisp_Object frame;
1105 Lisp_Object rest;
1106
1107 XSETFRAME (frame, f);
1108
1109 /* Otherwise, we're really honest and truly being told to drop it.
1110 Don't use Fdelq as that may QUIT;. */
1111
1112 /* Delete elements from the beginning of Vselection_alist. */
1113 while (!NILP (Vselection_alist)
1114 && EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (Vselection_alist)))))))
1115 {
1116 /* Let random Lisp code notice that the selection has been stolen. */
1117 Lisp_Object hooks, selection_symbol;
1118
1119 hooks = Vx_lost_selection_functions;
1120 selection_symbol = Fcar (Fcar (Vselection_alist));
1121
1122 if (!EQ (hooks, Qunbound))
1123 {
1124 for (; CONSP (hooks); hooks = Fcdr (hooks))
1125 call1 (Fcar (hooks), selection_symbol);
1126 #if 0 /* This can crash when deleting a frame
1127 from x_connection_closed. Anyway, it seems unnecessary;
1128 something else should cause a redisplay. */
1129 redisplay_preserve_echo_area (21);
1130 #endif
1131 }
1132
1133 Vselection_alist = Fcdr (Vselection_alist);
1134 }
1135
1136 /* Delete elements after the beginning of Vselection_alist. */
1137 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
1138 if (EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (XCDR (rest))))))))
1139 {
1140 /* Let random Lisp code notice that the selection has been stolen. */
1141 Lisp_Object hooks, selection_symbol;
1142
1143 hooks = Vx_lost_selection_functions;
1144 selection_symbol = Fcar (Fcar (XCDR (rest)));
1145
1146 if (!EQ (hooks, Qunbound))
1147 {
1148 for (; CONSP (hooks); hooks = Fcdr (hooks))
1149 call1 (Fcar (hooks), selection_symbol);
1150 #if 0 /* See above */
1151 redisplay_preserve_echo_area (22);
1152 #endif
1153 }
1154 XSETCDR (rest, Fcdr (XCDR (rest)));
1155 break;
1156 }
1157 }
1158 \f
1159 /* Nonzero if any properties for DISPLAY and WINDOW
1160 are on the list of what we are waiting for. */
1161
1162 static int
1163 waiting_for_other_props_on_window (display, window)
1164 Display *display;
1165 Window window;
1166 {
1167 struct prop_location *rest = property_change_wait_list;
1168 while (rest)
1169 if (rest->display == display && rest->window == window)
1170 return 1;
1171 else
1172 rest = rest->next;
1173 return 0;
1174 }
1175
1176 /* Add an entry to the list of property changes we are waiting for.
1177 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
1178 The return value is a number that uniquely identifies
1179 this awaited property change. */
1180
1181 static struct prop_location *
1182 expect_property_change (display, window, property, state)
1183 Display *display;
1184 Window window;
1185 Atom property;
1186 int state;
1187 {
1188 struct prop_location *pl = (struct prop_location *) xmalloc (sizeof *pl);
1189 pl->identifier = ++prop_location_identifier;
1190 pl->display = display;
1191 pl->window = window;
1192 pl->property = property;
1193 pl->desired_state = state;
1194 pl->next = property_change_wait_list;
1195 pl->arrived = 0;
1196 property_change_wait_list = pl;
1197 return pl;
1198 }
1199
1200 /* Delete an entry from the list of property changes we are waiting for.
1201 IDENTIFIER is the number that uniquely identifies the entry. */
1202
1203 static void
1204 unexpect_property_change (location)
1205 struct prop_location *location;
1206 {
1207 struct prop_location *prev = 0, *rest = property_change_wait_list;
1208 while (rest)
1209 {
1210 if (rest == location)
1211 {
1212 if (prev)
1213 prev->next = rest->next;
1214 else
1215 property_change_wait_list = rest->next;
1216 xfree (rest);
1217 return;
1218 }
1219 prev = rest;
1220 rest = rest->next;
1221 }
1222 }
1223
1224 /* Remove the property change expectation element for IDENTIFIER. */
1225
1226 static Lisp_Object
1227 wait_for_property_change_unwind (loc)
1228 Lisp_Object loc;
1229 {
1230 struct prop_location *location = XSAVE_VALUE (loc)->pointer;
1231
1232 unexpect_property_change (location);
1233 if (location == property_change_reply_object)
1234 property_change_reply_object = 0;
1235 return Qnil;
1236 }
1237
1238 /* Actually wait for a property change.
1239 IDENTIFIER should be the value that expect_property_change returned. */
1240
1241 static void
1242 wait_for_property_change (location)
1243 struct prop_location *location;
1244 {
1245 int secs, usecs;
1246 int count = SPECPDL_INDEX ();
1247
1248 if (property_change_reply_object)
1249 abort ();
1250
1251 /* Make sure to do unexpect_property_change if we quit or err. */
1252 record_unwind_protect (wait_for_property_change_unwind,
1253 make_save_value (location, 0));
1254
1255 XSETCAR (property_change_reply, Qnil);
1256 property_change_reply_object = location;
1257
1258 /* If the event we are waiting for arrives beyond here, it will set
1259 property_change_reply, because property_change_reply_object says so. */
1260 if (! location->arrived)
1261 {
1262 secs = x_selection_timeout / 1000;
1263 usecs = (x_selection_timeout % 1000) * 1000;
1264 TRACE2 (" Waiting %d secs, %d usecs", secs, usecs);
1265 wait_reading_process_output (secs, usecs, 0, 0,
1266 property_change_reply, NULL, 0);
1267
1268 if (NILP (XCAR (property_change_reply)))
1269 {
1270 TRACE0 (" Timed out");
1271 error ("Timed out waiting for property-notify event");
1272 }
1273 }
1274
1275 unbind_to (count, Qnil);
1276 }
1277
1278 /* Called from XTread_socket in response to a PropertyNotify event. */
1279
1280 void
1281 x_handle_property_notify (event)
1282 XPropertyEvent *event;
1283 {
1284 struct prop_location *prev = 0, *rest = property_change_wait_list;
1285
1286 while (rest)
1287 {
1288 if (!rest->arrived
1289 && rest->property == event->atom
1290 && rest->window == event->window
1291 && rest->display == event->display
1292 && rest->desired_state == event->state)
1293 {
1294 TRACE2 ("Expected %s of property %s",
1295 (event->state == PropertyDelete ? "deletion" : "change"),
1296 XGetAtomName (event->display, event->atom));
1297
1298 rest->arrived = 1;
1299
1300 /* If this is the one wait_for_property_change is waiting for,
1301 tell it to wake up. */
1302 if (rest == property_change_reply_object)
1303 XSETCAR (property_change_reply, Qt);
1304
1305 return;
1306 }
1307
1308 prev = rest;
1309 rest = rest->next;
1310 }
1311 }
1312
1313
1314 \f
1315 #if 0 /* #### MULTIPLE doesn't work yet */
1316
1317 static Lisp_Object
1318 fetch_multiple_target (event)
1319 XSelectionRequestEvent *event;
1320 {
1321 Display *display = event->display;
1322 Window window = event->requestor;
1323 Atom target = event->target;
1324 Atom selection_atom = event->selection;
1325 int result;
1326
1327 return
1328 Fcons (QMULTIPLE,
1329 x_get_window_property_as_lisp_data (display, window, target,
1330 QMULTIPLE, selection_atom));
1331 }
1332
1333 static Lisp_Object
1334 copy_multiple_data (obj)
1335 Lisp_Object obj;
1336 {
1337 Lisp_Object vec;
1338 int i;
1339 int size;
1340 if (CONSP (obj))
1341 return Fcons (XCAR (obj), copy_multiple_data (XCDR (obj)));
1342
1343 CHECK_VECTOR (obj);
1344 vec = Fmake_vector (size = XVECTOR (obj)->size, Qnil);
1345 for (i = 0; i < size; i++)
1346 {
1347 Lisp_Object vec2 = XVECTOR (obj)->contents [i];
1348 CHECK_VECTOR (vec2);
1349 if (XVECTOR (vec2)->size != 2)
1350 /* ??? Confusing error message */
1351 Fsignal (Qerror, Fcons (build_string ("vectors must be of length 2"),
1352 Fcons (vec2, Qnil)));
1353 XVECTOR (vec)->contents [i] = Fmake_vector (2, Qnil);
1354 XVECTOR (XVECTOR (vec)->contents [i])->contents [0]
1355 = XVECTOR (vec2)->contents [0];
1356 XVECTOR (XVECTOR (vec)->contents [i])->contents [1]
1357 = XVECTOR (vec2)->contents [1];
1358 }
1359 return vec;
1360 }
1361
1362 #endif
1363
1364 \f
1365 /* Variables for communication with x_handle_selection_notify. */
1366 static Atom reading_which_selection;
1367 static Lisp_Object reading_selection_reply;
1368 static Window reading_selection_window;
1369
1370 /* Do protocol to read selection-data from the server.
1371 Converts this to Lisp data and returns it. */
1372
1373 static Lisp_Object
1374 x_get_foreign_selection (selection_symbol, target_type, time_stamp)
1375 Lisp_Object selection_symbol, target_type, time_stamp;
1376 {
1377 struct frame *sf = SELECTED_FRAME ();
1378 Window requestor_window = FRAME_X_WINDOW (sf);
1379 Display *display = FRAME_X_DISPLAY (sf);
1380 struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (sf);
1381 Time requestor_time = last_event_timestamp;
1382 Atom target_property = dpyinfo->Xatom_EMACS_TMP;
1383 Atom selection_atom = symbol_to_x_atom (dpyinfo, display, selection_symbol);
1384 Atom type_atom;
1385 int secs, usecs;
1386 int count = SPECPDL_INDEX ();
1387 Lisp_Object frame;
1388
1389 if (CONSP (target_type))
1390 type_atom = symbol_to_x_atom (dpyinfo, display, XCAR (target_type));
1391 else
1392 type_atom = symbol_to_x_atom (dpyinfo, display, target_type);
1393
1394 if (! NILP (time_stamp))
1395 {
1396 if (CONSP (time_stamp))
1397 requestor_time = (Time) cons_to_long (time_stamp);
1398 else if (INTEGERP (time_stamp))
1399 requestor_time = (Time) XUINT (time_stamp);
1400 else if (FLOATP (time_stamp))
1401 requestor_time = (Time) XFLOAT_DATA (time_stamp);
1402 else
1403 error ("TIME_STAMP must be cons or number");
1404 }
1405
1406 BLOCK_INPUT;
1407
1408 /* The protected block contains wait_reading_process_output, which
1409 can run random lisp code (process handlers) or signal.
1410 Therefore, we put the x_uncatch_errors call in an unwind. */
1411 record_unwind_protect (x_catch_errors_unwind, Qnil);
1412 x_catch_errors (display);
1413
1414 TRACE2 ("Get selection %s, type %s",
1415 XGetAtomName (display, type_atom),
1416 XGetAtomName (display, target_property));
1417
1418 XConvertSelection (display, selection_atom, type_atom, target_property,
1419 requestor_window, requestor_time);
1420 XFlush (display);
1421
1422 /* Prepare to block until the reply has been read. */
1423 reading_selection_window = requestor_window;
1424 reading_which_selection = selection_atom;
1425 XSETCAR (reading_selection_reply, Qnil);
1426
1427 frame = some_frame_on_display (dpyinfo);
1428
1429 /* If the display no longer has frames, we can't expect
1430 to get many more selection requests from it, so don't
1431 bother trying to queue them. */
1432 if (!NILP (frame))
1433 {
1434 x_start_queuing_selection_requests ();
1435
1436 record_unwind_protect (queue_selection_requests_unwind,
1437 Qnil);
1438 }
1439 UNBLOCK_INPUT;
1440
1441 /* This allows quits. Also, don't wait forever. */
1442 secs = x_selection_timeout / 1000;
1443 usecs = (x_selection_timeout % 1000) * 1000;
1444 TRACE1 (" Start waiting %d secs for SelectionNotify", secs);
1445 wait_reading_process_output (secs, usecs, 0, 0,
1446 reading_selection_reply, NULL, 0);
1447 TRACE1 (" Got event = %d", !NILP (XCAR (reading_selection_reply)));
1448
1449 BLOCK_INPUT;
1450 if (x_had_errors_p (display))
1451 error ("Cannot get selection");
1452 /* This calls x_uncatch_errors. */
1453 unbind_to (count, Qnil);
1454 UNBLOCK_INPUT;
1455
1456 if (NILP (XCAR (reading_selection_reply)))
1457 error ("Timed out waiting for reply from selection owner");
1458 if (EQ (XCAR (reading_selection_reply), Qlambda))
1459 error ("No `%s' selection", SDATA (SYMBOL_NAME (selection_symbol)));
1460
1461 /* Otherwise, the selection is waiting for us on the requested property. */
1462 return
1463 x_get_window_property_as_lisp_data (display, requestor_window,
1464 target_property, target_type,
1465 selection_atom);
1466 }
1467 \f
1468 /* Subroutines of x_get_window_property_as_lisp_data */
1469
1470 /* Use xfree, not XFree, to free the data obtained with this function. */
1471
1472 static void
1473 x_get_window_property (display, window, property, data_ret, bytes_ret,
1474 actual_type_ret, actual_format_ret, actual_size_ret,
1475 delete_p)
1476 Display *display;
1477 Window window;
1478 Atom property;
1479 unsigned char **data_ret;
1480 int *bytes_ret;
1481 Atom *actual_type_ret;
1482 int *actual_format_ret;
1483 unsigned long *actual_size_ret;
1484 int delete_p;
1485 {
1486 int total_size;
1487 unsigned long bytes_remaining;
1488 int offset = 0;
1489 unsigned char *tmp_data = 0;
1490 int result;
1491 int buffer_size = SELECTION_QUANTUM (display);
1492
1493 if (buffer_size > MAX_SELECTION_QUANTUM)
1494 buffer_size = MAX_SELECTION_QUANTUM;
1495
1496 BLOCK_INPUT;
1497
1498 /* First probe the thing to find out how big it is. */
1499 result = XGetWindowProperty (display, window, property,
1500 0L, 0L, False, AnyPropertyType,
1501 actual_type_ret, actual_format_ret,
1502 actual_size_ret,
1503 &bytes_remaining, &tmp_data);
1504 if (result != Success)
1505 {
1506 UNBLOCK_INPUT;
1507 *data_ret = 0;
1508 *bytes_ret = 0;
1509 return;
1510 }
1511
1512 /* This was allocated by Xlib, so use XFree. */
1513 XFree ((char *) tmp_data);
1514
1515 if (*actual_type_ret == None || *actual_format_ret == 0)
1516 {
1517 UNBLOCK_INPUT;
1518 return;
1519 }
1520
1521 total_size = bytes_remaining + 1;
1522 *data_ret = (unsigned char *) xmalloc (total_size);
1523
1524 /* Now read, until we've gotten it all. */
1525 while (bytes_remaining)
1526 {
1527 #ifdef TRACE_SELECTION
1528 int last = bytes_remaining;
1529 #endif
1530 result
1531 = XGetWindowProperty (display, window, property,
1532 (long)offset/4, (long)buffer_size/4,
1533 False,
1534 AnyPropertyType,
1535 actual_type_ret, actual_format_ret,
1536 actual_size_ret, &bytes_remaining, &tmp_data);
1537
1538 TRACE2 ("Read %ld bytes from property %s",
1539 last - bytes_remaining,
1540 XGetAtomName (display, property));
1541
1542 /* If this doesn't return Success at this point, it means that
1543 some clod deleted the selection while we were in the midst of
1544 reading it. Deal with that, I guess.... */
1545 if (result != Success)
1546 break;
1547
1548 /* The man page for XGetWindowProperty says:
1549 "If the returned format is 32, the returned data is represented
1550 as a long array and should be cast to that type to obtain the
1551 elements."
1552 This applies even if long is more than 32 bits, the X library
1553 converts from 32 bit elements received from the X server to long
1554 and passes the long array to us. Thus, for that case bcopy can not
1555 be used. We convert to a 32 bit type here, because so much code
1556 assume on that.
1557
1558 The bytes and offsets passed to XGetWindowProperty refers to the
1559 property and those are indeed in 32 bit quantities if format is 32. */
1560
1561 if (*actual_format_ret == 32 && *actual_format_ret < BITS_PER_LONG)
1562 {
1563 unsigned long i;
1564 int *idata = (int *) ((*data_ret) + offset);
1565 long *ldata = (long *) tmp_data;
1566
1567 for (i = 0; i < *actual_size_ret; ++i)
1568 {
1569 idata[i]= (int) ldata[i];
1570 offset += 4;
1571 }
1572 }
1573 else
1574 {
1575 *actual_size_ret *= *actual_format_ret / 8;
1576 bcopy (tmp_data, (*data_ret) + offset, *actual_size_ret);
1577 offset += *actual_size_ret;
1578 }
1579
1580 /* This was allocated by Xlib, so use XFree. */
1581 XFree ((char *) tmp_data);
1582 }
1583
1584 XFlush (display);
1585 UNBLOCK_INPUT;
1586 *bytes_ret = offset;
1587 }
1588 \f
1589 /* Use xfree, not XFree, to free the data obtained with this function. */
1590
1591 static void
1592 receive_incremental_selection (display, window, property, target_type,
1593 min_size_bytes, data_ret, size_bytes_ret,
1594 type_ret, format_ret, size_ret)
1595 Display *display;
1596 Window window;
1597 Atom property;
1598 Lisp_Object target_type; /* for error messages only */
1599 unsigned int min_size_bytes;
1600 unsigned char **data_ret;
1601 int *size_bytes_ret;
1602 Atom *type_ret;
1603 unsigned long *size_ret;
1604 int *format_ret;
1605 {
1606 int offset = 0;
1607 struct prop_location *wait_object;
1608 *size_bytes_ret = min_size_bytes;
1609 *data_ret = (unsigned char *) xmalloc (*size_bytes_ret);
1610
1611 TRACE1 ("Read %d bytes incrementally", min_size_bytes);
1612
1613 /* At this point, we have read an INCR property.
1614 Delete the property to ack it.
1615 (But first, prepare to receive the next event in this handshake.)
1616
1617 Now, we must loop, waiting for the sending window to put a value on
1618 that property, then reading the property, then deleting it to ack.
1619 We are done when the sender places a property of length 0.
1620 */
1621 BLOCK_INPUT;
1622 XSelectInput (display, window, STANDARD_EVENT_SET | PropertyChangeMask);
1623 TRACE1 (" Delete property %s",
1624 SDATA (SYMBOL_NAME (x_atom_to_symbol (display, property))));
1625 XDeleteProperty (display, window, property);
1626 TRACE1 (" Expect new value of property %s",
1627 SDATA (SYMBOL_NAME (x_atom_to_symbol (display, property))));
1628 wait_object = expect_property_change (display, window, property,
1629 PropertyNewValue);
1630 XFlush (display);
1631 UNBLOCK_INPUT;
1632
1633 while (1)
1634 {
1635 unsigned char *tmp_data;
1636 int tmp_size_bytes;
1637
1638 TRACE0 (" Wait for property change");
1639 wait_for_property_change (wait_object);
1640
1641 /* expect it again immediately, because x_get_window_property may
1642 .. no it won't, I don't get it.
1643 .. Ok, I get it now, the Xt code that implements INCR is broken. */
1644 TRACE0 (" Get property value");
1645 x_get_window_property (display, window, property,
1646 &tmp_data, &tmp_size_bytes,
1647 type_ret, format_ret, size_ret, 1);
1648
1649 TRACE1 (" Read increment of %d bytes", tmp_size_bytes);
1650
1651 if (tmp_size_bytes == 0) /* we're done */
1652 {
1653 TRACE0 ("Done reading incrementally");
1654
1655 if (! waiting_for_other_props_on_window (display, window))
1656 XSelectInput (display, window, STANDARD_EVENT_SET);
1657 /* Use xfree, not XFree, because x_get_window_property
1658 calls xmalloc itself. */
1659 if (tmp_data) xfree (tmp_data);
1660 break;
1661 }
1662
1663 BLOCK_INPUT;
1664 TRACE1 (" ACK by deleting property %s",
1665 XGetAtomName (display, property));
1666 XDeleteProperty (display, window, property);
1667 wait_object = expect_property_change (display, window, property,
1668 PropertyNewValue);
1669 XFlush (display);
1670 UNBLOCK_INPUT;
1671
1672 if (*size_bytes_ret < offset + tmp_size_bytes)
1673 {
1674 *size_bytes_ret = offset + tmp_size_bytes;
1675 *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret);
1676 }
1677
1678 bcopy (tmp_data, (*data_ret) + offset, tmp_size_bytes);
1679 offset += tmp_size_bytes;
1680
1681 /* Use xfree, not XFree, because x_get_window_property
1682 calls xmalloc itself. */
1683 xfree (tmp_data);
1684 }
1685 }
1686
1687 \f
1688 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1689 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1690 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1691
1692 static Lisp_Object
1693 x_get_window_property_as_lisp_data (display, window, property, target_type,
1694 selection_atom)
1695 Display *display;
1696 Window window;
1697 Atom property;
1698 Lisp_Object target_type; /* for error messages only */
1699 Atom selection_atom; /* for error messages only */
1700 {
1701 Atom actual_type;
1702 int actual_format;
1703 unsigned long actual_size;
1704 unsigned char *data = 0;
1705 int bytes = 0;
1706 Lisp_Object val;
1707 struct x_display_info *dpyinfo = x_display_info_for_display (display);
1708
1709 TRACE0 ("Reading selection data");
1710
1711 x_get_window_property (display, window, property, &data, &bytes,
1712 &actual_type, &actual_format, &actual_size, 1);
1713 if (! data)
1714 {
1715 int there_is_a_selection_owner;
1716 BLOCK_INPUT;
1717 there_is_a_selection_owner
1718 = XGetSelectionOwner (display, selection_atom);
1719 UNBLOCK_INPUT;
1720 Fsignal (Qerror,
1721 there_is_a_selection_owner
1722 ? Fcons (build_string ("selection owner couldn't convert"),
1723 actual_type
1724 ? Fcons (target_type,
1725 Fcons (x_atom_to_symbol (display,
1726 actual_type),
1727 Qnil))
1728 : Fcons (target_type, Qnil))
1729 : Fcons (build_string ("no selection"),
1730 Fcons (x_atom_to_symbol (display,
1731 selection_atom),
1732 Qnil)));
1733 }
1734
1735 if (actual_type == dpyinfo->Xatom_INCR)
1736 {
1737 /* That wasn't really the data, just the beginning. */
1738
1739 unsigned int min_size_bytes = * ((unsigned int *) data);
1740 BLOCK_INPUT;
1741 /* Use xfree, not XFree, because x_get_window_property
1742 calls xmalloc itself. */
1743 xfree ((char *) data);
1744 UNBLOCK_INPUT;
1745 receive_incremental_selection (display, window, property, target_type,
1746 min_size_bytes, &data, &bytes,
1747 &actual_type, &actual_format,
1748 &actual_size);
1749 }
1750
1751 BLOCK_INPUT;
1752 TRACE1 (" Delete property %s", XGetAtomName (display, property));
1753 XDeleteProperty (display, window, property);
1754 XFlush (display);
1755 UNBLOCK_INPUT;
1756
1757 /* It's been read. Now convert it to a lisp object in some semi-rational
1758 manner. */
1759 val = selection_data_to_lisp_data (display, data, bytes,
1760 actual_type, actual_format);
1761
1762 /* Use xfree, not XFree, because x_get_window_property
1763 calls xmalloc itself. */
1764 xfree ((char *) data);
1765 return val;
1766 }
1767 \f
1768 /* These functions convert from the selection data read from the server into
1769 something that we can use from Lisp, and vice versa.
1770
1771 Type: Format: Size: Lisp Type:
1772 ----- ------- ----- -----------
1773 * 8 * String
1774 ATOM 32 1 Symbol
1775 ATOM 32 > 1 Vector of Symbols
1776 * 16 1 Integer
1777 * 16 > 1 Vector of Integers
1778 * 32 1 if <=16 bits: Integer
1779 if > 16 bits: Cons of top16, bot16
1780 * 32 > 1 Vector of the above
1781
1782 When converting a Lisp number to C, it is assumed to be of format 16 if
1783 it is an integer, and of format 32 if it is a cons of two integers.
1784
1785 When converting a vector of numbers from Lisp to C, it is assumed to be
1786 of format 16 if every element in the vector is an integer, and is assumed
1787 to be of format 32 if any element is a cons of two integers.
1788
1789 When converting an object to C, it may be of the form (SYMBOL . <data>)
1790 where SYMBOL is what we should claim that the type is. Format and
1791 representation are as above.
1792
1793 Important: When format is 32, data should contain an array of int,
1794 not an array of long as the X library returns. This makes a difference
1795 when sizeof(long) != sizeof(int). */
1796
1797
1798
1799 static Lisp_Object
1800 selection_data_to_lisp_data (display, data, size, type, format)
1801 Display *display;
1802 unsigned char *data;
1803 Atom type;
1804 int size, format;
1805 {
1806 struct x_display_info *dpyinfo = x_display_info_for_display (display);
1807
1808 if (type == dpyinfo->Xatom_NULL)
1809 return QNULL;
1810
1811 /* Convert any 8-bit data to a string, for compactness. */
1812 else if (format == 8)
1813 {
1814 Lisp_Object str, lispy_type;
1815
1816 str = make_unibyte_string ((char *) data, size);
1817 /* Indicate that this string is from foreign selection by a text
1818 property `foreign-selection' so that the caller of
1819 x-get-selection-internal (usually x-get-selection) can know
1820 that the string must be decode. */
1821 if (type == dpyinfo->Xatom_COMPOUND_TEXT)
1822 lispy_type = QCOMPOUND_TEXT;
1823 else if (type == dpyinfo->Xatom_UTF8_STRING)
1824 lispy_type = QUTF8_STRING;
1825 else
1826 lispy_type = QSTRING;
1827 Fput_text_property (make_number (0), make_number (size),
1828 Qforeign_selection, lispy_type, str);
1829 return str;
1830 }
1831 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1832 a vector of symbols.
1833 */
1834 else if (type == XA_ATOM)
1835 {
1836 int i;
1837 /* On a 64 bit machine sizeof(Atom) == sizeof(long) == 8.
1838 But the callers of these function has made sure the data for
1839 format == 32 is an array of int. Thus, use int instead
1840 of Atom. */
1841 int *idata = (int *) data;
1842
1843 if (size == sizeof (int))
1844 return x_atom_to_symbol (display, (Atom) idata[0]);
1845 else
1846 {
1847 Lisp_Object v = Fmake_vector (make_number (size / sizeof (int)),
1848 make_number (0));
1849 for (i = 0; i < size / sizeof (int); i++)
1850 Faset (v, make_number (i),
1851 x_atom_to_symbol (display, (Atom) idata[i]));
1852 return v;
1853 }
1854 }
1855
1856 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1857 If the number is > 16 bits, convert it to a cons of integers,
1858 16 bits in each half.
1859 */
1860 else if (format == 32 && size == sizeof (int))
1861 return long_to_cons (((unsigned int *) data) [0]);
1862 else if (format == 16 && size == sizeof (short))
1863 return make_number ((int) (((unsigned short *) data) [0]));
1864
1865 /* Convert any other kind of data to a vector of numbers, represented
1866 as above (as an integer, or a cons of two 16 bit integers.)
1867 */
1868 else if (format == 16)
1869 {
1870 int i;
1871 Lisp_Object v;
1872 v = Fmake_vector (make_number (size / 2), make_number (0));
1873 for (i = 0; i < size / 2; i++)
1874 {
1875 int j = (int) ((unsigned short *) data) [i];
1876 Faset (v, make_number (i), make_number (j));
1877 }
1878 return v;
1879 }
1880 else
1881 {
1882 int i;
1883 Lisp_Object v = Fmake_vector (make_number (size / 4), make_number (0));
1884 for (i = 0; i < size / 4; i++)
1885 {
1886 unsigned int j = ((unsigned int *) data) [i];
1887 Faset (v, make_number (i), long_to_cons (j));
1888 }
1889 return v;
1890 }
1891 }
1892
1893
1894 /* Use xfree, not XFree, to free the data obtained with this function. */
1895
1896 static void
1897 lisp_data_to_selection_data (display, obj,
1898 data_ret, type_ret, size_ret,
1899 format_ret, nofree_ret)
1900 Display *display;
1901 Lisp_Object obj;
1902 unsigned char **data_ret;
1903 Atom *type_ret;
1904 unsigned int *size_ret;
1905 int *format_ret;
1906 int *nofree_ret;
1907 {
1908 Lisp_Object type = Qnil;
1909 struct x_display_info *dpyinfo = x_display_info_for_display (display);
1910
1911 *nofree_ret = 0;
1912
1913 if (CONSP (obj) && SYMBOLP (XCAR (obj)))
1914 {
1915 type = XCAR (obj);
1916 obj = XCDR (obj);
1917 if (CONSP (obj) && NILP (XCDR (obj)))
1918 obj = XCAR (obj);
1919 }
1920
1921 if (EQ (obj, QNULL) || (EQ (type, QNULL)))
1922 { /* This is not the same as declining */
1923 *format_ret = 32;
1924 *size_ret = 0;
1925 *data_ret = 0;
1926 type = QNULL;
1927 }
1928 else if (STRINGP (obj))
1929 {
1930 if (SCHARS (obj) < SBYTES (obj))
1931 /* OBJ is a multibyte string containing a non-ASCII char. */
1932 Fsignal (Qerror, /* Qselection_error */
1933 Fcons (build_string
1934 ("Non-ASCII string must be encoded in advance"),
1935 Fcons (obj, Qnil)));
1936 if (NILP (type))
1937 type = QSTRING;
1938 *format_ret = 8;
1939 *size_ret = SBYTES (obj);
1940 *data_ret = SDATA (obj);
1941 *nofree_ret = 1;
1942 }
1943 else if (SYMBOLP (obj))
1944 {
1945 *format_ret = 32;
1946 *size_ret = 1;
1947 *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
1948 (*data_ret) [sizeof (Atom)] = 0;
1949 (*(Atom **) data_ret) [0] = symbol_to_x_atom (dpyinfo, display, obj);
1950 if (NILP (type)) type = QATOM;
1951 }
1952 else if (INTEGERP (obj)
1953 && XINT (obj) < 0xFFFF
1954 && XINT (obj) > -0xFFFF)
1955 {
1956 *format_ret = 16;
1957 *size_ret = 1;
1958 *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
1959 (*data_ret) [sizeof (short)] = 0;
1960 (*(short **) data_ret) [0] = (short) XINT (obj);
1961 if (NILP (type)) type = QINTEGER;
1962 }
1963 else if (INTEGERP (obj)
1964 || (CONSP (obj) && INTEGERP (XCAR (obj))
1965 && (INTEGERP (XCDR (obj))
1966 || (CONSP (XCDR (obj))
1967 && INTEGERP (XCAR (XCDR (obj)))))))
1968 {
1969 *format_ret = 32;
1970 *size_ret = 1;
1971 *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
1972 (*data_ret) [sizeof (long)] = 0;
1973 (*(unsigned long **) data_ret) [0] = cons_to_long (obj);
1974 if (NILP (type)) type = QINTEGER;
1975 }
1976 else if (VECTORP (obj))
1977 {
1978 /* Lisp_Vectors may represent a set of ATOMs;
1979 a set of 16 or 32 bit INTEGERs;
1980 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1981 */
1982 int i;
1983
1984 if (SYMBOLP (XVECTOR (obj)->contents [0]))
1985 /* This vector is an ATOM set */
1986 {
1987 if (NILP (type)) type = QATOM;
1988 *size_ret = XVECTOR (obj)->size;
1989 *format_ret = 32;
1990 *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
1991 for (i = 0; i < *size_ret; i++)
1992 if (SYMBOLP (XVECTOR (obj)->contents [i]))
1993 (*(Atom **) data_ret) [i]
1994 = symbol_to_x_atom (dpyinfo, display, XVECTOR (obj)->contents [i]);
1995 else
1996 Fsignal (Qerror, /* Qselection_error */
1997 Fcons (build_string
1998 ("all elements of selection vector must have same type"),
1999 Fcons (obj, Qnil)));
2000 }
2001 #if 0 /* #### MULTIPLE doesn't work yet */
2002 else if (VECTORP (XVECTOR (obj)->contents [0]))
2003 /* This vector is an ATOM_PAIR set */
2004 {
2005 if (NILP (type)) type = QATOM_PAIR;
2006 *size_ret = XVECTOR (obj)->size;
2007 *format_ret = 32;
2008 *data_ret = (unsigned char *)
2009 xmalloc ((*size_ret) * sizeof (Atom) * 2);
2010 for (i = 0; i < *size_ret; i++)
2011 if (VECTORP (XVECTOR (obj)->contents [i]))
2012 {
2013 Lisp_Object pair = XVECTOR (obj)->contents [i];
2014 if (XVECTOR (pair)->size != 2)
2015 Fsignal (Qerror,
2016 Fcons (build_string
2017 ("elements of the vector must be vectors of exactly two elements"),
2018 Fcons (pair, Qnil)));
2019
2020 (*(Atom **) data_ret) [i * 2]
2021 = symbol_to_x_atom (dpyinfo, display,
2022 XVECTOR (pair)->contents [0]);
2023 (*(Atom **) data_ret) [(i * 2) + 1]
2024 = symbol_to_x_atom (dpyinfo, display,
2025 XVECTOR (pair)->contents [1]);
2026 }
2027 else
2028 Fsignal (Qerror,
2029 Fcons (build_string
2030 ("all elements of the vector must be of the same type"),
2031 Fcons (obj, Qnil)));
2032
2033 }
2034 #endif
2035 else
2036 /* This vector is an INTEGER set, or something like it */
2037 {
2038 int data_size = 2;
2039 *size_ret = XVECTOR (obj)->size;
2040 if (NILP (type)) type = QINTEGER;
2041 *format_ret = 16;
2042 for (i = 0; i < *size_ret; i++)
2043 if (CONSP (XVECTOR (obj)->contents [i]))
2044 *format_ret = 32;
2045 else if (!INTEGERP (XVECTOR (obj)->contents [i]))
2046 Fsignal (Qerror, /* Qselection_error */
2047 Fcons (build_string
2048 ("elements of selection vector must be integers or conses of integers"),
2049 Fcons (obj, Qnil)));
2050
2051 /* Use sizeof(long) even if it is more than 32 bits. See comment
2052 in x_get_window_property and x_fill_property_data. */
2053
2054 if (*format_ret == 32) data_size = sizeof(long);
2055 *data_ret = (unsigned char *) xmalloc (*size_ret * data_size);
2056 for (i = 0; i < *size_ret; i++)
2057 if (*format_ret == 32)
2058 (*((unsigned long **) data_ret)) [i]
2059 = cons_to_long (XVECTOR (obj)->contents [i]);
2060 else
2061 (*((unsigned short **) data_ret)) [i]
2062 = (unsigned short) cons_to_long (XVECTOR (obj)->contents [i]);
2063 }
2064 }
2065 else
2066 Fsignal (Qerror, /* Qselection_error */
2067 Fcons (build_string ("unrecognized selection data"),
2068 Fcons (obj, Qnil)));
2069
2070 *type_ret = symbol_to_x_atom (dpyinfo, display, type);
2071 }
2072
2073 static Lisp_Object
2074 clean_local_selection_data (obj)
2075 Lisp_Object obj;
2076 {
2077 if (CONSP (obj)
2078 && INTEGERP (XCAR (obj))
2079 && CONSP (XCDR (obj))
2080 && INTEGERP (XCAR (XCDR (obj)))
2081 && NILP (XCDR (XCDR (obj))))
2082 obj = Fcons (XCAR (obj), XCDR (obj));
2083
2084 if (CONSP (obj)
2085 && INTEGERP (XCAR (obj))
2086 && INTEGERP (XCDR (obj)))
2087 {
2088 if (XINT (XCAR (obj)) == 0)
2089 return XCDR (obj);
2090 if (XINT (XCAR (obj)) == -1)
2091 return make_number (- XINT (XCDR (obj)));
2092 }
2093 if (VECTORP (obj))
2094 {
2095 int i;
2096 int size = XVECTOR (obj)->size;
2097 Lisp_Object copy;
2098 if (size == 1)
2099 return clean_local_selection_data (XVECTOR (obj)->contents [0]);
2100 copy = Fmake_vector (make_number (size), Qnil);
2101 for (i = 0; i < size; i++)
2102 XVECTOR (copy)->contents [i]
2103 = clean_local_selection_data (XVECTOR (obj)->contents [i]);
2104 return copy;
2105 }
2106 return obj;
2107 }
2108 \f
2109 /* Called from XTread_socket to handle SelectionNotify events.
2110 If it's the selection we are waiting for, stop waiting
2111 by setting the car of reading_selection_reply to non-nil.
2112 We store t there if the reply is successful, lambda if not. */
2113
2114 void
2115 x_handle_selection_notify (event)
2116 XSelectionEvent *event;
2117 {
2118 if (event->requestor != reading_selection_window)
2119 return;
2120 if (event->selection != reading_which_selection)
2121 return;
2122
2123 TRACE0 ("Received SelectionNotify");
2124 XSETCAR (reading_selection_reply,
2125 (event->property != 0 ? Qt : Qlambda));
2126 }
2127
2128 \f
2129 DEFUN ("x-own-selection-internal", Fx_own_selection_internal,
2130 Sx_own_selection_internal, 2, 2, 0,
2131 doc: /* Assert an X selection of the given TYPE with the given VALUE.
2132 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
2133 \(Those are literal upper-case symbol names, since that's what X expects.)
2134 VALUE is typically a string, or a cons of two markers, but may be
2135 anything that the functions on `selection-converter-alist' know about. */)
2136 (selection_name, selection_value)
2137 Lisp_Object selection_name, selection_value;
2138 {
2139 check_x ();
2140 CHECK_SYMBOL (selection_name);
2141 if (NILP (selection_value)) error ("SELECTION-VALUE may not be nil");
2142 x_own_selection (selection_name, selection_value);
2143 return selection_value;
2144 }
2145
2146
2147 /* Request the selection value from the owner. If we are the owner,
2148 simply return our selection value. If we are not the owner, this
2149 will block until all of the data has arrived. */
2150
2151 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
2152 Sx_get_selection_internal, 2, 3, 0,
2153 doc: /* Return text selected from some X window.
2154 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
2155 \(Those are literal upper-case symbol names, since that's what X expects.)
2156 TYPE is the type of data desired, typically `STRING'.
2157 TIME_STAMP is the time to use in the XConvertSelection call for foreign
2158 selections. If omitted, defaults to the time for the last event. */)
2159 (selection_symbol, target_type, time_stamp)
2160 Lisp_Object selection_symbol, target_type, time_stamp;
2161 {
2162 Lisp_Object val = Qnil;
2163 struct gcpro gcpro1, gcpro2;
2164 GCPRO2 (target_type, val); /* we store newly consed data into these */
2165 check_x ();
2166 CHECK_SYMBOL (selection_symbol);
2167
2168 #if 0 /* #### MULTIPLE doesn't work yet */
2169 if (CONSP (target_type)
2170 && XCAR (target_type) == QMULTIPLE)
2171 {
2172 CHECK_VECTOR (XCDR (target_type));
2173 /* So we don't destructively modify this... */
2174 target_type = copy_multiple_data (target_type);
2175 }
2176 else
2177 #endif
2178 CHECK_SYMBOL (target_type);
2179
2180 val = x_get_local_selection (selection_symbol, target_type, 1);
2181
2182 if (NILP (val))
2183 {
2184 val = x_get_foreign_selection (selection_symbol, target_type, time_stamp);
2185 goto DONE;
2186 }
2187
2188 if (CONSP (val)
2189 && SYMBOLP (XCAR (val)))
2190 {
2191 val = XCDR (val);
2192 if (CONSP (val) && NILP (XCDR (val)))
2193 val = XCAR (val);
2194 }
2195 val = clean_local_selection_data (val);
2196 DONE:
2197 UNGCPRO;
2198 return val;
2199 }
2200
2201 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
2202 Sx_disown_selection_internal, 1, 2, 0,
2203 doc: /* If we own the selection SELECTION, disown it.
2204 Disowning it means there is no such selection. */)
2205 (selection, time)
2206 Lisp_Object selection;
2207 Lisp_Object time;
2208 {
2209 Time timestamp;
2210 Atom selection_atom;
2211 union {
2212 struct selection_input_event sie;
2213 struct input_event ie;
2214 } event;
2215 Display *display;
2216 struct x_display_info *dpyinfo;
2217 struct frame *sf = SELECTED_FRAME ();
2218
2219 check_x ();
2220 display = FRAME_X_DISPLAY (sf);
2221 dpyinfo = FRAME_X_DISPLAY_INFO (sf);
2222 CHECK_SYMBOL (selection);
2223 if (NILP (time))
2224 timestamp = last_event_timestamp;
2225 else
2226 timestamp = cons_to_long (time);
2227
2228 if (NILP (assq_no_quit (selection, Vselection_alist)))
2229 return Qnil; /* Don't disown the selection when we're not the owner. */
2230
2231 selection_atom = symbol_to_x_atom (dpyinfo, display, selection);
2232
2233 BLOCK_INPUT;
2234 XSetSelectionOwner (display, selection_atom, None, timestamp);
2235 UNBLOCK_INPUT;
2236
2237 /* It doesn't seem to be guaranteed that a SelectionClear event will be
2238 generated for a window which owns the selection when that window sets
2239 the selection owner to None. The NCD server does, the MIT Sun4 server
2240 doesn't. So we synthesize one; this means we might get two, but
2241 that's ok, because the second one won't have any effect. */
2242 SELECTION_EVENT_DISPLAY (&event.sie) = display;
2243 SELECTION_EVENT_SELECTION (&event.sie) = selection_atom;
2244 SELECTION_EVENT_TIME (&event.sie) = timestamp;
2245 x_handle_selection_clear (&event.ie);
2246
2247 return Qt;
2248 }
2249
2250 /* Get rid of all the selections in buffer BUFFER.
2251 This is used when we kill a buffer. */
2252
2253 void
2254 x_disown_buffer_selections (buffer)
2255 Lisp_Object buffer;
2256 {
2257 Lisp_Object tail;
2258 struct buffer *buf = XBUFFER (buffer);
2259
2260 for (tail = Vselection_alist; CONSP (tail); tail = XCDR (tail))
2261 {
2262 Lisp_Object elt, value;
2263 elt = XCAR (tail);
2264 value = XCDR (elt);
2265 if (CONSP (value) && MARKERP (XCAR (value))
2266 && XMARKER (XCAR (value))->buffer == buf)
2267 Fx_disown_selection_internal (XCAR (elt), Qnil);
2268 }
2269 }
2270
2271 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
2272 0, 1, 0,
2273 doc: /* Whether the current Emacs process owns the given X Selection.
2274 The arg should be the name of the selection in question, typically one of
2275 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
2276 \(Those are literal upper-case symbol names, since that's what X expects.)
2277 For convenience, the symbol nil is the same as `PRIMARY',
2278 and t is the same as `SECONDARY'. */)
2279 (selection)
2280 Lisp_Object selection;
2281 {
2282 check_x ();
2283 CHECK_SYMBOL (selection);
2284 if (EQ (selection, Qnil)) selection = QPRIMARY;
2285 if (EQ (selection, Qt)) selection = QSECONDARY;
2286
2287 if (NILP (Fassq (selection, Vselection_alist)))
2288 return Qnil;
2289 return Qt;
2290 }
2291
2292 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
2293 0, 1, 0,
2294 doc: /* Whether there is an owner for the given X Selection.
2295 The arg should be the name of the selection in question, typically one of
2296 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
2297 \(Those are literal upper-case symbol names, since that's what X expects.)
2298 For convenience, the symbol nil is the same as `PRIMARY',
2299 and t is the same as `SECONDARY'. */)
2300 (selection)
2301 Lisp_Object selection;
2302 {
2303 Window owner;
2304 Atom atom;
2305 Display *dpy;
2306 struct frame *sf = SELECTED_FRAME ();
2307
2308 /* It should be safe to call this before we have an X frame. */
2309 if (! FRAME_X_P (sf))
2310 return Qnil;
2311
2312 dpy = FRAME_X_DISPLAY (sf);
2313 CHECK_SYMBOL (selection);
2314 if (!NILP (Fx_selection_owner_p (selection)))
2315 return Qt;
2316 if (EQ (selection, Qnil)) selection = QPRIMARY;
2317 if (EQ (selection, Qt)) selection = QSECONDARY;
2318 atom = symbol_to_x_atom (FRAME_X_DISPLAY_INFO (sf), dpy, selection);
2319 if (atom == 0)
2320 return Qnil;
2321 BLOCK_INPUT;
2322 owner = XGetSelectionOwner (dpy, atom);
2323 UNBLOCK_INPUT;
2324 return (owner ? Qt : Qnil);
2325 }
2326
2327 \f
2328 #ifdef CUT_BUFFER_SUPPORT
2329
2330 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
2331 static void
2332 initialize_cut_buffers (display, window)
2333 Display *display;
2334 Window window;
2335 {
2336 unsigned char *data = (unsigned char *) "";
2337 BLOCK_INPUT;
2338 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
2339 PropModeAppend, data, 0)
2340 FROB (XA_CUT_BUFFER0);
2341 FROB (XA_CUT_BUFFER1);
2342 FROB (XA_CUT_BUFFER2);
2343 FROB (XA_CUT_BUFFER3);
2344 FROB (XA_CUT_BUFFER4);
2345 FROB (XA_CUT_BUFFER5);
2346 FROB (XA_CUT_BUFFER6);
2347 FROB (XA_CUT_BUFFER7);
2348 #undef FROB
2349 UNBLOCK_INPUT;
2350 }
2351
2352
2353 #define CHECK_CUT_BUFFER(symbol) \
2354 { CHECK_SYMBOL ((symbol)); \
2355 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
2356 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
2357 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
2358 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
2359 Fsignal (Qerror, \
2360 Fcons (build_string ("doesn't name a cut buffer"), \
2361 Fcons ((symbol), Qnil))); \
2362 }
2363
2364 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal,
2365 Sx_get_cut_buffer_internal, 1, 1, 0,
2366 doc: /* Returns the value of the named cut buffer (typically CUT_BUFFER0). */)
2367 (buffer)
2368 Lisp_Object buffer;
2369 {
2370 Window window;
2371 Atom buffer_atom;
2372 unsigned char *data;
2373 int bytes;
2374 Atom type;
2375 int format;
2376 unsigned long size;
2377 Lisp_Object ret;
2378 Display *display;
2379 struct x_display_info *dpyinfo;
2380 struct frame *sf = SELECTED_FRAME ();
2381
2382 check_x ();
2383 display = FRAME_X_DISPLAY (sf);
2384 dpyinfo = FRAME_X_DISPLAY_INFO (sf);
2385 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
2386 CHECK_CUT_BUFFER (buffer);
2387 buffer_atom = symbol_to_x_atom (dpyinfo, display, buffer);
2388
2389 x_get_window_property (display, window, buffer_atom, &data, &bytes,
2390 &type, &format, &size, 0);
2391 if (!data || !format)
2392 return Qnil;
2393
2394 if (format != 8 || type != XA_STRING)
2395 Fsignal (Qerror,
2396 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
2397 Fcons (x_atom_to_symbol (display, type),
2398 Fcons (make_number (format), Qnil))));
2399
2400 ret = (bytes ? make_unibyte_string ((char *) data, bytes) : Qnil);
2401 /* Use xfree, not XFree, because x_get_window_property
2402 calls xmalloc itself. */
2403 xfree (data);
2404 return ret;
2405 }
2406
2407
2408 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal,
2409 Sx_store_cut_buffer_internal, 2, 2, 0,
2410 doc: /* Sets the value of the named cut buffer (typically CUT_BUFFER0). */)
2411 (buffer, string)
2412 Lisp_Object buffer, string;
2413 {
2414 Window window;
2415 Atom buffer_atom;
2416 unsigned char *data;
2417 int bytes;
2418 int bytes_remaining;
2419 int max_bytes;
2420 Display *display;
2421 struct frame *sf = SELECTED_FRAME ();
2422
2423 check_x ();
2424 display = FRAME_X_DISPLAY (sf);
2425 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
2426
2427 max_bytes = SELECTION_QUANTUM (display);
2428 if (max_bytes > MAX_SELECTION_QUANTUM)
2429 max_bytes = MAX_SELECTION_QUANTUM;
2430
2431 CHECK_CUT_BUFFER (buffer);
2432 CHECK_STRING (string);
2433 buffer_atom = symbol_to_x_atom (FRAME_X_DISPLAY_INFO (sf),
2434 display, buffer);
2435 data = (unsigned char *) SDATA (string);
2436 bytes = SBYTES (string);
2437 bytes_remaining = bytes;
2438
2439 if (! FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized)
2440 {
2441 initialize_cut_buffers (display, window);
2442 FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized = 1;
2443 }
2444
2445 BLOCK_INPUT;
2446
2447 /* Don't mess up with an empty value. */
2448 if (!bytes_remaining)
2449 XChangeProperty (display, window, buffer_atom, XA_STRING, 8,
2450 PropModeReplace, data, 0);
2451
2452 while (bytes_remaining)
2453 {
2454 int chunk = (bytes_remaining < max_bytes
2455 ? bytes_remaining : max_bytes);
2456 XChangeProperty (display, window, buffer_atom, XA_STRING, 8,
2457 (bytes_remaining == bytes
2458 ? PropModeReplace
2459 : PropModeAppend),
2460 data, chunk);
2461 data += chunk;
2462 bytes_remaining -= chunk;
2463 }
2464 UNBLOCK_INPUT;
2465 return string;
2466 }
2467
2468
2469 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal,
2470 Sx_rotate_cut_buffers_internal, 1, 1, 0,
2471 doc: /* Rotate the values of the cut buffers by the given number of step.
2472 Positive means shift the values forward, negative means backward. */)
2473 (n)
2474 Lisp_Object n;
2475 {
2476 Window window;
2477 Atom props[8];
2478 Display *display;
2479 struct frame *sf = SELECTED_FRAME ();
2480
2481 check_x ();
2482 display = FRAME_X_DISPLAY (sf);
2483 window = RootWindow (display, 0); /* Cut buffers are on screen 0 */
2484 CHECK_NUMBER (n);
2485 if (XINT (n) == 0)
2486 return n;
2487 if (! FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized)
2488 {
2489 initialize_cut_buffers (display, window);
2490 FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized = 1;
2491 }
2492
2493 props[0] = XA_CUT_BUFFER0;
2494 props[1] = XA_CUT_BUFFER1;
2495 props[2] = XA_CUT_BUFFER2;
2496 props[3] = XA_CUT_BUFFER3;
2497 props[4] = XA_CUT_BUFFER4;
2498 props[5] = XA_CUT_BUFFER5;
2499 props[6] = XA_CUT_BUFFER6;
2500 props[7] = XA_CUT_BUFFER7;
2501 BLOCK_INPUT;
2502 XRotateWindowProperties (display, window, props, 8, XINT (n));
2503 UNBLOCK_INPUT;
2504 return n;
2505 }
2506
2507 #endif
2508 \f
2509 /***********************************************************************
2510 Drag and drop support
2511 ***********************************************************************/
2512 /* Check that lisp values are of correct type for x_fill_property_data.
2513 That is, number, string or a cons with two numbers (low and high 16
2514 bit parts of a 32 bit number). */
2515
2516 int
2517 x_check_property_data (data)
2518 Lisp_Object data;
2519 {
2520 Lisp_Object iter;
2521 int size = 0;
2522
2523 for (iter = data; CONSP (iter) && size != -1; iter = XCDR (iter), ++size)
2524 {
2525 Lisp_Object o = XCAR (iter);
2526
2527 if (! NUMBERP (o) && ! STRINGP (o) && ! CONSP (o))
2528 size = -1;
2529 else if (CONSP (o) &&
2530 (! NUMBERP (XCAR (o)) || ! NUMBERP (XCDR (o))))
2531 size = -1;
2532 }
2533
2534 return size;
2535 }
2536
2537 /* Convert lisp values to a C array. Values may be a number, a string
2538 which is taken as an X atom name and converted to the atom value, or
2539 a cons containing the two 16 bit parts of a 32 bit number.
2540
2541 DPY is the display use to look up X atoms.
2542 DATA is a Lisp list of values to be converted.
2543 RET is the C array that contains the converted values. It is assumed
2544 it is big enough to hold all values.
2545 FORMAT is 8, 16 or 32 and denotes char/short/long for each C value to
2546 be stored in RET. Note that long is used for 32 even if long is more
2547 than 32 bits (see man pages for XChangeProperty, XGetWindowProperty and
2548 XClientMessageEvent). */
2549
2550 void
2551 x_fill_property_data (dpy, data, ret, format)
2552 Display *dpy;
2553 Lisp_Object data;
2554 void *ret;
2555 int format;
2556 {
2557 long val;
2558 long *d32 = (long *) ret;
2559 short *d16 = (short *) ret;
2560 char *d08 = (char *) ret;
2561 Lisp_Object iter;
2562
2563 for (iter = data; CONSP (iter); iter = XCDR (iter))
2564 {
2565 Lisp_Object o = XCAR (iter);
2566
2567 if (INTEGERP (o))
2568 val = (long) XFASTINT (o);
2569 else if (FLOATP (o))
2570 val = (long) XFLOAT_DATA (o);
2571 else if (CONSP (o))
2572 val = (long) cons_to_long (o);
2573 else if (STRINGP (o))
2574 {
2575 BLOCK_INPUT;
2576 val = (long) XInternAtom (dpy, (char *) SDATA (o), False);
2577 UNBLOCK_INPUT;
2578 }
2579 else
2580 error ("Wrong type, must be string, number or cons");
2581
2582 if (format == 8)
2583 *d08++ = (char) val;
2584 else if (format == 16)
2585 *d16++ = (short) val;
2586 else
2587 *d32++ = val;
2588 }
2589 }
2590
2591 /* Convert an array of C values to a Lisp list.
2592 F is the frame to be used to look up X atoms if the TYPE is XA_ATOM.
2593 DATA is a C array of values to be converted.
2594 TYPE is the type of the data. Only XA_ATOM is special, it converts
2595 each number in DATA to its corresponfing X atom as a symbol.
2596 FORMAT is 8, 16 or 32 and gives the size in bits for each C value to
2597 be stored in RET.
2598 SIZE is the number of elements in DATA.
2599
2600 Important: When format is 32, data should contain an array of int,
2601 not an array of long as the X library returns. This makes a difference
2602 when sizeof(long) != sizeof(int).
2603
2604 Also see comment for selection_data_to_lisp_data above. */
2605
2606 Lisp_Object
2607 x_property_data_to_lisp (f, data, type, format, size)
2608 struct frame *f;
2609 unsigned char *data;
2610 Atom type;
2611 int format;
2612 unsigned long size;
2613 {
2614 return selection_data_to_lisp_data (FRAME_X_DISPLAY (f),
2615 data, size*format/8, type, format);
2616 }
2617
2618 /* Get the mouse position in frame relative coordinates. */
2619
2620 static void
2621 mouse_position_for_drop (f, x, y)
2622 FRAME_PTR f;
2623 int *x;
2624 int *y;
2625 {
2626 Window root, dummy_window;
2627 int dummy;
2628
2629 BLOCK_INPUT;
2630
2631 XQueryPointer (FRAME_X_DISPLAY (f),
2632 DefaultRootWindow (FRAME_X_DISPLAY (f)),
2633
2634 /* The root window which contains the pointer. */
2635 &root,
2636
2637 /* Window pointer is on, not used */
2638 &dummy_window,
2639
2640 /* The position on that root window. */
2641 x, y,
2642
2643 /* x/y in dummy_window coordinates, not used. */
2644 &dummy, &dummy,
2645
2646 /* Modifier keys and pointer buttons, about which
2647 we don't care. */
2648 (unsigned int *) &dummy);
2649
2650
2651 /* Absolute to relative. */
2652 *x -= f->left_pos + FRAME_OUTER_TO_INNER_DIFF_X (f);
2653 *y -= f->top_pos + FRAME_OUTER_TO_INNER_DIFF_Y (f);
2654
2655 UNBLOCK_INPUT;
2656 }
2657
2658 DEFUN ("x-get-atom-name", Fx_get_atom_name,
2659 Sx_get_atom_name, 1, 2, 0,
2660 doc: /* Return the X atom name for VALUE as a string.
2661 VALUE may be a number or a cons where the car is the upper 16 bits and
2662 the cdr is the lower 16 bits of a 32 bit value.
2663 Use the display for FRAME or the current frame if FRAME is not given or nil.
2664
2665 If the value is 0 or the atom is not known, return the empty string. */)
2666 (value, frame)
2667 Lisp_Object value, frame;
2668 {
2669 struct frame *f = check_x_frame (frame);
2670 char *name = 0;
2671 Lisp_Object ret = Qnil;
2672 Display *dpy = FRAME_X_DISPLAY (f);
2673 Atom atom;
2674 int had_errors;
2675
2676 if (INTEGERP (value))
2677 atom = (Atom) XUINT (value);
2678 else if (FLOATP (value))
2679 atom = (Atom) XFLOAT_DATA (value);
2680 else if (CONSP (value))
2681 atom = (Atom) cons_to_long (value);
2682 else
2683 error ("Wrong type, value must be number or cons");
2684
2685 BLOCK_INPUT;
2686 x_catch_errors (dpy);
2687 name = atom ? XGetAtomName (dpy, atom) : "";
2688 had_errors = x_had_errors_p (dpy);
2689 x_uncatch_errors ();
2690
2691 if (!had_errors)
2692 ret = make_string (name, strlen (name));
2693
2694 if (atom && name) XFree (name);
2695 if (NILP (ret)) ret = make_string ("", 0);
2696
2697 UNBLOCK_INPUT;
2698
2699 return ret;
2700 }
2701
2702 /* Convert an XClientMessageEvent to a Lisp event of type DRAG_N_DROP_EVENT.
2703 TODO: Check if this client event really is a DND event? */
2704
2705 int
2706 x_handle_dnd_message (f, event, dpyinfo, bufp)
2707 struct frame *f;
2708 XClientMessageEvent *event;
2709 struct x_display_info *dpyinfo;
2710 struct input_event *bufp;
2711 {
2712 Lisp_Object vec;
2713 Lisp_Object frame;
2714 /* format 32 => size 5, format 16 => size 10, format 8 => size 20 */
2715 unsigned long size = 160/event->format;
2716 int x, y;
2717 unsigned char *data = (unsigned char *) event->data.b;
2718 int idata[5];
2719
2720 XSETFRAME (frame, f);
2721
2722 /* On a 64 bit machine, the event->data.l array members are 64 bits (long),
2723 but the x_property_data_to_lisp (or rather selection_data_to_lisp_data)
2724 function expects them to be of size int (i.e. 32). So to be able to
2725 use that function, put the data in the form it expects if format is 32. */
2726
2727 if (event->format == 32 && event->format < BITS_PER_LONG)
2728 {
2729 int i;
2730 for (i = 0; i < 5; ++i) /* There are only 5 longs in a ClientMessage. */
2731 idata[i] = (int) event->data.l[i];
2732 data = (unsigned char *) idata;
2733 }
2734
2735 vec = Fmake_vector (make_number (4), Qnil);
2736 AREF (vec, 0) = SYMBOL_NAME (x_atom_to_symbol (FRAME_X_DISPLAY (f),
2737 event->message_type));
2738 AREF (vec, 1) = frame;
2739 AREF (vec, 2) = make_number (event->format);
2740 AREF (vec, 3) = x_property_data_to_lisp (f,
2741 data,
2742 event->message_type,
2743 event->format,
2744 size);
2745
2746 mouse_position_for_drop (f, &x, &y);
2747 bufp->kind = DRAG_N_DROP_EVENT;
2748 bufp->frame_or_window = frame;
2749 bufp->timestamp = CurrentTime;
2750 bufp->x = make_number (x);
2751 bufp->y = make_number (y);
2752 bufp->arg = vec;
2753 bufp->modifiers = 0;
2754
2755 return 1;
2756 }
2757
2758 DEFUN ("x-send-client-message", Fx_send_client_event,
2759 Sx_send_client_message, 6, 6, 0,
2760 doc: /* Send a client message of MESSAGE-TYPE to window DEST on DISPLAY.
2761
2762 For DISPLAY, specify either a frame or a display name (a string).
2763 If DISPLAY is nil, that stands for the selected frame's display.
2764 DEST may be a number, in which case it is a Window id. The value 0 may
2765 be used to send to the root window of the DISPLAY.
2766 If DEST is a cons, it is converted to a 32 bit number
2767 with the high 16 bits from the car and the lower 16 bit from the cdr. That
2768 number is then used as a window id.
2769 If DEST is a frame the event is sent to the outer window of that frame.
2770 Nil means the currently selected frame.
2771 If DEST is the string "PointerWindow" the event is sent to the window that
2772 contains the pointer. If DEST is the string "InputFocus" the event is
2773 sent to the window that has the input focus.
2774 FROM is the frame sending the event. Use nil for currently selected frame.
2775 MESSAGE-TYPE is the name of an Atom as a string.
2776 FORMAT must be one of 8, 16 or 32 and determines the size of the values in
2777 bits. VALUES is a list of numbers, cons and/or strings containing the values
2778 to send. If a value is a string, it is converted to an Atom and the value of
2779 the Atom is sent. If a value is a cons, it is converted to a 32 bit number
2780 with the high 16 bits from the car and the lower 16 bit from the cdr.
2781 If more values than fits into the event is given, the excessive values
2782 are ignored. */)
2783 (display, dest, from, message_type, format, values)
2784 Lisp_Object display, dest, from, message_type, format, values;
2785 {
2786 struct x_display_info *dpyinfo = check_x_display_info (display);
2787 Window wdest;
2788 XEvent event;
2789 Lisp_Object cons;
2790 int size;
2791 struct frame *f = check_x_frame (from);
2792 int to_root;
2793
2794 CHECK_STRING (message_type);
2795 CHECK_NUMBER (format);
2796 CHECK_CONS (values);
2797
2798 if (x_check_property_data (values) == -1)
2799 error ("Bad data in VALUES, must be number, cons or string");
2800
2801 event.xclient.type = ClientMessage;
2802 event.xclient.format = XFASTINT (format);
2803
2804 if (event.xclient.format != 8 && event.xclient.format != 16
2805 && event.xclient.format != 32)
2806 error ("FORMAT must be one of 8, 16 or 32");
2807
2808 if (FRAMEP (dest) || NILP (dest))
2809 {
2810 struct frame *fdest = check_x_frame (dest);
2811 wdest = FRAME_OUTER_WINDOW (fdest);
2812 }
2813 else if (STRINGP (dest))
2814 {
2815 if (strcmp (SDATA (dest), "PointerWindow") == 0)
2816 wdest = PointerWindow;
2817 else if (strcmp (SDATA (dest), "InputFocus") == 0)
2818 wdest = InputFocus;
2819 else
2820 error ("DEST as a string must be one of PointerWindow or InputFocus");
2821 }
2822 else if (INTEGERP (dest))
2823 wdest = (Window) XFASTINT (dest);
2824 else if (FLOATP (dest))
2825 wdest = (Window) XFLOAT_DATA (dest);
2826 else if (CONSP (dest))
2827 {
2828 if (! NUMBERP (XCAR (dest)) || ! NUMBERP (XCDR (dest)))
2829 error ("Both car and cdr for DEST must be numbers");
2830 else
2831 wdest = (Window) cons_to_long (dest);
2832 }
2833 else
2834 error ("DEST must be a frame, nil, string, number or cons");
2835
2836 if (wdest == 0) wdest = dpyinfo->root_window;
2837 to_root = wdest == dpyinfo->root_window;
2838
2839 for (cons = values, size = 0; CONSP (cons); cons = XCDR (cons), ++size)
2840 ;
2841
2842 BLOCK_INPUT;
2843
2844 event.xclient.message_type
2845 = XInternAtom (dpyinfo->display, SDATA (message_type), False);
2846 event.xclient.display = dpyinfo->display;
2847
2848 /* Some clients (metacity for example) expects sending window to be here
2849 when sending to the root window. */
2850 event.xclient.window = to_root ? FRAME_OUTER_WINDOW (f) : wdest;
2851
2852
2853 memset (event.xclient.data.b, 0, sizeof (event.xclient.data.b));
2854 x_fill_property_data (dpyinfo->display, values, event.xclient.data.b,
2855 event.xclient.format);
2856
2857 /* If event mask is 0 the event is sent to the client that created
2858 the destination window. But if we are sending to the root window,
2859 there is no such client. Then we set the event mask to 0xffff. The
2860 event then goes to clients selecting for events on the root window. */
2861 x_catch_errors (dpyinfo->display);
2862 {
2863 int propagate = to_root ? False : True;
2864 unsigned mask = to_root ? 0xffff : 0;
2865 XSendEvent (dpyinfo->display, wdest, propagate, mask, &event);
2866 XFlush (dpyinfo->display);
2867 }
2868 x_uncatch_errors ();
2869 UNBLOCK_INPUT;
2870
2871 return Qnil;
2872 }
2873
2874 \f
2875 void
2876 syms_of_xselect ()
2877 {
2878 defsubr (&Sx_get_selection_internal);
2879 defsubr (&Sx_own_selection_internal);
2880 defsubr (&Sx_disown_selection_internal);
2881 defsubr (&Sx_selection_owner_p);
2882 defsubr (&Sx_selection_exists_p);
2883
2884 #ifdef CUT_BUFFER_SUPPORT
2885 defsubr (&Sx_get_cut_buffer_internal);
2886 defsubr (&Sx_store_cut_buffer_internal);
2887 defsubr (&Sx_rotate_cut_buffers_internal);
2888 #endif
2889
2890 defsubr (&Sx_get_atom_name);
2891 defsubr (&Sx_send_client_message);
2892
2893 reading_selection_reply = Fcons (Qnil, Qnil);
2894 staticpro (&reading_selection_reply);
2895 reading_selection_window = 0;
2896 reading_which_selection = 0;
2897
2898 property_change_wait_list = 0;
2899 prop_location_identifier = 0;
2900 property_change_reply = Fcons (Qnil, Qnil);
2901 staticpro (&property_change_reply);
2902
2903 Vselection_alist = Qnil;
2904 staticpro (&Vselection_alist);
2905
2906 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
2907 doc: /* An alist associating X Windows selection-types with functions.
2908 These functions are called to convert the selection, with three args:
2909 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');
2910 a desired type to which the selection should be converted;
2911 and the local selection value (whatever was given to `x-own-selection').
2912
2913 The function should return the value to send to the X server
2914 \(typically a string). A return value of nil
2915 means that the conversion could not be done.
2916 A return value which is the symbol `NULL'
2917 means that a side-effect was executed,
2918 and there is no meaningful selection value. */);
2919 Vselection_converter_alist = Qnil;
2920
2921 DEFVAR_LISP ("x-lost-selection-functions", &Vx_lost_selection_functions,
2922 doc: /* A list of functions to be called when Emacs loses an X selection.
2923 \(This happens when some other X client makes its own selection
2924 or when a Lisp program explicitly clears the selection.)
2925 The functions are called with one argument, the selection type
2926 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'). */);
2927 Vx_lost_selection_functions = Qnil;
2928
2929 DEFVAR_LISP ("x-sent-selection-functions", &Vx_sent_selection_functions,
2930 doc: /* A list of functions to be called when Emacs answers a selection request.
2931 The functions are called with four arguments:
2932 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');
2933 - the selection-type which Emacs was asked to convert the
2934 selection into before sending (for example, `STRING' or `LENGTH');
2935 - a flag indicating success or failure for responding to the request.
2936 We might have failed (and declined the request) for any number of reasons,
2937 including being asked for a selection that we no longer own, or being asked
2938 to convert into a type that we don't know about or that is inappropriate.
2939 This hook doesn't let you change the behavior of Emacs's selection replies,
2940 it merely informs you that they have happened. */);
2941 Vx_sent_selection_functions = Qnil;
2942
2943 DEFVAR_LISP ("selection-coding-system", &Vselection_coding_system,
2944 doc: /* Coding system for communicating with other X clients.
2945 When sending or receiving text via cut_buffer, selection, and clipboard,
2946 the text is encoded or decoded by this coding system.
2947 The default value is `compound-text-with-extensions'. */);
2948 Vselection_coding_system = intern ("compound-text-with-extensions");
2949
2950 DEFVAR_LISP ("next-selection-coding-system", &Vnext_selection_coding_system,
2951 doc: /* Coding system for the next communication with other X clients.
2952 Usually, `selection-coding-system' is used for communicating with
2953 other X clients. But, if this variable is set, it is used for the
2954 next communication only. After the communication, this variable is
2955 set to nil. */);
2956 Vnext_selection_coding_system = Qnil;
2957
2958 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout,
2959 doc: /* Number of milliseconds to wait for a selection reply.
2960 If the selection owner doesn't reply in this time, we give up.
2961 A value of 0 means wait as long as necessary. This is initialized from the
2962 \"*selectionTimeout\" resource. */);
2963 x_selection_timeout = 0;
2964
2965 QPRIMARY = intern ("PRIMARY"); staticpro (&QPRIMARY);
2966 QSECONDARY = intern ("SECONDARY"); staticpro (&QSECONDARY);
2967 QSTRING = intern ("STRING"); staticpro (&QSTRING);
2968 QINTEGER = intern ("INTEGER"); staticpro (&QINTEGER);
2969 QCLIPBOARD = intern ("CLIPBOARD"); staticpro (&QCLIPBOARD);
2970 QTIMESTAMP = intern ("TIMESTAMP"); staticpro (&QTIMESTAMP);
2971 QTEXT = intern ("TEXT"); staticpro (&QTEXT);
2972 QCOMPOUND_TEXT = intern ("COMPOUND_TEXT"); staticpro (&QCOMPOUND_TEXT);
2973 QUTF8_STRING = intern ("UTF8_STRING"); staticpro (&QUTF8_STRING);
2974 QDELETE = intern ("DELETE"); staticpro (&QDELETE);
2975 QMULTIPLE = intern ("MULTIPLE"); staticpro (&QMULTIPLE);
2976 QINCR = intern ("INCR"); staticpro (&QINCR);
2977 QEMACS_TMP = intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP);
2978 QTARGETS = intern ("TARGETS"); staticpro (&QTARGETS);
2979 QATOM = intern ("ATOM"); staticpro (&QATOM);
2980 QATOM_PAIR = intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR);
2981 QNULL = intern ("NULL"); staticpro (&QNULL);
2982 Qcompound_text_with_extensions = intern ("compound-text-with-extensions");
2983 staticpro (&Qcompound_text_with_extensions);
2984
2985 #ifdef CUT_BUFFER_SUPPORT
2986 QCUT_BUFFER0 = intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0);
2987 QCUT_BUFFER1 = intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1);
2988 QCUT_BUFFER2 = intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2);
2989 QCUT_BUFFER3 = intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3);
2990 QCUT_BUFFER4 = intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4);
2991 QCUT_BUFFER5 = intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5);
2992 QCUT_BUFFER6 = intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6);
2993 QCUT_BUFFER7 = intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7);
2994 #endif
2995
2996 Qforeign_selection = intern ("foreign-selection");
2997 staticpro (&Qforeign_selection);
2998 }
2999
3000 /* arch-tag: 7c293b0f-9918-4f69-8ac7-03e142307236
3001 (do not change this comment) */