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