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