1 /* x_handle_selection_notify
2 x_reply_selection_request
4 x_selection_timeout initial value */
6 /* X Selection processing for emacs
7 Copyright (C) 1990-1993 Free Software Foundation.
9 This file is part of GNU Emacs.
11 GNU Emacs is free software; you can redistribute it and/or modify
12 it under the terms of the GNU General Public License as published by
13 the Free Software Foundation; either version 2, or (at your option)
16 GNU Emacs is distributed in the hope that it will be useful,
17 but WITHOUT ANY WARRANTY; without even the implied warranty of
18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 GNU General Public License for more details.
21 You should have received a copy of the GNU General Public License
22 along with GNU Emacs; see the file COPYING. If not, write to
23 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
25 /* Rewritten by jwz */
30 #include <stdio.h> /* termhooks.h needs this */
31 #include "termhooks.h"
33 #include "xterm.h" /* for all of the X includes */
34 #include "dispextern.h" /* frame.h seems to want this */
35 #include "frame.h" /* Need this to get the X window of selected_frame */
36 #include "blockinput.h"
40 #define CUT_BUFFER_SUPPORT
42 static Atom Xatom_CLIPBOARD
, Xatom_TIMESTAMP
, Xatom_TEXT
, Xatom_DELETE
,
43 Xatom_MULTIPLE
, Xatom_INCR
, Xatom_EMACS_TMP
, Xatom_TARGETS
, Xatom_NULL
,
46 Lisp_Object QPRIMARY
, QSECONDARY
, QSTRING
, QINTEGER
, QCLIPBOARD
, QTIMESTAMP
,
47 QTEXT
, QDELETE
, QMULTIPLE
, QINCR
, QEMACS_TMP
, QTARGETS
, QATOM
, QNULL
,
50 #ifdef CUT_BUFFER_SUPPORT
51 Lisp_Object QCUT_BUFFER0
, QCUT_BUFFER1
, QCUT_BUFFER2
, QCUT_BUFFER3
,
52 QCUT_BUFFER4
, QCUT_BUFFER5
, QCUT_BUFFER6
, QCUT_BUFFER7
;
55 Lisp_Object Vx_lost_selection_hooks
;
56 Lisp_Object Vx_sent_selection_hooks
;
58 /* If this is a smaller number than the max-request-size of the display,
59 emacs will use INCR selection transfer when the selection is larger
60 than this. The max-request-size is usually around 64k, so if you want
61 emacs to use incremental selection transfers when the selection is
62 smaller than that, set this. I added this mostly for debugging the
63 incremental transfer stuff, but it might improve server performance.
65 #define MAX_SELECTION_QUANTUM 0xFFFFFF
68 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
70 #define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
73 /* The timestamp of the last input event Emacs received from the X server. */
74 unsigned long last_event_timestamp
;
76 /* This is an association list whose elements are of the form
77 ( selection-name selection-value selection-timestamp )
78 selection-name is a lisp symbol, whose name is the name of an X Atom.
79 selection-value is the value that emacs owns for that selection.
80 It may be any kind of Lisp object.
81 selection-timestamp is the time at which emacs began owning this selection,
82 as a cons of two 16-bit numbers (making a 32 bit time.)
83 If there is an entry in this alist, then it can be assumed that emacs owns
85 The only (eq) parts of this list that are visible from Lisp are the
88 Lisp_Object Vselection_alist
;
90 /* This is an alist whose CARs are selection-types (whose names are the same
91 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
92 call to convert the given Emacs selection value to a string representing
93 the given selection type. This is for Lisp-level extension of the emacs
96 Lisp_Object Vselection_converter_alist
;
98 /* If the selection owner takes too long to reply to a selection request,
99 we give up on it. This is in seconds (0 = no timeout.)
101 int x_selection_timeout
;
104 /* Utility functions */
106 static void lisp_data_to_selection_data ();
107 static Lisp_Object
selection_data_to_lisp_data ();
108 static Lisp_Object
x_get_window_property_as_lisp_data ();
110 static int expect_property_change ();
111 static void wait_for_property_change ();
112 static void unexpect_property_change ();
113 static int waiting_for_other_props_on_window ();
115 /* This converts a Lisp symbol to a server Atom, avoiding a server
116 roundtrip whenever possible. */
119 symbol_to_x_atom (display
, sym
)
124 if (NILP (sym
)) return 0;
125 if (EQ (sym
, QPRIMARY
)) return XA_PRIMARY
;
126 if (EQ (sym
, QSECONDARY
)) return XA_SECONDARY
;
127 if (EQ (sym
, QSTRING
)) return XA_STRING
;
128 if (EQ (sym
, QINTEGER
)) return XA_INTEGER
;
129 if (EQ (sym
, QATOM
)) return XA_ATOM
;
130 if (EQ (sym
, QCLIPBOARD
)) return Xatom_CLIPBOARD
;
131 if (EQ (sym
, QTIMESTAMP
)) return Xatom_TIMESTAMP
;
132 if (EQ (sym
, QTEXT
)) return Xatom_TEXT
;
133 if (EQ (sym
, QDELETE
)) return Xatom_DELETE
;
134 if (EQ (sym
, QMULTIPLE
)) return Xatom_MULTIPLE
;
135 if (EQ (sym
, QINCR
)) return Xatom_INCR
;
136 if (EQ (sym
, QEMACS_TMP
)) return Xatom_EMACS_TMP
;
137 if (EQ (sym
, QTARGETS
)) return Xatom_TARGETS
;
138 if (EQ (sym
, QNULL
)) return Xatom_NULL
;
139 #ifdef CUT_BUFFER_SUPPORT
140 if (EQ (sym
, QCUT_BUFFER0
)) return XA_CUT_BUFFER0
;
141 if (EQ (sym
, QCUT_BUFFER1
)) return XA_CUT_BUFFER1
;
142 if (EQ (sym
, QCUT_BUFFER2
)) return XA_CUT_BUFFER2
;
143 if (EQ (sym
, QCUT_BUFFER3
)) return XA_CUT_BUFFER3
;
144 if (EQ (sym
, QCUT_BUFFER4
)) return XA_CUT_BUFFER4
;
145 if (EQ (sym
, QCUT_BUFFER5
)) return XA_CUT_BUFFER5
;
146 if (EQ (sym
, QCUT_BUFFER6
)) return XA_CUT_BUFFER6
;
147 if (EQ (sym
, QCUT_BUFFER7
)) return XA_CUT_BUFFER7
;
149 if (!SYMBOLP (sym
)) abort ();
152 fprintf (stderr
, " XInternAtom %s\n", (char *) XSYMBOL (sym
)->name
->data
);
155 val
= XInternAtom (display
, (char *) XSYMBOL (sym
)->name
->data
, False
);
161 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
162 and calls to intern whenever possible. */
165 x_atom_to_symbol (display
, atom
)
171 if (! atom
) return Qnil
;
184 #ifdef CUT_BUFFER_SUPPORT
204 if (atom
== Xatom_CLIPBOARD
)
206 if (atom
== Xatom_TIMESTAMP
)
208 if (atom
== Xatom_TEXT
)
210 if (atom
== Xatom_DELETE
)
212 if (atom
== Xatom_MULTIPLE
)
214 if (atom
== Xatom_INCR
)
216 if (atom
== Xatom_EMACS_TMP
)
218 if (atom
== Xatom_TARGETS
)
220 if (atom
== Xatom_NULL
)
224 str
= XGetAtomName (display
, atom
);
227 fprintf (stderr
, " XGetAtomName --> %s\n", str
);
229 if (! str
) return Qnil
;
237 /* Do protocol to assert ourself as a selection owner.
238 Update the Vselection_alist so that we can reply to later requests for
242 x_own_selection (selection_name
, selection_value
)
243 Lisp_Object selection_name
, selection_value
;
245 Display
*display
= x_current_display
;
247 Window selecting_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
249 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
251 Time time
= last_event_timestamp
;
254 CHECK_SYMBOL (selection_name
, 0);
255 selection_atom
= symbol_to_x_atom (display
, selection_name
);
258 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
261 /* Now update the local cache */
263 Lisp_Object selection_time
;
264 Lisp_Object selection_data
;
265 Lisp_Object prev_value
;
267 selection_time
= long_to_cons ((unsigned long) time
);
268 selection_data
= Fcons (selection_name
,
269 Fcons (selection_value
,
270 Fcons (selection_time
, Qnil
)));
271 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
273 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
275 /* If we already owned the selection, remove the old selection data.
276 Perhaps we should destructively modify it instead.
277 Don't use Fdelq as that may QUIT. */
278 if (!NILP (prev_value
))
280 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
281 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
282 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
284 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
291 /* Given a selection-name and desired type, look up our local copy of
292 the selection value and convert it to the type.
293 The value is nil or a string.
294 This function is used both for remote requests
295 and for local x-get-selection-internal.
297 This calls random Lisp code, and may signal or gc. */
300 x_get_local_selection (selection_symbol
, target_type
)
301 Lisp_Object selection_symbol
, target_type
;
303 Lisp_Object local_value
;
304 Lisp_Object handler_fn
, value
, type
, check
;
307 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
309 if (NILP (local_value
)) return Qnil
;
311 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
312 if (EQ (target_type
, QTIMESTAMP
))
315 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
318 else if (EQ (target_type
, QDELETE
))
321 Fx_disown_selection_internal
323 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
328 #if 0 /* #### MULTIPLE doesn't work yet */
329 else if (CONSP (target_type
)
330 && XCONS (target_type
)->car
== QMULTIPLE
)
332 Lisp_Object pairs
= XCONS (target_type
)->cdr
;
333 int size
= XVECTOR (pairs
)->size
;
335 /* If the target is MULTIPLE, then target_type looks like
336 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
337 We modify the second element of each pair in the vector and
338 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
340 for (i
= 0; i
< size
; i
++)
342 Lisp_Object pair
= XVECTOR (pairs
)->contents
[i
];
343 XVECTOR (pair
)->contents
[1]
344 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
345 XVECTOR (pair
)->contents
[1]);
352 /* Don't allow a quit within the converter.
353 When the user types C-g, he would be surprised
354 if by luck it came during a converter. */
355 count
= specpdl_ptr
- specpdl
;
356 specbind (Qinhibit_quit
, Qt
);
358 CHECK_SYMBOL (target_type
, 0);
359 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
360 if (NILP (handler_fn
))
362 Fcons (build_string ("missing selection-conversion function"),
363 Fcons (target_type
, Fcons (value
, Qnil
))));
364 value
= call3 (handler_fn
,
365 selection_symbol
, target_type
,
366 XCONS (XCONS (local_value
)->cdr
)->car
);
367 unbind_to (count
, Qnil
);
370 /* Make sure this value is of a type that we could transmit
371 to another X client. */
375 && SYMBOLP (XCONS (value
)->car
))
376 type
= XCONS (value
)->car
,
377 check
= XCONS (value
)->cdr
;
385 /* Check for a value that cons_to_long could handle. */
386 else if (CONSP (check
)
387 && INTEGERP (XCONS (check
)->car
)
388 && (INTEGERP (XCONS (check
)->cdr
)
390 (CONSP (XCONS (check
)->cdr
)
391 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
392 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
397 Fcons (build_string ("invalid data returned by selection-conversion function"),
398 Fcons (handler_fn
, Fcons (value
, Qnil
))));
401 /* Subroutines of x_reply_selection_request. */
403 /* Send a SelectionNotify event to the requestor with property=None,
404 meaning we were unable to do what they wanted. */
407 x_decline_selection_request (event
)
408 struct input_event
*event
;
410 XSelectionEvent reply
;
411 reply
.type
= SelectionNotify
;
412 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
413 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
414 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
415 reply
.time
= SELECTION_EVENT_TIME (event
);
416 reply
.target
= SELECTION_EVENT_TARGET (event
);
417 reply
.property
= None
;
420 (void) XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
425 /* This is the selection request currently being processed.
426 It is set to zero when the request is fully processed. */
427 static struct input_event
*x_selection_current_request
;
429 /* Used as an unwind-protect clause so that, if a selection-converter signals
430 an error, we tell the requestor that we were unable to do what they wanted
431 before we throw to top-level or go into the debugger or whatever. */
434 x_selection_request_lisp_error (ignore
)
437 if (x_selection_current_request
!= 0)
438 x_decline_selection_request (x_selection_current_request
);
442 /* Send the reply to a selection request event EVENT.
443 TYPE is the type of selection data requested.
444 DATA and SIZE describe the data to send, already converted.
445 FORMAT is the unit-size (in bits) of the data to be transmitted. */
448 x_reply_selection_request (event
, format
, data
, size
, type
)
449 struct input_event
*event
;
454 XSelectionEvent reply
;
455 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
456 Window window
= SELECTION_EVENT_REQUESTOR (event
);
458 int format_bytes
= format
/8;
459 int max_bytes
= SELECTION_QUANTUM (display
);
461 if (max_bytes
> MAX_SELECTION_QUANTUM
)
462 max_bytes
= MAX_SELECTION_QUANTUM
;
464 reply
.type
= SelectionNotify
;
465 reply
.display
= display
;
466 reply
.requestor
= window
;
467 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
468 reply
.time
= SELECTION_EVENT_TIME (event
);
469 reply
.target
= SELECTION_EVENT_TARGET (event
);
470 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
471 if (reply
.property
== None
)
472 reply
.property
= reply
.target
;
474 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
477 /* Store the data on the requested property.
478 If the selection is large, only store the first N bytes of it.
480 bytes_remaining
= size
* format_bytes
;
481 if (bytes_remaining
<= max_bytes
)
483 /* Send all the data at once, with minimal handshaking. */
485 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
487 XChangeProperty (display
, window
, reply
.property
, type
, format
,
488 PropModeReplace
, data
, size
);
489 /* At this point, the selection was successfully stored; ack it. */
490 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
494 /* Send an INCR selection. */
497 if (x_window_to_frame (window
)) /* #### debug */
498 error ("attempt to transfer an INCR to ourself!");
500 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
502 prop_id
= expect_property_change (display
, window
, reply
.property
,
505 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
506 32, PropModeReplace
, (unsigned char *)
507 &bytes_remaining
, 1);
508 XSelectInput (display
, window
, PropertyChangeMask
);
509 /* Tell 'em the INCR data is there... */
510 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
512 /* First, wait for the requestor to ack by deleting the property.
513 This can run random lisp code (process handlers) or signal. */
514 wait_for_property_change (prop_id
);
516 while (bytes_remaining
)
518 int i
= ((bytes_remaining
< max_bytes
)
521 prop_id
= expect_property_change (display
, window
, reply
.property
,
524 fprintf (stderr
," INCR adding %d\n", i
);
526 /* Append the next chunk of data to the property. */
527 XChangeProperty (display
, window
, reply
.property
, type
, format
,
528 PropModeAppend
, data
, i
/ format_bytes
);
529 bytes_remaining
-= i
;
532 /* Now wait for the requestor to ack this chunk by deleting the
533 property. This can run random lisp code or signal.
535 wait_for_property_change (prop_id
);
537 /* Now write a zero-length chunk to the property to tell the requestor
540 fprintf (stderr
," INCR done\n");
542 if (! waiting_for_other_props_on_window (display
, window
))
543 XSelectInput (display
, window
, 0L);
545 XChangeProperty (display
, window
, reply
.property
, type
, format
,
546 PropModeReplace
, data
, 0);
551 /* Handle a SelectionRequest event EVENT.
552 This is called from keyboard.c when such an event is found in the queue. */
555 x_handle_selection_request (event
)
556 struct input_event
*event
;
558 struct gcpro gcpro1
, gcpro2
, gcpro3
;
559 XSelectionEvent reply
;
560 Lisp_Object local_selection_data
= Qnil
;
561 Lisp_Object selection_symbol
;
562 Lisp_Object target_symbol
= Qnil
;
563 Lisp_Object converted_selection
= Qnil
;
564 Time local_selection_time
;
565 Lisp_Object successful_p
= Qnil
;
568 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
570 reply
.type
= SelectionNotify
; /* Construct the reply event */
571 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
572 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
573 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
574 reply
.time
= SELECTION_EVENT_TIME (event
);
575 reply
.target
= SELECTION_EVENT_TARGET (event
);
576 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
577 if (reply
.property
== None
)
578 reply
.property
= reply
.target
;
580 selection_symbol
= x_atom_to_symbol (reply
.display
,
581 SELECTION_EVENT_SELECTION (event
));
583 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
586 # define CDR(x) (XCONS (x)->cdr)
587 # define CAR(x) (XCONS (x)->car)
588 /* This list isn't user-visible, so it can't "go bad." */
589 if (!CONSP (local_selection_data
)) abort ();
590 if (!CONSP (CDR (local_selection_data
))) abort ();
591 if (!CONSP (CDR (CDR (local_selection_data
)))) abort ();
592 if (!NILP (CDR (CDR (CDR (local_selection_data
))))) abort ();
593 if (!CONSP (CAR (CDR (CDR (local_selection_data
))))) abort ();
594 if (!INTEGERP (CAR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
595 if (!INTEGERP (CDR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
600 if (NILP (local_selection_data
))
602 /* Someone asked for the selection, but we don't have it any more.
604 x_decline_selection_request (event
);
608 local_selection_time
= (Time
)
609 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
611 if (SELECTION_EVENT_TIME (event
) != CurrentTime
612 && local_selection_time
> SELECTION_EVENT_TIME (event
))
614 /* Someone asked for the selection, and we have one, but not the one
617 x_decline_selection_request (event
);
621 count
= specpdl_ptr
- specpdl
;
622 x_selection_current_request
= event
;
623 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
625 target_symbol
= x_atom_to_symbol (reply
.display
,
626 SELECTION_EVENT_TARGET (event
));
628 #if 0 /* #### MULTIPLE doesn't work yet */
629 if (EQ (target_symbol
, QMULTIPLE
))
630 target_symbol
= fetch_multiple_target (event
);
633 /* Convert lisp objects back into binary data */
636 = x_get_local_selection (selection_symbol
, target_symbol
);
638 if (! NILP (converted_selection
))
644 lisp_data_to_selection_data (reply
.display
, converted_selection
,
645 &data
, &type
, &size
, &format
);
647 x_reply_selection_request (event
, format
, data
, size
, type
);
650 /* Indicate we have successfully processed this event. */
651 x_selection_current_request
= 0;
655 unbind_to (count
, Qnil
);
661 /* Let random lisp code notice that the selection has been asked for. */
663 Lisp_Object rest
= Vx_sent_selection_hooks
;
664 if (!EQ (rest
, Qunbound
))
665 for (; CONSP (rest
); rest
= Fcdr (rest
))
666 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
670 /* Handle a SelectionClear event EVENT, which indicates that some other
671 client cleared out our previously asserted selection.
672 This is called from keyboard.c when such an event is found in the queue. */
675 x_handle_selection_clear (event
)
676 struct input_event
*event
;
678 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
679 Atom selection
= SELECTION_EVENT_SELECTION (event
);
680 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
682 Lisp_Object selection_symbol
, local_selection_data
;
683 Time local_selection_time
;
685 selection_symbol
= x_atom_to_symbol (display
, selection
);
687 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
689 /* Well, we already believe that we don't own it, so that's just fine. */
690 if (NILP (local_selection_data
)) return;
692 local_selection_time
= (Time
)
693 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
695 /* This SelectionClear is for a selection that we no longer own, so we can
696 disregard it. (That is, we have reasserted the selection since this
697 request was generated.) */
699 if (changed_owner_time
!= CurrentTime
700 && local_selection_time
> changed_owner_time
)
703 /* Otherwise, we're really honest and truly being told to drop it.
704 Don't use Fdelq as that may QUIT;. */
706 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
707 Vselection_alist
= Fcdr (Vselection_alist
);
711 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
712 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
714 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
719 /* Let random lisp code notice that the selection has been stolen. */
722 Lisp_Object rest
= Vx_lost_selection_hooks
;
723 if (!EQ (rest
, Qunbound
))
724 for (; CONSP (rest
); rest
= Fcdr (rest
))
725 call1 (Fcar (rest
), selection_symbol
);
730 /* This stuff is so that INCR selections are reentrant (that is, so we can
731 be servicing multiple INCR selection requests simultaneously.) I haven't
732 actually tested that yet. */
734 static int prop_location_tick
;
736 static Lisp_Object property_change_reply
;
737 static int property_change_reply_tick
;
739 /* Keep a list of the property changes that are awaited. */
748 struct prop_location
*next
;
751 static struct prop_location
*property_change_wait_list
;
754 property_deleted_p (tick
)
757 struct prop_location
*rest
= property_change_wait_list
;
759 if (rest
->tick
== (int) tick
)
766 /* Nonzero if any properties for DISPLAY and WINDOW
767 are on the list of what we are waiting for. */
770 waiting_for_other_props_on_window (display
, window
)
774 struct prop_location
*rest
= property_change_wait_list
;
776 if (rest
->display
== display
&& rest
->window
== window
)
783 /* Add an entry to the list of property changes we are waiting for.
784 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
785 The return value is a number that uniquely identifies
786 this awaited property change. */
789 expect_property_change (display
, window
, property
, state
)
792 Lisp_Object property
;
795 struct prop_location
*pl
796 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
797 pl
->tick
= ++prop_location_tick
;
798 pl
->display
= display
;
800 pl
->property
= property
;
801 pl
->desired_state
= state
;
802 pl
->next
= property_change_wait_list
;
803 property_change_wait_list
= pl
;
807 /* Delete an entry from the list of property changes we are waiting for.
808 TICK is the number that uniquely identifies the entry. */
811 unexpect_property_change (tick
)
814 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
817 if (rest
->tick
== tick
)
820 prev
->next
= rest
->next
;
822 property_change_wait_list
= rest
->next
;
831 /* Actually wait for a property change.
832 TICK should be the value that expect_property_change returned. */
835 wait_for_property_change (tick
)
837 XCONS (property_change_reply
)->car
= Qnil
;
838 property_change_reply_tick
= tick
;
839 wait_reading_process_input (0, 0, property_change_reply
, 0);
842 /* Called from XTread_socket in response to a PropertyNotify event. */
845 x_handle_property_notify (event
)
846 XPropertyEvent
*event
;
848 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
851 if (rest
->property
== event
->atom
852 && rest
->window
== event
->window
853 && rest
->display
== event
->display
854 && rest
->desired_state
== event
->state
)
857 fprintf (stderr
, "Saw expected prop-%s on %s\n",
858 (event
->state
== PropertyDelete
? "delete" : "change"),
859 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
864 /* If this is the one wait_for_property_change is waiting for,
865 tell it to wake up. */
866 if (rest
->tick
== property_change_reply_tick
)
867 XCONS (property_change_reply
)->car
= Qt
;
870 prev
->next
= rest
->next
;
872 property_change_wait_list
= rest
->next
;
880 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
881 (event
->state
== PropertyDelete
? "delete" : "change"),
882 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
889 #if 0 /* #### MULTIPLE doesn't work yet */
892 fetch_multiple_target (event
)
893 XSelectionRequestEvent
*event
;
895 Display
*display
= event
->display
;
896 Window window
= event
->requestor
;
897 Atom target
= event
->target
;
898 Atom selection_atom
= event
->selection
;
903 x_get_window_property_as_lisp_data (display
, window
, target
,
904 QMULTIPLE
, selection_atom
));
908 copy_multiple_data (obj
)
915 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
917 CHECK_VECTOR (obj
, 0);
918 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
919 for (i
= 0; i
< size
; i
++)
921 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
922 CHECK_VECTOR (vec2
, 0);
923 if (XVECTOR (vec2
)->size
!= 2)
924 /* ??? Confusing error message */
925 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
926 Fcons (vec2
, Qnil
)));
927 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
928 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
929 = XVECTOR (vec2
)->contents
[0];
930 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
931 = XVECTOR (vec2
)->contents
[1];
939 /* Variables for communication with x_handle_selection_notify. */
940 static Atom reading_which_selection
;
941 static Lisp_Object reading_selection_reply
;
942 static Window reading_selection_window
;
944 /* Do protocol to read selection-data from the server.
945 Converts this to Lisp data and returns it. */
948 x_get_foreign_selection (selection_symbol
, target_type
)
949 Lisp_Object selection_symbol
, target_type
;
951 Display
*display
= x_current_display
;
953 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
955 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
957 Time requestor_time
= last_event_timestamp
;
958 Atom target_property
= Xatom_EMACS_TMP
;
959 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
962 if (CONSP (target_type
))
963 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
965 type_atom
= symbol_to_x_atom (display
, target_type
);
968 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
969 requestor_window
, requestor_time
);
972 /* Prepare to block until the reply has been read. */
973 reading_selection_window
= requestor_window
;
974 reading_which_selection
= selection_atom
;
975 XCONS (reading_selection_reply
)->car
= Qnil
;
978 /* This allows quits. */
979 wait_reading_process_input (x_selection_timeout
, 0,
980 reading_selection_reply
, 0);
982 if (NILP (XCONS (reading_selection_reply
)->car
))
983 error ("timed out waiting for reply from selection owner");
985 /* Otherwise, the selection is waiting for us on the requested property. */
987 x_get_window_property_as_lisp_data (display
, requestor_window
,
988 target_property
, target_type
,
992 /* Subroutines of x_get_window_property_as_lisp_data */
995 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
996 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1001 unsigned char **data_ret
;
1003 Atom
*actual_type_ret
;
1004 int *actual_format_ret
;
1005 unsigned long *actual_size_ret
;
1009 unsigned long bytes_remaining
;
1011 unsigned char *tmp_data
= 0;
1013 int buffer_size
= SELECTION_QUANTUM (display
);
1014 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1017 /* First probe the thing to find out how big it is. */
1018 result
= XGetWindowProperty (display
, window
, property
,
1019 0, 0, False
, AnyPropertyType
,
1020 actual_type_ret
, actual_format_ret
,
1022 &bytes_remaining
, &tmp_data
);
1024 if (result
!= Success
)
1031 XFree ((char *) tmp_data
);
1034 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1036 if (delete_p
) XDeleteProperty (display
, window
, property
);
1040 total_size
= bytes_remaining
+ 1;
1041 *data_ret
= (unsigned char *) xmalloc (total_size
);
1043 /* Now read, until weve gotten it all. */
1045 while (bytes_remaining
)
1048 int last
= bytes_remaining
;
1051 = XGetWindowProperty (display
, window
, property
,
1052 offset
/4, buffer_size
/4,
1053 (delete_p
? True
: False
),
1055 actual_type_ret
, actual_format_ret
,
1056 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1058 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1060 /* If this doesn't return Success at this point, it means that
1061 some clod deleted the selection while we were in the midst of
1062 reading it. Deal with that, I guess....
1064 if (result
!= Success
) break;
1065 *actual_size_ret
*= *actual_format_ret
/ 8;
1066 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1067 offset
+= *actual_size_ret
;
1068 XFree ((char *) tmp_data
);
1071 *bytes_ret
= offset
;
1075 receive_incremental_selection (display
, window
, property
, target_type
,
1076 min_size_bytes
, data_ret
, size_bytes_ret
,
1077 type_ret
, format_ret
, size_ret
)
1081 Lisp_Object target_type
; /* for error messages only */
1082 unsigned int min_size_bytes
;
1083 unsigned char **data_ret
;
1084 int *size_bytes_ret
;
1086 unsigned long *size_ret
;
1091 *size_bytes_ret
= min_size_bytes
;
1092 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1094 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1096 /* At this point, we have read an INCR property, and deleted it (which
1097 is how we ack its receipt: the sending window will be selecting
1098 PropertyNotify events on our window to notice this.)
1100 Now, we must loop, waiting for the sending window to put a value on
1101 that property, then reading the property, then deleting it to ack.
1102 We are done when the sender places a property of length 0.
1104 prop_id
= expect_property_change (display
, window
, property
,
1108 unsigned char *tmp_data
;
1110 wait_for_property_change (prop_id
);
1111 /* expect it again immediately, because x_get_window_property may
1112 .. no it wont, I dont get it.
1113 .. Ok, I get it now, the Xt code that implements INCR is broken.
1115 prop_id
= expect_property_change (display
, window
, property
,
1117 x_get_window_property (display
, window
, property
,
1118 &tmp_data
, &tmp_size_bytes
,
1119 type_ret
, format_ret
, size_ret
, 1);
1121 if (tmp_size_bytes
== 0) /* we're done */
1124 fprintf (stderr
, " read INCR done\n");
1126 unexpect_property_change (prop_id
);
1127 if (tmp_data
) xfree (tmp_data
);
1131 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1133 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1136 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1137 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1139 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1140 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1142 memcpy ((*data_ret
) + offset
, tmp_data
, tmp_size_bytes
);
1143 offset
+= tmp_size_bytes
;
1148 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1149 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1150 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1153 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1158 Lisp_Object target_type
; /* for error messages only */
1159 Atom selection_atom
; /* for error messages only */
1163 unsigned long actual_size
;
1164 unsigned char *data
= 0;
1168 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1169 &actual_type
, &actual_format
, &actual_size
, 1);
1172 int there_is_a_selection_owner
;
1174 there_is_a_selection_owner
1175 = XGetSelectionOwner (display
, selection_atom
);
1177 while (1) /* Note debugger can no longer return, so this is obsolete */
1179 there_is_a_selection_owner
?
1180 Fcons (build_string ("selection owner couldn't convert"),
1182 ? Fcons (target_type
,
1183 Fcons (x_atom_to_symbol (display
, actual_type
),
1185 : Fcons (target_type
, Qnil
))
1186 : Fcons (build_string ("no selection"),
1187 Fcons (x_atom_to_symbol (display
, selection_atom
),
1191 if (actual_type
== Xatom_INCR
)
1193 /* That wasn't really the data, just the beginning. */
1195 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1197 XFree ((char *) data
);
1199 receive_incremental_selection (display
, window
, property
, target_type
,
1200 min_size_bytes
, &data
, &bytes
,
1201 &actual_type
, &actual_format
,
1205 /* It's been read. Now convert it to a lisp object in some semi-rational
1207 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1208 actual_type
, actual_format
);
1210 xfree ((char *) data
);
1214 /* These functions convert from the selection data read from the server into
1215 something that we can use from Lisp, and vice versa.
1217 Type: Format: Size: Lisp Type:
1218 ----- ------- ----- -----------
1221 ATOM 32 > 1 Vector of Symbols
1223 * 16 > 1 Vector of Integers
1224 * 32 1 if <=16 bits: Integer
1225 if > 16 bits: Cons of top16, bot16
1226 * 32 > 1 Vector of the above
1228 When converting a Lisp number to C, it is assumed to be of format 16 if
1229 it is an integer, and of format 32 if it is a cons of two integers.
1231 When converting a vector of numbers from Lisp to C, it is assumed to be
1232 of format 16 if every element in the vector is an integer, and is assumed
1233 to be of format 32 if any element is a cons of two integers.
1235 When converting an object to C, it may be of the form (SYMBOL . <data>)
1236 where SYMBOL is what we should claim that the type is. Format and
1237 representation are as above. */
1242 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1244 unsigned char *data
;
1249 if (type
== Xatom_NULL
)
1252 /* Convert any 8-bit data to a string, for compactness. */
1253 else if (format
== 8)
1254 return make_string ((char *) data
, size
);
1256 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1257 a vector of symbols.
1259 else if (type
== XA_ATOM
)
1262 if (size
== sizeof (Atom
))
1263 return x_atom_to_symbol (display
, *((Atom
*) data
));
1266 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1267 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1268 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1273 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1274 If the number is > 16 bits, convert it to a cons of integers,
1275 16 bits in each half.
1277 else if (format
== 32 && size
== sizeof (long))
1278 return long_to_cons (((unsigned long *) data
) [0]);
1279 else if (format
== 16 && size
== sizeof (short))
1280 return make_number ((int) (((unsigned short *) data
) [0]));
1282 /* Convert any other kind of data to a vector of numbers, represented
1283 as above (as an integer, or a cons of two 16 bit integers.)
1285 else if (format
== 16)
1288 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1289 for (i
= 0; i
< size
/ 4; i
++)
1291 int j
= (int) ((unsigned short *) data
) [i
];
1292 Faset (v
, i
, make_number (j
));
1299 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1300 for (i
= 0; i
< size
/ 4; i
++)
1302 unsigned long j
= ((unsigned long *) data
) [i
];
1303 Faset (v
, i
, long_to_cons (j
));
1311 lisp_data_to_selection_data (display
, obj
,
1312 data_ret
, type_ret
, size_ret
, format_ret
)
1315 unsigned char **data_ret
;
1317 unsigned int *size_ret
;
1320 Lisp_Object type
= Qnil
;
1321 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1323 type
= XCONS (obj
)->car
;
1324 obj
= XCONS (obj
)->cdr
;
1325 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1326 obj
= XCONS (obj
)->car
;
1329 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1330 { /* This is not the same as declining */
1336 else if (STRINGP (obj
))
1339 *size_ret
= XSTRING (obj
)->size
;
1340 *data_ret
= (unsigned char *) xmalloc (*size_ret
);
1341 memcpy (*data_ret
, (char *) XSTRING (obj
)->data
, *size_ret
);
1342 if (NILP (type
)) type
= QSTRING
;
1344 else if (SYMBOLP (obj
))
1348 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1349 (*data_ret
) [sizeof (Atom
)] = 0;
1350 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1351 if (NILP (type
)) type
= QATOM
;
1353 else if (INTEGERP (obj
)
1354 && XINT (obj
) < 0xFFFF
1355 && XINT (obj
) > -0xFFFF)
1359 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1360 (*data_ret
) [sizeof (short)] = 0;
1361 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1362 if (NILP (type
)) type
= QINTEGER
;
1364 else if (INTEGERP (obj
)
1365 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1366 && (INTEGERP (XCONS (obj
)->cdr
)
1367 || (CONSP (XCONS (obj
)->cdr
)
1368 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1372 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1373 (*data_ret
) [sizeof (long)] = 0;
1374 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1375 if (NILP (type
)) type
= QINTEGER
;
1377 else if (VECTORP (obj
))
1379 /* Lisp_Vectors may represent a set of ATOMs;
1380 a set of 16 or 32 bit INTEGERs;
1381 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1385 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1386 /* This vector is an ATOM set */
1388 if (NILP (type
)) type
= QATOM
;
1389 *size_ret
= XVECTOR (obj
)->size
;
1391 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1392 for (i
= 0; i
< *size_ret
; i
++)
1393 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1394 (*(Atom
**) data_ret
) [i
]
1395 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1397 Fsignal (Qerror
, /* Qselection_error */
1399 ("all elements of selection vector must have same type"),
1400 Fcons (obj
, Qnil
)));
1402 #if 0 /* #### MULTIPLE doesn't work yet */
1403 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1404 /* This vector is an ATOM_PAIR set */
1406 if (NILP (type
)) type
= QATOM_PAIR
;
1407 *size_ret
= XVECTOR (obj
)->size
;
1409 *data_ret
= (unsigned char *)
1410 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1411 for (i
= 0; i
< *size_ret
; i
++)
1412 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1414 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1415 if (XVECTOR (pair
)->size
!= 2)
1418 ("elements of the vector must be vectors of exactly two elements"),
1419 Fcons (pair
, Qnil
)));
1421 (*(Atom
**) data_ret
) [i
* 2]
1422 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1423 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1424 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1429 ("all elements of the vector must be of the same type"),
1430 Fcons (obj
, Qnil
)));
1435 /* This vector is an INTEGER set, or something like it */
1437 *size_ret
= XVECTOR (obj
)->size
;
1438 if (NILP (type
)) type
= QINTEGER
;
1440 for (i
= 0; i
< *size_ret
; i
++)
1441 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1443 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1444 Fsignal (Qerror
, /* Qselection_error */
1446 ("elements of selection vector must be integers or conses of integers"),
1447 Fcons (obj
, Qnil
)));
1449 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1450 for (i
= 0; i
< *size_ret
; i
++)
1451 if (*format_ret
== 32)
1452 (*((unsigned long **) data_ret
)) [i
]
1453 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1455 (*((unsigned short **) data_ret
)) [i
]
1456 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1460 Fsignal (Qerror
, /* Qselection_error */
1461 Fcons (build_string ("unrecognised selection data"),
1462 Fcons (obj
, Qnil
)));
1464 *type_ret
= symbol_to_x_atom (display
, type
);
1468 clean_local_selection_data (obj
)
1472 && INTEGERP (XCONS (obj
)->car
)
1473 && CONSP (XCONS (obj
)->cdr
)
1474 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1475 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1476 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1479 && INTEGERP (XCONS (obj
)->car
)
1480 && INTEGERP (XCONS (obj
)->cdr
))
1482 if (XINT (XCONS (obj
)->car
) == 0)
1483 return XCONS (obj
)->cdr
;
1484 if (XINT (XCONS (obj
)->car
) == -1)
1485 return make_number (- XINT (XCONS (obj
)->cdr
));
1490 int size
= XVECTOR (obj
)->size
;
1493 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1494 copy
= Fmake_vector (size
, Qnil
);
1495 for (i
= 0; i
< size
; i
++)
1496 XVECTOR (copy
)->contents
[i
]
1497 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1503 /* Called from XTread_socket to handle SelectionNotify events.
1504 If it's the selection we are waiting for, stop waiting. */
1507 x_handle_selection_notify (event
)
1508 XSelectionEvent
*event
;
1510 if (event
->requestor
!= reading_selection_window
)
1512 if (event
->selection
!= reading_which_selection
)
1515 XCONS (reading_selection_reply
)->car
= Qt
;
1519 DEFUN ("x-own-selection-internal",
1520 Fx_own_selection_internal
, Sx_own_selection_internal
,
1522 "Assert an X selection of the given TYPE with the given VALUE.\n\
1523 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1524 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1525 VALUE is typically a string, or a cons of two markers, but may be\n\
1526 anything that the functions on `selection-converter-alist' know about.")
1527 (selection_name
, selection_value
)
1528 Lisp_Object selection_name
, selection_value
;
1530 CHECK_SYMBOL (selection_name
, 0);
1531 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1532 x_own_selection (selection_name
, selection_value
);
1533 return selection_value
;
1537 /* Request the selection value from the owner. If we are the owner,
1538 simply return our selection value. If we are not the owner, this
1539 will block until all of the data has arrived. */
1541 DEFUN ("x-get-selection-internal",
1542 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1543 "Return text selected from some X window.\n\
1544 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1545 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1546 TYPE is the type of data desired, typically `STRING'.")
1547 (selection_symbol
, target_type
)
1548 Lisp_Object selection_symbol
, target_type
;
1550 Lisp_Object val
= Qnil
;
1551 struct gcpro gcpro1
, gcpro2
;
1552 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1553 CHECK_SYMBOL (selection_symbol
, 0);
1555 #if 0 /* #### MULTIPLE doesn't work yet */
1556 if (CONSP (target_type
)
1557 && XCONS (target_type
)->car
== QMULTIPLE
)
1559 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1560 /* So we don't destructively modify this... */
1561 target_type
= copy_multiple_data (target_type
);
1565 CHECK_SYMBOL (target_type
, 0);
1567 val
= x_get_local_selection (selection_symbol
, target_type
);
1571 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1576 && SYMBOLP (XCONS (val
)->car
))
1578 val
= XCONS (val
)->cdr
;
1579 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1580 val
= XCONS (val
)->car
;
1582 val
= clean_local_selection_data (val
);
1588 DEFUN ("x-disown-selection-internal",
1589 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1590 "If we own the selection SELECTION, disown it.\n\
1591 Disowning it means there is no such selection.")
1593 Lisp_Object selection
;
1596 Display
*display
= x_current_display
;
1598 Atom selection_atom
;
1599 XSelectionClearEvent event
;
1601 CHECK_SYMBOL (selection
, 0);
1603 timestamp
= last_event_timestamp
;
1605 timestamp
= cons_to_long (time
);
1607 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1608 return Qnil
; /* Don't disown the selection when we're not the owner. */
1610 selection_atom
= symbol_to_x_atom (display
, selection
);
1613 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1616 /* It doesn't seem to be guarenteed that a SelectionClear event will be
1617 generated for a window which owns the selection when that window sets
1618 the selection owner to None. The NCD server does, the MIT Sun4 server
1619 doesn't. So we synthesize one; this means we might get two, but
1620 that's ok, because the second one won't have any effect. */
1621 event
.display
= display
;
1622 event
.selection
= selection_atom
;
1623 event
.time
= timestamp
;
1624 x_handle_selection_clear (&event
);
1629 /* Get rid of all the selections in buffer BUFFER.
1630 This is used when we kill a buffer. */
1633 x_disown_buffer_selections (buffer
)
1637 struct buffer
*buf
= XBUFFER (buffer
);
1639 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1641 Lisp_Object elt
, value
;
1642 elt
= XCONS (tail
)->car
;
1643 value
= XCONS (elt
)->cdr
;
1644 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1645 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1646 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1650 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1652 "Whether the current Emacs process owns the given X Selection.\n\
1653 The arg should be the name of the selection in question, typically one of\n\
1654 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1655 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1656 For convenience, the symbol nil is the same as `PRIMARY',\n\
1657 and t is the same as `SECONDARY'.)")
1659 Lisp_Object selection
;
1661 CHECK_SYMBOL (selection
, 0);
1662 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1663 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1665 if (NILP (Fassq (selection
, Vselection_alist
)))
1670 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1672 "Whether there is an owner for the given X Selection.\n\
1673 The arg should be the name of the selection in question, typically one of\n\
1674 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1675 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1676 For convenience, the symbol nil is the same as `PRIMARY',\n\
1677 and t is the same as `SECONDARY'.)")
1679 Lisp_Object selection
;
1682 Display
*dpy
= x_current_display
;
1683 CHECK_SYMBOL (selection
, 0);
1684 if (!NILP (Fx_selection_owner_p (selection
)))
1687 owner
= XGetSelectionOwner (dpy
, symbol_to_x_atom (dpy
, selection
));
1689 return (owner
? Qt
: Qnil
);
1693 #ifdef CUT_BUFFER_SUPPORT
1695 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1697 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1699 initialize_cut_buffers (display
, window
)
1703 unsigned char *data
= (unsigned char *) "";
1705 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1706 PropModeAppend, data, 0)
1707 FROB (XA_CUT_BUFFER0
);
1708 FROB (XA_CUT_BUFFER1
);
1709 FROB (XA_CUT_BUFFER2
);
1710 FROB (XA_CUT_BUFFER3
);
1711 FROB (XA_CUT_BUFFER4
);
1712 FROB (XA_CUT_BUFFER5
);
1713 FROB (XA_CUT_BUFFER6
);
1714 FROB (XA_CUT_BUFFER7
);
1717 cut_buffers_initialized
= 1;
1721 #define CHECK_CUT_BUFFER(symbol,n) \
1722 { CHECK_SYMBOL ((symbol), (n)); \
1723 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1724 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1725 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1726 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1728 Fcons (build_string ("doesn't name a cut buffer"), \
1729 Fcons ((symbol), Qnil))); \
1732 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1733 Sx_get_cut_buffer_internal
, 1, 1, 0,
1734 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1738 Display
*display
= x_current_display
;
1739 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1741 unsigned char *data
;
1748 CHECK_CUT_BUFFER (buffer
, 0);
1749 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1751 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1752 &type
, &format
, &size
, 0);
1753 if (!data
) return Qnil
;
1755 if (format
!= 8 || type
!= XA_STRING
)
1757 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1758 Fcons (x_atom_to_symbol (display
, type
),
1759 Fcons (make_number (format
), Qnil
))));
1761 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1767 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1768 Sx_store_cut_buffer_internal
, 2, 2, 0,
1769 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1771 Lisp_Object buffer
, string
;
1773 Display
*display
= x_current_display
;
1774 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1776 unsigned char *data
;
1778 int bytes_remaining
;
1779 int max_bytes
= SELECTION_QUANTUM (display
);
1780 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1782 CHECK_CUT_BUFFER (buffer
, 0);
1783 CHECK_STRING (string
, 0);
1784 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1785 data
= (unsigned char *) XSTRING (string
)->data
;
1786 bytes
= XSTRING (string
)->size
;
1787 bytes_remaining
= bytes
;
1789 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1792 while (bytes_remaining
)
1794 int chunk
= (bytes_remaining
< max_bytes
1795 ? bytes_remaining
: max_bytes
);
1796 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1797 (bytes_remaining
== bytes
1802 bytes_remaining
-= chunk
;
1809 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1810 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1811 "Rotate the values of the cut buffers by the given number of steps;\n\
1812 positive means move values forward, negative means backward.")
1816 Display
*display
= x_current_display
;
1817 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1820 CHECK_NUMBER (n
, 0);
1821 if (XINT (n
) == 0) return n
;
1822 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1823 props
[0] = XA_CUT_BUFFER0
;
1824 props
[1] = XA_CUT_BUFFER1
;
1825 props
[2] = XA_CUT_BUFFER2
;
1826 props
[3] = XA_CUT_BUFFER3
;
1827 props
[4] = XA_CUT_BUFFER4
;
1828 props
[5] = XA_CUT_BUFFER5
;
1829 props
[6] = XA_CUT_BUFFER6
;
1830 props
[7] = XA_CUT_BUFFER7
;
1832 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1840 Xatoms_of_xselect ()
1842 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1845 /* Non-predefined atoms that we might end up using a lot */
1846 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1847 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1848 Xatom_TEXT
= ATOM ("TEXT");
1849 Xatom_DELETE
= ATOM ("DELETE");
1850 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1851 Xatom_INCR
= ATOM ("INCR");
1852 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1853 Xatom_TARGETS
= ATOM ("TARGETS");
1854 Xatom_NULL
= ATOM ("NULL");
1855 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1862 defsubr (&Sx_get_selection_internal
);
1863 defsubr (&Sx_own_selection_internal
);
1864 defsubr (&Sx_disown_selection_internal
);
1865 defsubr (&Sx_selection_owner_p
);
1866 defsubr (&Sx_selection_exists_p
);
1868 #ifdef CUT_BUFFER_SUPPORT
1869 defsubr (&Sx_get_cut_buffer_internal
);
1870 defsubr (&Sx_store_cut_buffer_internal
);
1871 defsubr (&Sx_rotate_cut_buffers_internal
);
1872 cut_buffers_initialized
= 0;
1875 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1876 staticpro (&reading_selection_reply
);
1877 reading_selection_window
= 0;
1878 reading_which_selection
= 0;
1880 property_change_wait_list
= 0;
1881 prop_location_tick
= 0;
1882 property_change_reply
= Fcons (Qnil
, Qnil
);
1883 staticpro (&property_change_reply
);
1885 Vselection_alist
= Qnil
;
1886 staticpro (&Vselection_alist
);
1888 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1889 "An alist associating X Windows selection-types with functions.\n\
1890 These functions are called to convert the selection, with three args:\n\
1891 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1892 a desired type to which the selection should be converted;\n\
1893 and the local selection value (whatever was given to `x-own-selection').\n\
1895 The function should return the value to send to the X server\n\
1896 \(typically a string). A return value of nil\n\
1897 means that the conversion could not be done.\n\
1898 A return value which is the symbol `NULL'\n\
1899 means that a side-effect was executed,\n\
1900 and there is no meaningful selection value.");
1901 Vselection_converter_alist
= Qnil
;
1903 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1904 "A list of functions to be called when Emacs loses an X selection.\n\
1905 \(This happens when some other X client makes its own selection\n\
1906 or when a Lisp program explicitly clears the selection.)\n\
1907 The functions are called with one argument, the selection type\n\
1908 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1909 Vx_lost_selection_hooks
= Qnil
;
1911 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1912 "A list of functions to be called when Emacs answers a selection request.\n\
1913 The functions are called with four arguments:\n\
1914 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1915 - the selection-type which Emacs was asked to convert the\n\
1916 selection into before sending (for example, `STRING' or `LENGTH');\n\
1917 - a flag indicating success or failure for responding to the request.\n\
1918 We might have failed (and declined the request) for any number of reasons,\n\
1919 including being asked for a selection that we no longer own, or being asked\n\
1920 to convert into a type that we don't know about or that is inappropriate.\n\
1921 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
1922 it merely informs you that they have happened.");
1923 Vx_sent_selection_hooks
= Qnil
;
1925 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
1926 "Number of seconds to wait for a selection reply from another X client.\n\
1927 If the selection owner doens't reply in this many seconds, we give up.\n\
1928 A value of 0 means wait as long as necessary. This is initialized from the\n\
1929 \"*selectionTimeout\" resource (which is expressed in milliseconds).");
1930 x_selection_timeout
= 0;
1932 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
1933 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
1934 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
1935 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
1936 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
1937 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1938 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
1939 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1940 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
1941 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
1942 QINCR
= intern ("INCR"); staticpro (&QINCR
);
1943 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
1944 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
1945 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
1946 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
1947 QNULL
= intern ("NULL"); staticpro (&QNULL
);
1949 #ifdef CUT_BUFFER_SUPPORT
1950 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
1951 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
1952 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
1953 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
1954 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
1955 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
1956 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
1957 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);