1 /* X Selection processing for emacs
2 Copyright (C) 1993 Free Software Foundation.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
20 /* x_handle_selection_notify
21 x_reply_selection_request */
24 /* Rewritten by jwz */
29 #include <stdio.h> /* termhooks.h needs this */
30 #include "termhooks.h"
32 #include "xterm.h" /* for all of the X includes */
33 #include "dispextern.h" /* frame.h seems to want this */
34 #include "frame.h" /* Need this to get the X window of selected_frame */
35 #include "blockinput.h"
39 #define CUT_BUFFER_SUPPORT
41 static Atom Xatom_CLIPBOARD
, Xatom_TIMESTAMP
, Xatom_TEXT
, Xatom_DELETE
,
42 Xatom_MULTIPLE
, Xatom_INCR
, Xatom_EMACS_TMP
, Xatom_TARGETS
, Xatom_NULL
,
45 Lisp_Object QPRIMARY
, QSECONDARY
, QSTRING
, QINTEGER
, QCLIPBOARD
, QTIMESTAMP
,
46 QTEXT
, QDELETE
, QMULTIPLE
, QINCR
, QEMACS_TMP
, QTARGETS
, QATOM
, QNULL
,
49 #ifdef CUT_BUFFER_SUPPORT
50 Lisp_Object QCUT_BUFFER0
, QCUT_BUFFER1
, QCUT_BUFFER2
, QCUT_BUFFER3
,
51 QCUT_BUFFER4
, QCUT_BUFFER5
, QCUT_BUFFER6
, QCUT_BUFFER7
;
54 Lisp_Object Vx_lost_selection_hooks
;
55 Lisp_Object Vx_sent_selection_hooks
;
57 /* If this is a smaller number than the max-request-size of the display,
58 emacs will use INCR selection transfer when the selection is larger
59 than this. The max-request-size is usually around 64k, so if you want
60 emacs to use incremental selection transfers when the selection is
61 smaller than that, set this. I added this mostly for debugging the
62 incremental transfer stuff, but it might improve server performance.
64 #define MAX_SELECTION_QUANTUM 0xFFFFFF
67 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
69 #define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
72 /* The timestamp of the last input event Emacs received from the X server. */
73 unsigned long last_event_timestamp
;
75 /* This is an association list whose elements are of the form
76 ( selection-name selection-value selection-timestamp )
77 selection-name is a lisp symbol, whose name is the name of an X Atom.
78 selection-value is the value that emacs owns for that selection.
79 It may be any kind of Lisp object.
80 selection-timestamp is the time at which emacs began owning this selection,
81 as a cons of two 16-bit numbers (making a 32 bit time.)
82 If there is an entry in this alist, then it can be assumed that emacs owns
84 The only (eq) parts of this list that are visible from Lisp are the
87 Lisp_Object Vselection_alist
;
89 /* This is an alist whose CARs are selection-types (whose names are the same
90 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
91 call to convert the given Emacs selection value to a string representing
92 the given selection type. This is for Lisp-level extension of the emacs
95 Lisp_Object Vselection_converter_alist
;
97 /* If the selection owner takes too long to reply to a selection request,
98 we give up on it. This is in milliseconds (0 = no timeout.)
100 int x_selection_timeout
;
103 /* Utility functions */
105 static void lisp_data_to_selection_data ();
106 static Lisp_Object
selection_data_to_lisp_data ();
107 static Lisp_Object
x_get_window_property_as_lisp_data ();
109 static int expect_property_change ();
110 static void wait_for_property_change ();
111 static void unexpect_property_change ();
112 static int waiting_for_other_props_on_window ();
114 /* This converts a Lisp symbol to a server Atom, avoiding a server
115 roundtrip whenever possible. */
118 symbol_to_x_atom (display
, sym
)
123 if (NILP (sym
)) return 0;
124 if (EQ (sym
, QPRIMARY
)) return XA_PRIMARY
;
125 if (EQ (sym
, QSECONDARY
)) return XA_SECONDARY
;
126 if (EQ (sym
, QSTRING
)) return XA_STRING
;
127 if (EQ (sym
, QINTEGER
)) return XA_INTEGER
;
128 if (EQ (sym
, QATOM
)) return XA_ATOM
;
129 if (EQ (sym
, QCLIPBOARD
)) return Xatom_CLIPBOARD
;
130 if (EQ (sym
, QTIMESTAMP
)) return Xatom_TIMESTAMP
;
131 if (EQ (sym
, QTEXT
)) return Xatom_TEXT
;
132 if (EQ (sym
, QDELETE
)) return Xatom_DELETE
;
133 if (EQ (sym
, QMULTIPLE
)) return Xatom_MULTIPLE
;
134 if (EQ (sym
, QINCR
)) return Xatom_INCR
;
135 if (EQ (sym
, QEMACS_TMP
)) return Xatom_EMACS_TMP
;
136 if (EQ (sym
, QTARGETS
)) return Xatom_TARGETS
;
137 if (EQ (sym
, QNULL
)) return Xatom_NULL
;
138 #ifdef CUT_BUFFER_SUPPORT
139 if (EQ (sym
, QCUT_BUFFER0
)) return XA_CUT_BUFFER0
;
140 if (EQ (sym
, QCUT_BUFFER1
)) return XA_CUT_BUFFER1
;
141 if (EQ (sym
, QCUT_BUFFER2
)) return XA_CUT_BUFFER2
;
142 if (EQ (sym
, QCUT_BUFFER3
)) return XA_CUT_BUFFER3
;
143 if (EQ (sym
, QCUT_BUFFER4
)) return XA_CUT_BUFFER4
;
144 if (EQ (sym
, QCUT_BUFFER5
)) return XA_CUT_BUFFER5
;
145 if (EQ (sym
, QCUT_BUFFER6
)) return XA_CUT_BUFFER6
;
146 if (EQ (sym
, QCUT_BUFFER7
)) return XA_CUT_BUFFER7
;
148 if (!SYMBOLP (sym
)) abort ();
151 fprintf (stderr
, " XInternAtom %s\n", (char *) XSYMBOL (sym
)->name
->data
);
154 val
= XInternAtom (display
, (char *) XSYMBOL (sym
)->name
->data
, False
);
160 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
161 and calls to intern whenever possible. */
164 x_atom_to_symbol (display
, atom
)
170 if (! atom
) return Qnil
;
183 #ifdef CUT_BUFFER_SUPPORT
203 if (atom
== Xatom_CLIPBOARD
)
205 if (atom
== Xatom_TIMESTAMP
)
207 if (atom
== Xatom_TEXT
)
209 if (atom
== Xatom_DELETE
)
211 if (atom
== Xatom_MULTIPLE
)
213 if (atom
== Xatom_INCR
)
215 if (atom
== Xatom_EMACS_TMP
)
217 if (atom
== Xatom_TARGETS
)
219 if (atom
== Xatom_NULL
)
223 str
= XGetAtomName (display
, atom
);
226 fprintf (stderr
, " XGetAtomName --> %s\n", str
);
228 if (! str
) return Qnil
;
236 /* Do protocol to assert ourself as a selection owner.
237 Update the Vselection_alist so that we can reply to later requests for
241 x_own_selection (selection_name
, selection_value
)
242 Lisp_Object selection_name
, selection_value
;
244 Display
*display
= x_current_display
;
246 Window selecting_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
248 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
250 Time time
= last_event_timestamp
;
253 CHECK_SYMBOL (selection_name
, 0);
254 selection_atom
= symbol_to_x_atom (display
, selection_name
);
257 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
260 /* Now update the local cache */
262 Lisp_Object selection_time
;
263 Lisp_Object selection_data
;
264 Lisp_Object prev_value
;
266 selection_time
= long_to_cons ((unsigned long) time
);
267 selection_data
= Fcons (selection_name
,
268 Fcons (selection_value
,
269 Fcons (selection_time
, Qnil
)));
270 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
272 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
274 /* If we already owned the selection, remove the old selection data.
275 Perhaps we should destructively modify it instead.
276 Don't use Fdelq as that may QUIT. */
277 if (!NILP (prev_value
))
279 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
280 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
281 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
283 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
290 /* Given a selection-name and desired type, look up our local copy of
291 the selection value and convert it to the type.
292 The value is nil or a string.
293 This function is used both for remote requests
294 and for local x-get-selection-internal.
296 This calls random Lisp code, and may signal or gc. */
299 x_get_local_selection (selection_symbol
, target_type
)
300 Lisp_Object selection_symbol
, target_type
;
302 Lisp_Object local_value
;
303 Lisp_Object handler_fn
, value
, type
, check
;
306 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
308 if (NILP (local_value
)) return Qnil
;
310 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
311 if (EQ (target_type
, QTIMESTAMP
))
314 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
317 else if (EQ (target_type
, QDELETE
))
320 Fx_disown_selection_internal
322 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
327 #if 0 /* #### MULTIPLE doesn't work yet */
328 else if (CONSP (target_type
)
329 && XCONS (target_type
)->car
== QMULTIPLE
)
331 Lisp_Object pairs
= XCONS (target_type
)->cdr
;
332 int size
= XVECTOR (pairs
)->size
;
334 /* If the target is MULTIPLE, then target_type looks like
335 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
336 We modify the second element of each pair in the vector and
337 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
339 for (i
= 0; i
< size
; i
++)
341 Lisp_Object pair
= XVECTOR (pairs
)->contents
[i
];
342 XVECTOR (pair
)->contents
[1]
343 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
344 XVECTOR (pair
)->contents
[1]);
351 /* Don't allow a quit within the converter.
352 When the user types C-g, he would be surprised
353 if by luck it came during a converter. */
354 count
= specpdl_ptr
- specpdl
;
355 specbind (Qinhibit_quit
, Qt
);
357 CHECK_SYMBOL (target_type
, 0);
358 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
359 if (!NILP (handler_fn
))
360 value
= call3 (handler_fn
,
361 selection_symbol
, target_type
,
362 XCONS (XCONS (local_value
)->cdr
)->car
);
365 unbind_to (count
, Qnil
);
368 /* Make sure this value is of a type that we could transmit
369 to another X client. */
373 && SYMBOLP (XCONS (value
)->car
))
374 type
= XCONS (value
)->car
,
375 check
= XCONS (value
)->cdr
;
383 /* Check for a value that cons_to_long could handle. */
384 else if (CONSP (check
)
385 && INTEGERP (XCONS (check
)->car
)
386 && (INTEGERP (XCONS (check
)->cdr
)
388 (CONSP (XCONS (check
)->cdr
)
389 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
390 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
395 Fcons (build_string ("invalid data returned by selection-conversion function"),
396 Fcons (handler_fn
, Fcons (value
, Qnil
))));
399 /* Subroutines of x_reply_selection_request. */
401 /* Send a SelectionNotify event to the requestor with property=None,
402 meaning we were unable to do what they wanted. */
405 x_decline_selection_request (event
)
406 struct input_event
*event
;
408 XSelectionEvent reply
;
409 reply
.type
= SelectionNotify
;
410 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
411 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
412 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
413 reply
.time
= SELECTION_EVENT_TIME (event
);
414 reply
.target
= SELECTION_EVENT_TARGET (event
);
415 reply
.property
= None
;
418 (void) XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
423 /* This is the selection request currently being processed.
424 It is set to zero when the request is fully processed. */
425 static struct input_event
*x_selection_current_request
;
427 /* Used as an unwind-protect clause so that, if a selection-converter signals
428 an error, we tell the requestor that we were unable to do what they wanted
429 before we throw to top-level or go into the debugger or whatever. */
432 x_selection_request_lisp_error (ignore
)
435 if (x_selection_current_request
!= 0)
436 x_decline_selection_request (x_selection_current_request
);
440 /* Send the reply to a selection request event EVENT.
441 TYPE is the type of selection data requested.
442 DATA and SIZE describe the data to send, already converted.
443 FORMAT is the unit-size (in bits) of the data to be transmitted. */
446 x_reply_selection_request (event
, format
, data
, size
, type
)
447 struct input_event
*event
;
452 XSelectionEvent reply
;
453 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
454 Window window
= SELECTION_EVENT_REQUESTOR (event
);
456 int format_bytes
= format
/8;
457 int max_bytes
= SELECTION_QUANTUM (display
);
459 if (max_bytes
> MAX_SELECTION_QUANTUM
)
460 max_bytes
= MAX_SELECTION_QUANTUM
;
462 reply
.type
= SelectionNotify
;
463 reply
.display
= display
;
464 reply
.requestor
= window
;
465 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
466 reply
.time
= SELECTION_EVENT_TIME (event
);
467 reply
.target
= SELECTION_EVENT_TARGET (event
);
468 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
469 if (reply
.property
== None
)
470 reply
.property
= reply
.target
;
472 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
475 /* Store the data on the requested property.
476 If the selection is large, only store the first N bytes of it.
478 bytes_remaining
= size
* format_bytes
;
479 if (bytes_remaining
<= max_bytes
)
481 /* Send all the data at once, with minimal handshaking. */
483 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
485 XChangeProperty (display
, window
, reply
.property
, type
, format
,
486 PropModeReplace
, data
, size
);
487 /* At this point, the selection was successfully stored; ack it. */
488 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
492 /* Send an INCR selection. */
495 if (x_window_to_frame (window
)) /* #### debug */
496 error ("attempt to transfer an INCR to ourself!");
498 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
500 prop_id
= expect_property_change (display
, window
, reply
.property
,
503 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
504 32, PropModeReplace
, (unsigned char *)
505 &bytes_remaining
, 1);
506 XSelectInput (display
, window
, PropertyChangeMask
);
507 /* Tell 'em the INCR data is there... */
508 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
510 /* First, wait for the requestor to ack by deleting the property.
511 This can run random lisp code (process handlers) or signal. */
512 wait_for_property_change (prop_id
);
514 while (bytes_remaining
)
516 int i
= ((bytes_remaining
< max_bytes
)
519 prop_id
= expect_property_change (display
, window
, reply
.property
,
522 fprintf (stderr
," INCR adding %d\n", i
);
524 /* Append the next chunk of data to the property. */
525 XChangeProperty (display
, window
, reply
.property
, type
, format
,
526 PropModeAppend
, data
, i
/ format_bytes
);
527 bytes_remaining
-= i
;
530 /* Now wait for the requestor to ack this chunk by deleting the
531 property. This can run random lisp code or signal.
533 wait_for_property_change (prop_id
);
535 /* Now write a zero-length chunk to the property to tell the requestor
538 fprintf (stderr
," INCR done\n");
540 if (! waiting_for_other_props_on_window (display
, window
))
541 XSelectInput (display
, window
, 0L);
543 XChangeProperty (display
, window
, reply
.property
, type
, format
,
544 PropModeReplace
, data
, 0);
550 /* Handle a SelectionRequest event EVENT.
551 This is called from keyboard.c when such an event is found in the queue. */
554 x_handle_selection_request (event
)
555 struct input_event
*event
;
557 struct gcpro gcpro1
, gcpro2
, gcpro3
;
558 XSelectionEvent reply
;
559 Lisp_Object local_selection_data
= Qnil
;
560 Lisp_Object selection_symbol
;
561 Lisp_Object target_symbol
= Qnil
;
562 Lisp_Object converted_selection
= Qnil
;
563 Time local_selection_time
;
564 Lisp_Object successful_p
= Qnil
;
567 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
569 reply
.type
= SelectionNotify
; /* Construct the reply event */
570 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
571 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
572 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
573 reply
.time
= SELECTION_EVENT_TIME (event
);
574 reply
.target
= SELECTION_EVENT_TARGET (event
);
575 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
576 if (reply
.property
== None
)
577 reply
.property
= reply
.target
;
579 selection_symbol
= x_atom_to_symbol (reply
.display
,
580 SELECTION_EVENT_SELECTION (event
));
582 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
585 # define CDR(x) (XCONS (x)->cdr)
586 # define CAR(x) (XCONS (x)->car)
587 /* This list isn't user-visible, so it can't "go bad." */
588 if (!CONSP (local_selection_data
)) abort ();
589 if (!CONSP (CDR (local_selection_data
))) abort ();
590 if (!CONSP (CDR (CDR (local_selection_data
)))) abort ();
591 if (!NILP (CDR (CDR (CDR (local_selection_data
))))) abort ();
592 if (!CONSP (CAR (CDR (CDR (local_selection_data
))))) abort ();
593 if (!INTEGERP (CAR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
594 if (!INTEGERP (CDR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
599 if (NILP (local_selection_data
))
601 /* Someone asked for the selection, but we don't have it any more.
603 x_decline_selection_request (event
);
607 local_selection_time
= (Time
)
608 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
610 if (SELECTION_EVENT_TIME (event
) != CurrentTime
611 && local_selection_time
> SELECTION_EVENT_TIME (event
))
613 /* Someone asked for the selection, and we have one, but not the one
616 x_decline_selection_request (event
);
620 count
= specpdl_ptr
- specpdl
;
621 x_selection_current_request
= event
;
622 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
624 target_symbol
= x_atom_to_symbol (reply
.display
,
625 SELECTION_EVENT_TARGET (event
));
627 #if 0 /* #### MULTIPLE doesn't work yet */
628 if (EQ (target_symbol
, QMULTIPLE
))
629 target_symbol
= fetch_multiple_target (event
);
632 /* Convert lisp objects back into binary data */
635 = x_get_local_selection (selection_symbol
, target_symbol
);
637 if (! NILP (converted_selection
))
645 lisp_data_to_selection_data (reply
.display
, converted_selection
,
646 &data
, &type
, &size
, &format
, &nofree
);
648 x_reply_selection_request (event
, format
, data
, size
, type
);
651 /* Indicate we have successfully processed this event. */
652 x_selection_current_request
= 0;
657 unbind_to (count
, Qnil
);
663 /* Let random lisp code notice that the selection has been asked for. */
665 Lisp_Object rest
= Vx_sent_selection_hooks
;
666 if (!EQ (rest
, Qunbound
))
667 for (; CONSP (rest
); rest
= Fcdr (rest
))
668 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
672 /* Handle a SelectionClear event EVENT, which indicates that some other
673 client cleared out our previously asserted selection.
674 This is called from keyboard.c when such an event is found in the queue. */
677 x_handle_selection_clear (event
)
678 struct input_event
*event
;
680 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
681 Atom selection
= SELECTION_EVENT_SELECTION (event
);
682 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
684 Lisp_Object selection_symbol
, local_selection_data
;
685 Time local_selection_time
;
687 selection_symbol
= x_atom_to_symbol (display
, selection
);
689 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
691 /* Well, we already believe that we don't own it, so that's just fine. */
692 if (NILP (local_selection_data
)) return;
694 local_selection_time
= (Time
)
695 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
697 /* This SelectionClear is for a selection that we no longer own, so we can
698 disregard it. (That is, we have reasserted the selection since this
699 request was generated.) */
701 if (changed_owner_time
!= CurrentTime
702 && local_selection_time
> changed_owner_time
)
705 /* Otherwise, we're really honest and truly being told to drop it.
706 Don't use Fdelq as that may QUIT;. */
708 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
709 Vselection_alist
= Fcdr (Vselection_alist
);
713 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
714 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
716 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
721 /* Let random lisp code notice that the selection has been stolen. */
724 Lisp_Object rest
= Vx_lost_selection_hooks
;
725 if (!EQ (rest
, Qunbound
))
726 for (; CONSP (rest
); rest
= Fcdr (rest
))
727 call1 (Fcar (rest
), selection_symbol
);
732 /* This stuff is so that INCR selections are reentrant (that is, so we can
733 be servicing multiple INCR selection requests simultaneously.) I haven't
734 actually tested that yet. */
736 static int prop_location_tick
;
738 static Lisp_Object property_change_reply
;
739 static int property_change_reply_tick
;
741 /* Keep a list of the property changes that are awaited. */
750 struct prop_location
*next
;
753 static struct prop_location
*property_change_wait_list
;
756 property_deleted_p (tick
)
759 struct prop_location
*rest
= property_change_wait_list
;
761 if (rest
->tick
== (int) tick
)
768 /* Nonzero if any properties for DISPLAY and WINDOW
769 are on the list of what we are waiting for. */
772 waiting_for_other_props_on_window (display
, window
)
776 struct prop_location
*rest
= property_change_wait_list
;
778 if (rest
->display
== display
&& rest
->window
== window
)
785 /* Add an entry to the list of property changes we are waiting for.
786 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
787 The return value is a number that uniquely identifies
788 this awaited property change. */
791 expect_property_change (display
, window
, property
, state
)
794 Lisp_Object property
;
797 struct prop_location
*pl
798 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
799 pl
->tick
= ++prop_location_tick
;
800 pl
->display
= display
;
802 pl
->property
= property
;
803 pl
->desired_state
= state
;
804 pl
->next
= property_change_wait_list
;
805 property_change_wait_list
= pl
;
809 /* Delete an entry from the list of property changes we are waiting for.
810 TICK is the number that uniquely identifies the entry. */
813 unexpect_property_change (tick
)
816 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
819 if (rest
->tick
== tick
)
822 prev
->next
= rest
->next
;
824 property_change_wait_list
= rest
->next
;
833 /* Actually wait for a property change.
834 TICK should be the value that expect_property_change returned. */
837 wait_for_property_change (tick
)
839 XCONS (property_change_reply
)->car
= Qnil
;
840 property_change_reply_tick
= tick
;
841 wait_reading_process_input (0, 0, property_change_reply
, 0);
844 /* Called from XTread_socket in response to a PropertyNotify event. */
847 x_handle_property_notify (event
)
848 XPropertyEvent
*event
;
850 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
853 if (rest
->property
== event
->atom
854 && rest
->window
== event
->window
855 && rest
->display
== event
->display
856 && rest
->desired_state
== event
->state
)
859 fprintf (stderr
, "Saw expected prop-%s on %s\n",
860 (event
->state
== PropertyDelete
? "delete" : "change"),
861 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
866 /* If this is the one wait_for_property_change is waiting for,
867 tell it to wake up. */
868 if (rest
->tick
== property_change_reply_tick
)
869 XCONS (property_change_reply
)->car
= Qt
;
872 prev
->next
= rest
->next
;
874 property_change_wait_list
= rest
->next
;
882 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
883 (event
->state
== PropertyDelete
? "delete" : "change"),
884 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
891 #if 0 /* #### MULTIPLE doesn't work yet */
894 fetch_multiple_target (event
)
895 XSelectionRequestEvent
*event
;
897 Display
*display
= event
->display
;
898 Window window
= event
->requestor
;
899 Atom target
= event
->target
;
900 Atom selection_atom
= event
->selection
;
905 x_get_window_property_as_lisp_data (display
, window
, target
,
906 QMULTIPLE
, selection_atom
));
910 copy_multiple_data (obj
)
917 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
919 CHECK_VECTOR (obj
, 0);
920 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
921 for (i
= 0; i
< size
; i
++)
923 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
924 CHECK_VECTOR (vec2
, 0);
925 if (XVECTOR (vec2
)->size
!= 2)
926 /* ??? Confusing error message */
927 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
928 Fcons (vec2
, Qnil
)));
929 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
930 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
931 = XVECTOR (vec2
)->contents
[0];
932 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
933 = XVECTOR (vec2
)->contents
[1];
941 /* Variables for communication with x_handle_selection_notify. */
942 static Atom reading_which_selection
;
943 static Lisp_Object reading_selection_reply
;
944 static Window reading_selection_window
;
946 /* Do protocol to read selection-data from the server.
947 Converts this to Lisp data and returns it. */
950 x_get_foreign_selection (selection_symbol
, target_type
)
951 Lisp_Object selection_symbol
, target_type
;
953 Display
*display
= x_current_display
;
955 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
957 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
959 Time requestor_time
= last_event_timestamp
;
960 Atom target_property
= Xatom_EMACS_TMP
;
961 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
965 if (CONSP (target_type
))
966 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
968 type_atom
= symbol_to_x_atom (display
, target_type
);
971 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
972 requestor_window
, requestor_time
);
975 /* Prepare to block until the reply has been read. */
976 reading_selection_window
= requestor_window
;
977 reading_which_selection
= selection_atom
;
978 XCONS (reading_selection_reply
)->car
= Qnil
;
981 /* This allows quits. Also, don't wait forever. */
982 secs
= x_selection_timeout
/ 1000;
983 usecs
= (x_selection_timeout
% 1000) * 1000;
984 wait_reading_process_input (secs
, usecs
, reading_selection_reply
, 0);
986 if (NILP (XCONS (reading_selection_reply
)->car
))
987 error ("timed out waiting for reply from selection owner");
989 /* Otherwise, the selection is waiting for us on the requested property. */
991 x_get_window_property_as_lisp_data (display
, requestor_window
,
992 target_property
, target_type
,
996 /* Subroutines of x_get_window_property_as_lisp_data */
999 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
1000 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1005 unsigned char **data_ret
;
1007 Atom
*actual_type_ret
;
1008 int *actual_format_ret
;
1009 unsigned long *actual_size_ret
;
1013 unsigned long bytes_remaining
;
1015 unsigned char *tmp_data
= 0;
1017 int buffer_size
= SELECTION_QUANTUM (display
);
1018 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1021 /* First probe the thing to find out how big it is. */
1022 result
= XGetWindowProperty (display
, window
, property
,
1023 0, 0, False
, AnyPropertyType
,
1024 actual_type_ret
, actual_format_ret
,
1026 &bytes_remaining
, &tmp_data
);
1028 if (result
!= Success
)
1035 XFree ((char *) tmp_data
);
1038 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1040 if (delete_p
) XDeleteProperty (display
, window
, property
);
1044 total_size
= bytes_remaining
+ 1;
1045 *data_ret
= (unsigned char *) xmalloc (total_size
);
1047 /* Now read, until weve gotten it all. */
1049 while (bytes_remaining
)
1052 int last
= bytes_remaining
;
1055 = XGetWindowProperty (display
, window
, property
,
1056 offset
/4, buffer_size
/4,
1057 (delete_p
? True
: False
),
1059 actual_type_ret
, actual_format_ret
,
1060 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1062 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1064 /* If this doesn't return Success at this point, it means that
1065 some clod deleted the selection while we were in the midst of
1066 reading it. Deal with that, I guess....
1068 if (result
!= Success
) break;
1069 *actual_size_ret
*= *actual_format_ret
/ 8;
1070 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1071 offset
+= *actual_size_ret
;
1072 XFree ((char *) tmp_data
);
1075 *bytes_ret
= offset
;
1079 receive_incremental_selection (display
, window
, property
, target_type
,
1080 min_size_bytes
, data_ret
, size_bytes_ret
,
1081 type_ret
, format_ret
, size_ret
)
1085 Lisp_Object target_type
; /* for error messages only */
1086 unsigned int min_size_bytes
;
1087 unsigned char **data_ret
;
1088 int *size_bytes_ret
;
1090 unsigned long *size_ret
;
1095 *size_bytes_ret
= min_size_bytes
;
1096 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1098 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1100 /* At this point, we have read an INCR property, and deleted it (which
1101 is how we ack its receipt: the sending window will be selecting
1102 PropertyNotify events on our window to notice this.)
1104 Now, we must loop, waiting for the sending window to put a value on
1105 that property, then reading the property, then deleting it to ack.
1106 We are done when the sender places a property of length 0.
1108 prop_id
= expect_property_change (display
, window
, property
,
1112 unsigned char *tmp_data
;
1114 wait_for_property_change (prop_id
);
1115 /* expect it again immediately, because x_get_window_property may
1116 .. no it wont, I dont get it.
1117 .. Ok, I get it now, the Xt code that implements INCR is broken.
1119 prop_id
= expect_property_change (display
, window
, property
,
1121 x_get_window_property (display
, window
, property
,
1122 &tmp_data
, &tmp_size_bytes
,
1123 type_ret
, format_ret
, size_ret
, 1);
1125 if (tmp_size_bytes
== 0) /* we're done */
1128 fprintf (stderr
, " read INCR done\n");
1130 unexpect_property_change (prop_id
);
1131 if (tmp_data
) xfree (tmp_data
);
1135 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1137 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1140 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1141 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1143 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1144 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1146 memcpy ((*data_ret
) + offset
, tmp_data
, tmp_size_bytes
);
1147 offset
+= tmp_size_bytes
;
1152 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1153 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1154 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1157 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1162 Lisp_Object target_type
; /* for error messages only */
1163 Atom selection_atom
; /* for error messages only */
1167 unsigned long actual_size
;
1168 unsigned char *data
= 0;
1172 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1173 &actual_type
, &actual_format
, &actual_size
, 1);
1176 int there_is_a_selection_owner
;
1178 there_is_a_selection_owner
1179 = XGetSelectionOwner (display
, selection_atom
);
1181 while (1) /* Note debugger can no longer return, so this is obsolete */
1183 there_is_a_selection_owner
?
1184 Fcons (build_string ("selection owner couldn't convert"),
1186 ? Fcons (target_type
,
1187 Fcons (x_atom_to_symbol (display
, actual_type
),
1189 : Fcons (target_type
, Qnil
))
1190 : Fcons (build_string ("no selection"),
1191 Fcons (x_atom_to_symbol (display
, selection_atom
),
1195 if (actual_type
== Xatom_INCR
)
1197 /* That wasn't really the data, just the beginning. */
1199 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1201 XFree ((char *) data
);
1203 receive_incremental_selection (display
, window
, property
, target_type
,
1204 min_size_bytes
, &data
, &bytes
,
1205 &actual_type
, &actual_format
,
1209 /* It's been read. Now convert it to a lisp object in some semi-rational
1211 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1212 actual_type
, actual_format
);
1214 xfree ((char *) data
);
1218 /* These functions convert from the selection data read from the server into
1219 something that we can use from Lisp, and vice versa.
1221 Type: Format: Size: Lisp Type:
1222 ----- ------- ----- -----------
1225 ATOM 32 > 1 Vector of Symbols
1227 * 16 > 1 Vector of Integers
1228 * 32 1 if <=16 bits: Integer
1229 if > 16 bits: Cons of top16, bot16
1230 * 32 > 1 Vector of the above
1232 When converting a Lisp number to C, it is assumed to be of format 16 if
1233 it is an integer, and of format 32 if it is a cons of two integers.
1235 When converting a vector of numbers from Lisp to C, it is assumed to be
1236 of format 16 if every element in the vector is an integer, and is assumed
1237 to be of format 32 if any element is a cons of two integers.
1239 When converting an object to C, it may be of the form (SYMBOL . <data>)
1240 where SYMBOL is what we should claim that the type is. Format and
1241 representation are as above. */
1246 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1248 unsigned char *data
;
1253 if (type
== Xatom_NULL
)
1256 /* Convert any 8-bit data to a string, for compactness. */
1257 else if (format
== 8)
1258 return make_string ((char *) data
, size
);
1260 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1261 a vector of symbols.
1263 else if (type
== XA_ATOM
)
1266 if (size
== sizeof (Atom
))
1267 return x_atom_to_symbol (display
, *((Atom
*) data
));
1270 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1271 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1272 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1277 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1278 If the number is > 16 bits, convert it to a cons of integers,
1279 16 bits in each half.
1281 else if (format
== 32 && size
== sizeof (long))
1282 return long_to_cons (((unsigned long *) data
) [0]);
1283 else if (format
== 16 && size
== sizeof (short))
1284 return make_number ((int) (((unsigned short *) data
) [0]));
1286 /* Convert any other kind of data to a vector of numbers, represented
1287 as above (as an integer, or a cons of two 16 bit integers.)
1289 else if (format
== 16)
1292 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1293 for (i
= 0; i
< size
/ 4; i
++)
1295 int j
= (int) ((unsigned short *) data
) [i
];
1296 Faset (v
, i
, make_number (j
));
1303 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1304 for (i
= 0; i
< size
/ 4; i
++)
1306 unsigned long j
= ((unsigned long *) data
) [i
];
1307 Faset (v
, i
, long_to_cons (j
));
1315 lisp_data_to_selection_data (display
, obj
,
1316 data_ret
, type_ret
, size_ret
,
1317 format_ret
, nofree_ret
)
1320 unsigned char **data_ret
;
1322 unsigned int *size_ret
;
1326 Lisp_Object type
= Qnil
;
1330 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1332 type
= XCONS (obj
)->car
;
1333 obj
= XCONS (obj
)->cdr
;
1334 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1335 obj
= XCONS (obj
)->car
;
1338 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1339 { /* This is not the same as declining */
1345 else if (STRINGP (obj
))
1348 *size_ret
= XSTRING (obj
)->size
;
1349 *data_ret
= XSTRING (obj
)->data
;
1351 if (NILP (type
)) type
= QSTRING
;
1353 else if (SYMBOLP (obj
))
1357 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1358 (*data_ret
) [sizeof (Atom
)] = 0;
1359 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1360 if (NILP (type
)) type
= QATOM
;
1362 else if (INTEGERP (obj
)
1363 && XINT (obj
) < 0xFFFF
1364 && XINT (obj
) > -0xFFFF)
1368 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1369 (*data_ret
) [sizeof (short)] = 0;
1370 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1371 if (NILP (type
)) type
= QINTEGER
;
1373 else if (INTEGERP (obj
)
1374 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1375 && (INTEGERP (XCONS (obj
)->cdr
)
1376 || (CONSP (XCONS (obj
)->cdr
)
1377 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1381 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1382 (*data_ret
) [sizeof (long)] = 0;
1383 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1384 if (NILP (type
)) type
= QINTEGER
;
1386 else if (VECTORP (obj
))
1388 /* Lisp_Vectors may represent a set of ATOMs;
1389 a set of 16 or 32 bit INTEGERs;
1390 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1394 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1395 /* This vector is an ATOM set */
1397 if (NILP (type
)) type
= QATOM
;
1398 *size_ret
= XVECTOR (obj
)->size
;
1400 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1401 for (i
= 0; i
< *size_ret
; i
++)
1402 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1403 (*(Atom
**) data_ret
) [i
]
1404 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1406 Fsignal (Qerror
, /* Qselection_error */
1408 ("all elements of selection vector must have same type"),
1409 Fcons (obj
, Qnil
)));
1411 #if 0 /* #### MULTIPLE doesn't work yet */
1412 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1413 /* This vector is an ATOM_PAIR set */
1415 if (NILP (type
)) type
= QATOM_PAIR
;
1416 *size_ret
= XVECTOR (obj
)->size
;
1418 *data_ret
= (unsigned char *)
1419 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1420 for (i
= 0; i
< *size_ret
; i
++)
1421 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1423 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1424 if (XVECTOR (pair
)->size
!= 2)
1427 ("elements of the vector must be vectors of exactly two elements"),
1428 Fcons (pair
, Qnil
)));
1430 (*(Atom
**) data_ret
) [i
* 2]
1431 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1432 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1433 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1438 ("all elements of the vector must be of the same type"),
1439 Fcons (obj
, Qnil
)));
1444 /* This vector is an INTEGER set, or something like it */
1446 *size_ret
= XVECTOR (obj
)->size
;
1447 if (NILP (type
)) type
= QINTEGER
;
1449 for (i
= 0; i
< *size_ret
; i
++)
1450 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1452 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1453 Fsignal (Qerror
, /* Qselection_error */
1455 ("elements of selection vector must be integers or conses of integers"),
1456 Fcons (obj
, Qnil
)));
1458 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1459 for (i
= 0; i
< *size_ret
; i
++)
1460 if (*format_ret
== 32)
1461 (*((unsigned long **) data_ret
)) [i
]
1462 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1464 (*((unsigned short **) data_ret
)) [i
]
1465 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1469 Fsignal (Qerror
, /* Qselection_error */
1470 Fcons (build_string ("unrecognised selection data"),
1471 Fcons (obj
, Qnil
)));
1473 *type_ret
= symbol_to_x_atom (display
, type
);
1477 clean_local_selection_data (obj
)
1481 && INTEGERP (XCONS (obj
)->car
)
1482 && CONSP (XCONS (obj
)->cdr
)
1483 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1484 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1485 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1488 && INTEGERP (XCONS (obj
)->car
)
1489 && INTEGERP (XCONS (obj
)->cdr
))
1491 if (XINT (XCONS (obj
)->car
) == 0)
1492 return XCONS (obj
)->cdr
;
1493 if (XINT (XCONS (obj
)->car
) == -1)
1494 return make_number (- XINT (XCONS (obj
)->cdr
));
1499 int size
= XVECTOR (obj
)->size
;
1502 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1503 copy
= Fmake_vector (size
, Qnil
);
1504 for (i
= 0; i
< size
; i
++)
1505 XVECTOR (copy
)->contents
[i
]
1506 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1512 /* Called from XTread_socket to handle SelectionNotify events.
1513 If it's the selection we are waiting for, stop waiting. */
1516 x_handle_selection_notify (event
)
1517 XSelectionEvent
*event
;
1519 if (event
->requestor
!= reading_selection_window
)
1521 if (event
->selection
!= reading_which_selection
)
1524 XCONS (reading_selection_reply
)->car
= Qt
;
1528 DEFUN ("x-own-selection-internal",
1529 Fx_own_selection_internal
, Sx_own_selection_internal
,
1531 "Assert an X selection of the given TYPE with the given VALUE.\n\
1532 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1533 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1534 VALUE is typically a string, or a cons of two markers, but may be\n\
1535 anything that the functions on `selection-converter-alist' know about.")
1536 (selection_name
, selection_value
)
1537 Lisp_Object selection_name
, selection_value
;
1539 CHECK_SYMBOL (selection_name
, 0);
1540 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1541 x_own_selection (selection_name
, selection_value
);
1542 return selection_value
;
1546 /* Request the selection value from the owner. If we are the owner,
1547 simply return our selection value. If we are not the owner, this
1548 will block until all of the data has arrived. */
1550 DEFUN ("x-get-selection-internal",
1551 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1552 "Return text selected from some X window.\n\
1553 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1554 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1555 TYPE is the type of data desired, typically `STRING'.")
1556 (selection_symbol
, target_type
)
1557 Lisp_Object selection_symbol
, target_type
;
1559 Lisp_Object val
= Qnil
;
1560 struct gcpro gcpro1
, gcpro2
;
1561 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1562 CHECK_SYMBOL (selection_symbol
, 0);
1564 #if 0 /* #### MULTIPLE doesn't work yet */
1565 if (CONSP (target_type
)
1566 && XCONS (target_type
)->car
== QMULTIPLE
)
1568 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1569 /* So we don't destructively modify this... */
1570 target_type
= copy_multiple_data (target_type
);
1574 CHECK_SYMBOL (target_type
, 0);
1576 val
= x_get_local_selection (selection_symbol
, target_type
);
1580 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1585 && SYMBOLP (XCONS (val
)->car
))
1587 val
= XCONS (val
)->cdr
;
1588 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1589 val
= XCONS (val
)->car
;
1591 val
= clean_local_selection_data (val
);
1597 DEFUN ("x-disown-selection-internal",
1598 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1599 "If we own the selection SELECTION, disown it.\n\
1600 Disowning it means there is no such selection.")
1602 Lisp_Object selection
;
1605 Display
*display
= x_current_display
;
1607 Atom selection_atom
;
1608 XSelectionClearEvent event
;
1610 CHECK_SYMBOL (selection
, 0);
1612 timestamp
= last_event_timestamp
;
1614 timestamp
= cons_to_long (time
);
1616 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1617 return Qnil
; /* Don't disown the selection when we're not the owner. */
1619 selection_atom
= symbol_to_x_atom (display
, selection
);
1622 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1625 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1626 generated for a window which owns the selection when that window sets
1627 the selection owner to None. The NCD server does, the MIT Sun4 server
1628 doesn't. So we synthesize one; this means we might get two, but
1629 that's ok, because the second one won't have any effect. */
1630 event
.display
= display
;
1631 event
.selection
= selection_atom
;
1632 event
.time
= timestamp
;
1633 x_handle_selection_clear (&event
);
1638 /* Get rid of all the selections in buffer BUFFER.
1639 This is used when we kill a buffer. */
1642 x_disown_buffer_selections (buffer
)
1646 struct buffer
*buf
= XBUFFER (buffer
);
1648 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1650 Lisp_Object elt
, value
;
1651 elt
= XCONS (tail
)->car
;
1652 value
= XCONS (elt
)->cdr
;
1653 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1654 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1655 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1659 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1661 "Whether the current Emacs process owns the given X Selection.\n\
1662 The arg should be the name of the selection in question, typically one of\n\
1663 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1664 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1665 For convenience, the symbol nil is the same as `PRIMARY',\n\
1666 and t is the same as `SECONDARY'.)")
1668 Lisp_Object selection
;
1670 CHECK_SYMBOL (selection
, 0);
1671 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1672 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1674 if (NILP (Fassq (selection
, Vselection_alist
)))
1679 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1681 "Whether there is an owner for the given X Selection.\n\
1682 The arg should be the name of the selection in question, typically one of\n\
1683 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1684 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1685 For convenience, the symbol nil is the same as `PRIMARY',\n\
1686 and t is the same as `SECONDARY'.)")
1688 Lisp_Object selection
;
1692 Display
*dpy
= x_current_display
;
1693 CHECK_SYMBOL (selection
, 0);
1694 if (!NILP (Fx_selection_owner_p (selection
)))
1696 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1697 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1698 atom
= symbol_to_x_atom (dpy
, selection
);
1702 owner
= XGetSelectionOwner (dpy
, atom
);
1704 return (owner
? Qt
: Qnil
);
1708 #ifdef CUT_BUFFER_SUPPORT
1710 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1712 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1714 initialize_cut_buffers (display
, window
)
1718 unsigned char *data
= (unsigned char *) "";
1720 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1721 PropModeAppend, data, 0)
1722 FROB (XA_CUT_BUFFER0
);
1723 FROB (XA_CUT_BUFFER1
);
1724 FROB (XA_CUT_BUFFER2
);
1725 FROB (XA_CUT_BUFFER3
);
1726 FROB (XA_CUT_BUFFER4
);
1727 FROB (XA_CUT_BUFFER5
);
1728 FROB (XA_CUT_BUFFER6
);
1729 FROB (XA_CUT_BUFFER7
);
1732 cut_buffers_initialized
= 1;
1736 #define CHECK_CUT_BUFFER(symbol,n) \
1737 { CHECK_SYMBOL ((symbol), (n)); \
1738 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1739 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1740 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1741 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1743 Fcons (build_string ("doesn't name a cut buffer"), \
1744 Fcons ((symbol), Qnil))); \
1747 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1748 Sx_get_cut_buffer_internal
, 1, 1, 0,
1749 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1753 Display
*display
= x_current_display
;
1754 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1756 unsigned char *data
;
1763 CHECK_CUT_BUFFER (buffer
, 0);
1764 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1766 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1767 &type
, &format
, &size
, 0);
1768 if (!data
) return Qnil
;
1770 if (format
!= 8 || type
!= XA_STRING
)
1772 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1773 Fcons (x_atom_to_symbol (display
, type
),
1774 Fcons (make_number (format
), Qnil
))));
1776 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1782 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1783 Sx_store_cut_buffer_internal
, 2, 2, 0,
1784 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1786 Lisp_Object buffer
, string
;
1788 Display
*display
= x_current_display
;
1789 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1791 unsigned char *data
;
1793 int bytes_remaining
;
1794 int max_bytes
= SELECTION_QUANTUM (display
);
1795 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1797 CHECK_CUT_BUFFER (buffer
, 0);
1798 CHECK_STRING (string
, 0);
1799 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1800 data
= (unsigned char *) XSTRING (string
)->data
;
1801 bytes
= XSTRING (string
)->size
;
1802 bytes_remaining
= bytes
;
1804 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1808 /* Don't mess up with an empty value. */
1809 if (!bytes_remaining
)
1810 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1811 PropModeReplace
, data
, 0);
1813 while (bytes_remaining
)
1815 int chunk
= (bytes_remaining
< max_bytes
1816 ? bytes_remaining
: max_bytes
);
1817 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1818 (bytes_remaining
== bytes
1823 bytes_remaining
-= chunk
;
1830 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1831 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1832 "Rotate the values of the cut buffers by the given number of steps;\n\
1833 positive means move values forward, negative means backward.")
1837 Display
*display
= x_current_display
;
1838 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1841 CHECK_NUMBER (n
, 0);
1842 if (XINT (n
) == 0) return n
;
1843 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1844 props
[0] = XA_CUT_BUFFER0
;
1845 props
[1] = XA_CUT_BUFFER1
;
1846 props
[2] = XA_CUT_BUFFER2
;
1847 props
[3] = XA_CUT_BUFFER3
;
1848 props
[4] = XA_CUT_BUFFER4
;
1849 props
[5] = XA_CUT_BUFFER5
;
1850 props
[6] = XA_CUT_BUFFER6
;
1851 props
[7] = XA_CUT_BUFFER7
;
1853 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1861 Xatoms_of_xselect ()
1863 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1866 /* Non-predefined atoms that we might end up using a lot */
1867 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1868 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1869 Xatom_TEXT
= ATOM ("TEXT");
1870 Xatom_DELETE
= ATOM ("DELETE");
1871 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1872 Xatom_INCR
= ATOM ("INCR");
1873 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1874 Xatom_TARGETS
= ATOM ("TARGETS");
1875 Xatom_NULL
= ATOM ("NULL");
1876 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1883 defsubr (&Sx_get_selection_internal
);
1884 defsubr (&Sx_own_selection_internal
);
1885 defsubr (&Sx_disown_selection_internal
);
1886 defsubr (&Sx_selection_owner_p
);
1887 defsubr (&Sx_selection_exists_p
);
1889 #ifdef CUT_BUFFER_SUPPORT
1890 defsubr (&Sx_get_cut_buffer_internal
);
1891 defsubr (&Sx_store_cut_buffer_internal
);
1892 defsubr (&Sx_rotate_cut_buffers_internal
);
1893 cut_buffers_initialized
= 0;
1896 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1897 staticpro (&reading_selection_reply
);
1898 reading_selection_window
= 0;
1899 reading_which_selection
= 0;
1901 property_change_wait_list
= 0;
1902 prop_location_tick
= 0;
1903 property_change_reply
= Fcons (Qnil
, Qnil
);
1904 staticpro (&property_change_reply
);
1906 Vselection_alist
= Qnil
;
1907 staticpro (&Vselection_alist
);
1909 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1910 "An alist associating X Windows selection-types with functions.\n\
1911 These functions are called to convert the selection, with three args:\n\
1912 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1913 a desired type to which the selection should be converted;\n\
1914 and the local selection value (whatever was given to `x-own-selection').\n\
1916 The function should return the value to send to the X server\n\
1917 \(typically a string). A return value of nil\n\
1918 means that the conversion could not be done.\n\
1919 A return value which is the symbol `NULL'\n\
1920 means that a side-effect was executed,\n\
1921 and there is no meaningful selection value.");
1922 Vselection_converter_alist
= Qnil
;
1924 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1925 "A list of functions to be called when Emacs loses an X selection.\n\
1926 \(This happens when some other X client makes its own selection\n\
1927 or when a Lisp program explicitly clears the selection.)\n\
1928 The functions are called with one argument, the selection type\n\
1929 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1930 Vx_lost_selection_hooks
= Qnil
;
1932 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1933 "A list of functions to be called when Emacs answers a selection request.\n\
1934 The functions are called with four arguments:\n\
1935 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1936 - the selection-type which Emacs was asked to convert the\n\
1937 selection into before sending (for example, `STRING' or `LENGTH');\n\
1938 - a flag indicating success or failure for responding to the request.\n\
1939 We might have failed (and declined the request) for any number of reasons,\n\
1940 including being asked for a selection that we no longer own, or being asked\n\
1941 to convert into a type that we don't know about or that is inappropriate.\n\
1942 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
1943 it merely informs you that they have happened.");
1944 Vx_sent_selection_hooks
= Qnil
;
1946 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
1947 "Number of milliseconds to wait for a selection reply.\n\
1948 If the selection owner doens't reply in this time, we give up.\n\
1949 A value of 0 means wait as long as necessary. This is initialized from the\n\
1950 \"*selectionTimeout\" resource.");
1951 x_selection_timeout
= 0;
1953 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
1954 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
1955 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
1956 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
1957 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
1958 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1959 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
1960 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1961 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
1962 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
1963 QINCR
= intern ("INCR"); staticpro (&QINCR
);
1964 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
1965 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
1966 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
1967 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
1968 QNULL
= intern ("NULL"); staticpro (&QNULL
);
1970 #ifdef CUT_BUFFER_SUPPORT
1971 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
1972 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
1973 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
1974 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
1975 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
1976 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
1977 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
1978 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);