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 */
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
66 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize (dpy) << 2) - 100)
69 /* The timestamp of the last input event Emacs received from the X server. */
70 unsigned long last_event_timestamp
;
72 /* This is an association list whose elements are of the form
73 ( selection-name selection-value selection-timestamp )
74 selection-name is a lisp symbol, whose name is the name of an X Atom.
75 selection-value is the value that emacs owns for that selection.
76 It may be any kind of Lisp object.
77 selection-timestamp is the time at which emacs began owning this selection,
78 as a cons of two 16-bit numbers (making a 32 bit time.)
79 If there is an entry in this alist, then it can be assumed that emacs owns
81 The only (eq) parts of this list that are visible from Lisp are the
84 Lisp_Object Vselection_alist
;
86 /* This is an alist whose CARs are selection-types (whose names are the same
87 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
88 call to convert the given Emacs selection value to a string representing
89 the given selection type. This is for Lisp-level extension of the emacs
92 Lisp_Object Vselection_converter_alist
;
94 /* If the selection owner takes too long to reply to a selection request,
95 we give up on it. This is in seconds (0 = no timeout.)
97 int x_selection_timeout
;
100 /* Utility functions */
102 static void lisp_data_to_selection_data ();
103 static Lisp_Object
selection_data_to_lisp_data ();
104 static Lisp_Object
x_get_window_property_as_lisp_data ();
106 static int expect_property_change ();
107 static void wait_for_property_change ();
108 static void unexpect_property_change ();
109 static int waiting_for_other_props_on_window ();
111 /* This converts a Lisp symbol to a server Atom, avoiding a server
112 roundtrip whenever possible. */
115 symbol_to_x_atom (display
, sym
)
120 if (NILP (sym
)) return 0;
121 if (EQ (sym
, QPRIMARY
)) return XA_PRIMARY
;
122 if (EQ (sym
, QSECONDARY
)) return XA_SECONDARY
;
123 if (EQ (sym
, QSTRING
)) return XA_STRING
;
124 if (EQ (sym
, QINTEGER
)) return XA_INTEGER
;
125 if (EQ (sym
, QATOM
)) return XA_ATOM
;
126 if (EQ (sym
, QCLIPBOARD
)) return Xatom_CLIPBOARD
;
127 if (EQ (sym
, QTIMESTAMP
)) return Xatom_TIMESTAMP
;
128 if (EQ (sym
, QTEXT
)) return Xatom_TEXT
;
129 if (EQ (sym
, QDELETE
)) return Xatom_DELETE
;
130 if (EQ (sym
, QMULTIPLE
)) return Xatom_MULTIPLE
;
131 if (EQ (sym
, QINCR
)) return Xatom_INCR
;
132 if (EQ (sym
, QEMACS_TMP
)) return Xatom_EMACS_TMP
;
133 if (EQ (sym
, QTARGETS
)) return Xatom_TARGETS
;
134 if (EQ (sym
, QNULL
)) return Xatom_NULL
;
135 #ifdef CUT_BUFFER_SUPPORT
136 if (EQ (sym
, QCUT_BUFFER0
)) return XA_CUT_BUFFER0
;
137 if (EQ (sym
, QCUT_BUFFER1
)) return XA_CUT_BUFFER1
;
138 if (EQ (sym
, QCUT_BUFFER2
)) return XA_CUT_BUFFER2
;
139 if (EQ (sym
, QCUT_BUFFER3
)) return XA_CUT_BUFFER3
;
140 if (EQ (sym
, QCUT_BUFFER4
)) return XA_CUT_BUFFER4
;
141 if (EQ (sym
, QCUT_BUFFER5
)) return XA_CUT_BUFFER5
;
142 if (EQ (sym
, QCUT_BUFFER6
)) return XA_CUT_BUFFER6
;
143 if (EQ (sym
, QCUT_BUFFER7
)) return XA_CUT_BUFFER7
;
145 if (!SYMBOLP (sym
)) abort ();
148 fprintf (stderr
, " XInternAtom %s\n", (char *) XSYMBOL (sym
)->name
->data
);
151 val
= XInternAtom (display
, (char *) XSYMBOL (sym
)->name
->data
, False
);
157 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
158 and calls to intern whenever possible. */
161 x_atom_to_symbol (display
, atom
)
167 if (! atom
) return Qnil
;
180 #ifdef CUT_BUFFER_SUPPORT
200 if (atom
== Xatom_CLIPBOARD
)
202 if (atom
== Xatom_TIMESTAMP
)
204 if (atom
== Xatom_TEXT
)
206 if (atom
== Xatom_DELETE
)
208 if (atom
== Xatom_MULTIPLE
)
210 if (atom
== Xatom_INCR
)
212 if (atom
== Xatom_EMACS_TMP
)
214 if (atom
== Xatom_TARGETS
)
216 if (atom
== Xatom_NULL
)
220 str
= XGetAtomName (display
, atom
);
223 fprintf (stderr
, " XGetAtomName --> %s\n", str
);
225 if (! str
) return Qnil
;
238 unsigned int top
= i
>> 16;
239 unsigned int bot
= i
& 0xFFFF;
240 if (top
== 0) return make_number (bot
);
241 if (top
== 0xFFFF) return Fcons (make_number (-1), make_number (bot
));
242 return Fcons (make_number (top
), make_number (bot
));
250 if (INTEGERP (c
)) return XINT (c
);
251 top
= XCONS (c
)->car
;
252 bot
= XCONS (c
)->cdr
;
253 if (CONSP (bot
)) bot
= XCONS (bot
)->car
;
254 return ((XINT (top
) << 16) | XINT (bot
));
259 /* Do protocol to assert ourself as a selection owner.
260 Update the Vselection_alist so that we can reply to later requests for
264 x_own_selection (selection_name
, selection_value
)
265 Lisp_Object selection_name
, selection_value
;
267 Display
*display
= x_current_display
;
269 Window selecting_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
271 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
273 Time time
= last_event_timestamp
;
276 CHECK_SYMBOL (selection_name
, 0);
277 selection_atom
= symbol_to_x_atom (display
, selection_name
);
280 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
283 /* Now update the local cache */
285 Lisp_Object selection_time
;
286 Lisp_Object selection_data
;
287 Lisp_Object prev_value
;
289 selection_time
= long_to_cons ((unsigned long) time
);
290 selection_data
= Fcons (selection_name
,
291 Fcons (selection_value
,
292 Fcons (selection_time
, Qnil
)));
293 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
295 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
297 /* If we already owned the selection, remove the old selection data.
298 Perhaps we should destructively modify it instead.
299 Don't use Fdelq as that may QUIT. */
300 if (!NILP (prev_value
))
302 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
303 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
304 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
306 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
313 /* Given a selection-name and desired type, look up our local copy of
314 the selection value and convert it to the type.
315 The value is nil or a string.
316 This function is used both for remote requests
317 and for local x-get-selection-internal.
319 This calls random Lisp code, and may signal or gc. */
322 x_get_local_selection (selection_symbol
, target_type
)
323 Lisp_Object selection_symbol
, target_type
;
325 Lisp_Object local_value
;
326 Lisp_Object handler_fn
, value
, type
, check
;
329 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
331 if (NILP (local_value
)) return Qnil
;
333 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
334 if (EQ (target_type
, QTIMESTAMP
))
337 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
340 else if (EQ (target_type
, QDELETE
))
343 Fx_disown_selection_internal
345 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
350 #if 0 /* #### MULTIPLE doesn't work yet */
351 else if (CONSP (target_type
)
352 && XCONS (target_type
)->car
== QMULTIPLE
)
354 Lisp_Object pairs
= XCONS (target_type
)->cdr
;
355 int size
= XVECTOR (pairs
)->size
;
357 /* If the target is MULTIPLE, then target_type looks like
358 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
359 We modify the second element of each pair in the vector and
360 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
362 for (i
= 0; i
< size
; i
++)
364 Lisp_Object pair
= XVECTOR (pairs
)->contents
[i
];
365 XVECTOR (pair
)->contents
[1]
366 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
367 XVECTOR (pair
)->contents
[1]);
374 /* Don't allow a quit within the converter.
375 When the user types C-g, he would be surprised
376 if by luck it came during a converter. */
377 count
= specpdl_ptr
- specpdl
;
378 specbind (Qinhibit_quit
, Qt
);
380 CHECK_SYMBOL (target_type
, 0);
381 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
382 if (NILP (handler_fn
))
384 Fcons (build_string ("missing selection-conversion function"),
385 Fcons (target_type
, Fcons (value
, Qnil
))));
386 value
= call3 (handler_fn
,
387 selection_symbol
, target_type
,
388 XCONS (XCONS (local_value
)->cdr
)->car
);
389 unbind_to (count
, Qnil
);
392 /* Make sure this value is of a type that we could transmit
393 to another X client. */
397 && SYMBOLP (XCONS (value
)->car
))
398 type
= XCONS (value
)->car
,
399 check
= XCONS (value
)->cdr
;
407 /* Check for a value that cons_to_long could handle. */
408 else if (CONSP (check
)
409 && INTEGERP (XCONS (check
)->car
)
410 && (INTEGERP (XCONS (check
)->cdr
)
412 (CONSP (XCONS (check
)->cdr
)
413 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
414 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
419 Fcons (build_string ("invalid data returned by selection-conversion function"),
420 Fcons (handler_fn
, Fcons (value
, Qnil
))));
423 /* Subroutines of x_reply_selection_request. */
425 /* Send a SelectionNotify event to the requestor with property=None,
426 meaning we were unable to do what they wanted. */
429 x_decline_selection_request (event
)
430 struct input_event
*event
;
432 XSelectionEvent reply
;
433 reply
.type
= SelectionNotify
;
434 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
435 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
436 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
437 reply
.time
= SELECTION_EVENT_TIME (event
);
438 reply
.target
= SELECTION_EVENT_TARGET (event
);
439 reply
.property
= None
;
442 (void) XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
447 /* This is the selection request currently being processed.
448 It is set to zero when the request is fully processed. */
449 static struct input_event
*x_selection_current_request
;
451 /* Used as an unwind-protect clause so that, if a selection-converter signals
452 an error, we tell the requestor that we were unable to do what they wanted
453 before we throw to top-level or go into the debugger or whatever. */
456 x_selection_request_lisp_error (ignore
)
459 if (x_selection_current_request
!= 0)
460 x_decline_selection_request (x_selection_current_request
);
464 /* Send the reply to a selection request event EVENT.
465 TYPE is the type of selection data requested.
466 DATA and SIZE describe the data to send, already converted.
467 FORMAT is the unit-size (in bits) of the data to be transmitted. */
470 x_reply_selection_request (event
, format
, data
, size
, type
)
471 struct input_event
*event
;
476 XSelectionEvent reply
;
477 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
478 Window window
= SELECTION_EVENT_REQUESTOR (event
);
480 int format_bytes
= format
/8;
481 int max_bytes
= SELECTION_QUANTUM (display
);
483 if (max_bytes
> MAX_SELECTION_QUANTUM
)
484 max_bytes
= MAX_SELECTION_QUANTUM
;
486 reply
.type
= SelectionNotify
;
487 reply
.display
= display
;
488 reply
.requestor
= window
;
489 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
490 reply
.time
= SELECTION_EVENT_TIME (event
);
491 reply
.target
= SELECTION_EVENT_TARGET (event
);
492 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
493 if (reply
.property
== None
)
494 reply
.property
= reply
.target
;
496 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
499 /* Store the data on the requested property.
500 If the selection is large, only store the first N bytes of it.
502 bytes_remaining
= size
* format_bytes
;
503 if (bytes_remaining
<= max_bytes
)
505 /* Send all the data at once, with minimal handshaking. */
507 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
509 XChangeProperty (display
, window
, reply
.property
, type
, format
,
510 PropModeReplace
, data
, size
);
511 /* At this point, the selection was successfully stored; ack it. */
512 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
516 /* Send an INCR selection. */
519 if (x_window_to_frame (window
)) /* #### debug */
520 error ("attempt to transfer an INCR to ourself!");
522 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
524 prop_id
= expect_property_change (display
, window
, reply
.property
,
527 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
528 32, PropModeReplace
, (unsigned char *)
529 &bytes_remaining
, 1);
530 XSelectInput (display
, window
, PropertyChangeMask
);
531 /* Tell 'em the INCR data is there... */
532 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
534 /* First, wait for the requestor to ack by deleting the property.
535 This can run random lisp code (process handlers) or signal. */
536 wait_for_property_change (prop_id
);
538 while (bytes_remaining
)
540 int i
= ((bytes_remaining
< max_bytes
)
543 prop_id
= expect_property_change (display
, window
, reply
.property
,
546 fprintf (stderr
," INCR adding %d\n", i
);
548 /* Append the next chunk of data to the property. */
549 XChangeProperty (display
, window
, reply
.property
, type
, format
,
550 PropModeAppend
, data
, i
/ format_bytes
);
551 bytes_remaining
-= i
;
554 /* Now wait for the requestor to ack this chunk by deleting the
555 property. This can run random lisp code or signal.
557 wait_for_property_change (prop_id
);
559 /* Now write a zero-length chunk to the property to tell the requestor
562 fprintf (stderr
," INCR done\n");
564 if (! waiting_for_other_props_on_window (display
, window
))
565 XSelectInput (display
, window
, 0L);
567 XChangeProperty (display
, window
, reply
.property
, type
, format
,
568 PropModeReplace
, data
, 0);
573 /* Handle a SelectionRequest event EVENT.
574 This is called from keyboard.c when such an event is found in the queue. */
577 x_handle_selection_request (event
)
578 struct input_event
*event
;
580 struct gcpro gcpro1
, gcpro2
, gcpro3
;
581 XSelectionEvent reply
;
582 Lisp_Object local_selection_data
= Qnil
;
583 Lisp_Object selection_symbol
;
584 Lisp_Object target_symbol
= Qnil
;
585 Lisp_Object converted_selection
= Qnil
;
586 Time local_selection_time
;
587 Lisp_Object successful_p
= Qnil
;
590 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
592 reply
.type
= SelectionNotify
; /* Construct the reply event */
593 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
594 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
595 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
596 reply
.time
= SELECTION_EVENT_TIME (event
);
597 reply
.target
= SELECTION_EVENT_TARGET (event
);
598 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
599 if (reply
.property
== None
)
600 reply
.property
= reply
.target
;
602 selection_symbol
= x_atom_to_symbol (reply
.display
,
603 SELECTION_EVENT_SELECTION (event
));
605 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
608 # define CDR(x) (XCONS (x)->cdr)
609 # define CAR(x) (XCONS (x)->car)
610 /* This list isn't user-visible, so it can't "go bad." */
611 if (!CONSP (local_selection_data
)) abort ();
612 if (!CONSP (CDR (local_selection_data
))) abort ();
613 if (!CONSP (CDR (CDR (local_selection_data
)))) abort ();
614 if (!NILP (CDR (CDR (CDR (local_selection_data
))))) abort ();
615 if (!CONSP (CAR (CDR (CDR (local_selection_data
))))) abort ();
616 if (!INTEGERP (CAR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
617 if (!INTEGERP (CDR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
622 if (NILP (local_selection_data
))
624 /* Someone asked for the selection, but we don't have it any more.
626 x_decline_selection_request (event
);
630 local_selection_time
= (Time
)
631 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
633 if (SELECTION_EVENT_TIME (event
) != CurrentTime
634 && local_selection_time
> SELECTION_EVENT_TIME (event
))
636 /* Someone asked for the selection, and we have one, but not the one
639 x_decline_selection_request (event
);
643 count
= specpdl_ptr
- specpdl
;
644 x_selection_current_request
= event
;
645 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
647 target_symbol
= x_atom_to_symbol (reply
.display
,
648 SELECTION_EVENT_TARGET (event
));
650 #if 0 /* #### MULTIPLE doesn't work yet */
651 if (EQ (target_symbol
, QMULTIPLE
))
652 target_symbol
= fetch_multiple_target (event
);
655 /* Convert lisp objects back into binary data */
658 = x_get_local_selection (selection_symbol
, target_symbol
);
660 if (! NILP (converted_selection
))
666 lisp_data_to_selection_data (reply
.display
, converted_selection
,
667 &data
, &type
, &size
, &format
);
669 x_reply_selection_request (event
, format
, data
, size
, type
);
672 /* Indicate we have successfully processed this event. */
673 x_selection_current_request
= 0;
677 unbind_to (count
, Qnil
);
683 /* Let random lisp code notice that the selection has been asked for. */
685 Lisp_Object rest
= Vx_sent_selection_hooks
;
686 if (!EQ (rest
, Qunbound
))
687 for (; CONSP (rest
); rest
= Fcdr (rest
))
688 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
692 /* Handle a SelectionClear event EVENT, which indicates that some other
693 client cleared out our previously asserted selection.
694 This is called from keyboard.c when such an event is found in the queue. */
697 x_handle_selection_clear (event
)
698 struct input_event
*event
;
700 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
701 Atom selection
= SELECTION_EVENT_SELECTION (event
);
702 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
704 Lisp_Object selection_symbol
, local_selection_data
;
705 Time local_selection_time
;
707 selection_symbol
= x_atom_to_symbol (display
, selection
);
709 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
711 /* Well, we already believe that we don't own it, so that's just fine. */
712 if (NILP (local_selection_data
)) return;
714 local_selection_time
= (Time
)
715 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
717 /* This SelectionClear is for a selection that we no longer own, so we can
718 disregard it. (That is, we have reasserted the selection since this
719 request was generated.) */
721 if (changed_owner_time
!= CurrentTime
722 && local_selection_time
> changed_owner_time
)
725 /* Otherwise, we're really honest and truly being told to drop it.
726 Don't use Fdelq as that may QUIT;. */
728 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
729 Vselection_alist
= Fcdr (Vselection_alist
);
733 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
734 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
736 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
741 /* Let random lisp code notice that the selection has been stolen. */
744 Lisp_Object rest
= Vx_lost_selection_hooks
;
745 if (!EQ (rest
, Qunbound
))
746 for (; CONSP (rest
); rest
= Fcdr (rest
))
747 call1 (Fcar (rest
), selection_symbol
);
752 /* This stuff is so that INCR selections are reentrant (that is, so we can
753 be servicing multiple INCR selection requests simultaneously.) I haven't
754 actually tested that yet. */
756 static int prop_location_tick
;
758 static Lisp_Object property_change_reply
;
759 static int property_change_reply_tick
;
761 /* Keep a list of the property changes that are awaited. */
770 struct prop_location
*next
;
773 static struct prop_location
*property_change_wait_list
;
776 property_deleted_p (tick
)
779 struct prop_location
*rest
= property_change_wait_list
;
781 if (rest
->tick
== (int) tick
)
788 /* Nonzero if any properties for DISPLAY and WINDOW
789 are on the list of what we are waiting for. */
792 waiting_for_other_props_on_window (display
, window
)
796 struct prop_location
*rest
= property_change_wait_list
;
798 if (rest
->display
== display
&& rest
->window
== window
)
805 /* Add an entry to the list of property changes we are waiting for.
806 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
807 The return value is a number that uniquely identifies
808 this awaited property change. */
811 expect_property_change (display
, window
, property
, state
)
814 Lisp_Object property
;
817 struct prop_location
*pl
818 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
819 pl
->tick
= ++prop_location_tick
;
820 pl
->display
= display
;
822 pl
->property
= property
;
823 pl
->desired_state
= state
;
824 pl
->next
= property_change_wait_list
;
825 property_change_wait_list
= pl
;
829 /* Delete an entry from the list of property changes we are waiting for.
830 TICK is the number that uniquely identifies the entry. */
833 unexpect_property_change (tick
)
836 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
839 if (rest
->tick
== tick
)
842 prev
->next
= rest
->next
;
844 property_change_wait_list
= rest
->next
;
853 /* Actually wait for a property change.
854 TICK should be the value that expect_property_change returned. */
857 wait_for_property_change (tick
)
859 XCONS (property_change_reply
)->car
= Qnil
;
860 property_change_reply_tick
= tick
;
861 wait_reading_process_input (0, 0, property_change_reply
, 0);
864 /* Called from XTread_socket in response to a PropertyNotify event. */
867 x_handle_property_notify (event
)
868 XPropertyEvent
*event
;
870 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
873 if (rest
->property
== event
->atom
874 && rest
->window
== event
->window
875 && rest
->display
== event
->display
876 && rest
->desired_state
== event
->state
)
879 fprintf (stderr
, "Saw expected prop-%s on %s\n",
880 (event
->state
== PropertyDelete
? "delete" : "change"),
881 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
886 /* If this is the one wait_for_property_change is waiting for,
887 tell it to wake up. */
888 if (rest
->tick
== property_change_reply_tick
)
889 XCONS (property_change_reply
)->car
= Qt
;
892 prev
->next
= rest
->next
;
894 property_change_wait_list
= rest
->next
;
902 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
903 (event
->state
== PropertyDelete
? "delete" : "change"),
904 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
911 #if 0 /* #### MULTIPLE doesn't work yet */
914 fetch_multiple_target (event
)
915 XSelectionRequestEvent
*event
;
917 Display
*display
= event
->display
;
918 Window window
= event
->requestor
;
919 Atom target
= event
->target
;
920 Atom selection_atom
= event
->selection
;
925 x_get_window_property_as_lisp_data (display
, window
, target
,
926 QMULTIPLE
, selection_atom
));
930 copy_multiple_data (obj
)
937 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
939 CHECK_VECTOR (obj
, 0);
940 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
941 for (i
= 0; i
< size
; i
++)
943 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
944 CHECK_VECTOR (vec2
, 0);
945 if (XVECTOR (vec2
)->size
!= 2)
946 /* ??? Confusing error message */
947 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
948 Fcons (vec2
, Qnil
)));
949 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
950 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
951 = XVECTOR (vec2
)->contents
[0];
952 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
953 = XVECTOR (vec2
)->contents
[1];
961 /* Variables for communication with x_handle_selection_notify. */
962 static Atom reading_which_selection
;
963 static Lisp_Object reading_selection_reply
;
964 static Window reading_selection_window
;
966 /* Do protocol to read selection-data from the server.
967 Converts this to Lisp data and returns it. */
970 x_get_foreign_selection (selection_symbol
, target_type
)
971 Lisp_Object selection_symbol
, target_type
;
973 Display
*display
= x_current_display
;
975 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
977 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
979 Time requestor_time
= last_event_timestamp
;
980 Atom target_property
= Xatom_EMACS_TMP
;
981 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
984 if (CONSP (target_type
))
985 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
987 type_atom
= symbol_to_x_atom (display
, target_type
);
990 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
991 requestor_window
, requestor_time
);
994 /* Prepare to block until the reply has been read. */
995 reading_selection_window
= requestor_window
;
996 reading_which_selection
= selection_atom
;
997 XCONS (reading_selection_reply
)->car
= Qnil
;
1000 /* This allows quits. */
1001 wait_reading_process_input (x_selection_timeout
, 0,
1002 reading_selection_reply
, 0);
1004 if (NILP (XCONS (reading_selection_reply
)->car
))
1005 error ("timed out waiting for reply from selection owner");
1007 /* Otherwise, the selection is waiting for us on the requested property. */
1009 x_get_window_property_as_lisp_data (display
, requestor_window
,
1010 target_property
, target_type
,
1014 /* Subroutines of x_get_window_property_as_lisp_data */
1017 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
1018 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1023 unsigned char **data_ret
;
1025 Atom
*actual_type_ret
;
1026 int *actual_format_ret
;
1027 unsigned long *actual_size_ret
;
1031 unsigned long bytes_remaining
;
1033 unsigned char *tmp_data
= 0;
1035 int buffer_size
= SELECTION_QUANTUM (display
);
1036 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1039 /* First probe the thing to find out how big it is. */
1040 result
= XGetWindowProperty (display
, window
, property
,
1041 0, 0, False
, AnyPropertyType
,
1042 actual_type_ret
, actual_format_ret
,
1044 &bytes_remaining
, &tmp_data
);
1046 if (result
!= Success
)
1053 XFree ((char *) tmp_data
);
1056 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1058 if (delete_p
) XDeleteProperty (display
, window
, property
);
1062 total_size
= bytes_remaining
+ 1;
1063 *data_ret
= (unsigned char *) xmalloc (total_size
);
1065 /* Now read, until weve gotten it all. */
1067 while (bytes_remaining
)
1070 int last
= bytes_remaining
;
1073 = XGetWindowProperty (display
, window
, property
,
1074 offset
/4, buffer_size
/4,
1075 (delete_p
? True
: False
),
1077 actual_type_ret
, actual_format_ret
,
1078 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1080 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1082 /* If this doesn't return Success at this point, it means that
1083 some clod deleted the selection while we were in the midst of
1084 reading it. Deal with that, I guess....
1086 if (result
!= Success
) break;
1087 *actual_size_ret
*= *actual_format_ret
/ 8;
1088 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1089 offset
+= *actual_size_ret
;
1090 XFree ((char *) tmp_data
);
1093 *bytes_ret
= offset
;
1097 receive_incremental_selection (display
, window
, property
, target_type
,
1098 min_size_bytes
, data_ret
, size_bytes_ret
,
1099 type_ret
, format_ret
, size_ret
)
1103 Lisp_Object target_type
; /* for error messages only */
1104 unsigned int min_size_bytes
;
1105 unsigned char **data_ret
;
1106 int *size_bytes_ret
;
1108 unsigned long *size_ret
;
1113 *size_bytes_ret
= min_size_bytes
;
1114 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1116 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1118 /* At this point, we have read an INCR property, and deleted it (which
1119 is how we ack its receipt: the sending window will be selecting
1120 PropertyNotify events on our window to notice this.)
1122 Now, we must loop, waiting for the sending window to put a value on
1123 that property, then reading the property, then deleting it to ack.
1124 We are done when the sender places a property of length 0.
1126 prop_id
= expect_property_change (display
, window
, property
,
1130 unsigned char *tmp_data
;
1132 wait_for_property_change (prop_id
);
1133 /* expect it again immediately, because x_get_window_property may
1134 .. no it wont, I dont get it.
1135 .. Ok, I get it now, the Xt code that implements INCR is broken.
1137 prop_id
= expect_property_change (display
, window
, property
,
1139 x_get_window_property (display
, window
, property
,
1140 &tmp_data
, &tmp_size_bytes
,
1141 type_ret
, format_ret
, size_ret
, 1);
1143 if (tmp_size_bytes
== 0) /* we're done */
1146 fprintf (stderr
, " read INCR done\n");
1148 unexpect_property_change (prop_id
);
1149 if (tmp_data
) xfree (tmp_data
);
1153 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1155 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1158 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1159 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1161 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1162 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1164 memcpy ((*data_ret
) + offset
, tmp_data
, tmp_size_bytes
);
1165 offset
+= tmp_size_bytes
;
1170 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1171 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1172 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1175 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1180 Lisp_Object target_type
; /* for error messages only */
1181 Atom selection_atom
; /* for error messages only */
1185 unsigned long actual_size
;
1186 unsigned char *data
= 0;
1190 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1191 &actual_type
, &actual_format
, &actual_size
, 1);
1194 int there_is_a_selection_owner
;
1196 there_is_a_selection_owner
1197 = XGetSelectionOwner (display
, selection_atom
);
1199 while (1) /* Note debugger can no longer return, so this is obsolete */
1201 there_is_a_selection_owner
?
1202 Fcons (build_string ("selection owner couldn't convert"),
1204 ? Fcons (target_type
,
1205 Fcons (x_atom_to_symbol (display
, actual_type
),
1207 : Fcons (target_type
, Qnil
))
1208 : Fcons (build_string ("no selection"),
1209 Fcons (x_atom_to_symbol (display
, selection_atom
),
1213 if (actual_type
== Xatom_INCR
)
1215 /* That wasn't really the data, just the beginning. */
1217 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1219 XFree ((char *) data
);
1221 receive_incremental_selection (display
, window
, property
, target_type
,
1222 min_size_bytes
, &data
, &bytes
,
1223 &actual_type
, &actual_format
,
1227 /* It's been read. Now convert it to a lisp object in some semi-rational
1229 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1230 actual_type
, actual_format
);
1232 xfree ((char *) data
);
1236 /* These functions convert from the selection data read from the server into
1237 something that we can use from Lisp, and vice versa.
1239 Type: Format: Size: Lisp Type:
1240 ----- ------- ----- -----------
1243 ATOM 32 > 1 Vector of Symbols
1245 * 16 > 1 Vector of Integers
1246 * 32 1 if <=16 bits: Integer
1247 if > 16 bits: Cons of top16, bot16
1248 * 32 > 1 Vector of the above
1250 When converting a Lisp number to C, it is assumed to be of format 16 if
1251 it is an integer, and of format 32 if it is a cons of two integers.
1253 When converting a vector of numbers from Lisp to C, it is assumed to be
1254 of format 16 if every element in the vector is an integer, and is assumed
1255 to be of format 32 if any element is a cons of two integers.
1257 When converting an object to C, it may be of the form (SYMBOL . <data>)
1258 where SYMBOL is what we should claim that the type is. Format and
1259 representation are as above. */
1264 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1266 unsigned char *data
;
1271 if (type
== Xatom_NULL
)
1274 /* Convert any 8-bit data to a string, for compactness. */
1275 else if (format
== 8)
1276 return make_string ((char *) data
, size
);
1278 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1279 a vector of symbols.
1281 else if (type
== XA_ATOM
)
1284 if (size
== sizeof (Atom
))
1285 return x_atom_to_symbol (display
, *((Atom
*) data
));
1288 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1289 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1290 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1295 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1296 If the number is > 16 bits, convert it to a cons of integers,
1297 16 bits in each half.
1299 else if (format
== 32 && size
== sizeof (long))
1300 return long_to_cons (((unsigned long *) data
) [0]);
1301 else if (format
== 16 && size
== sizeof (short))
1302 return make_number ((int) (((unsigned short *) data
) [0]));
1304 /* Convert any other kind of data to a vector of numbers, represented
1305 as above (as an integer, or a cons of two 16 bit integers.)
1307 else if (format
== 16)
1310 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1311 for (i
= 0; i
< size
/ 4; i
++)
1313 int j
= (int) ((unsigned short *) data
) [i
];
1314 Faset (v
, i
, make_number (j
));
1321 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1322 for (i
= 0; i
< size
/ 4; i
++)
1324 unsigned long j
= ((unsigned long *) data
) [i
];
1325 Faset (v
, i
, long_to_cons (j
));
1333 lisp_data_to_selection_data (display
, obj
,
1334 data_ret
, type_ret
, size_ret
, format_ret
)
1337 unsigned char **data_ret
;
1339 unsigned int *size_ret
;
1342 Lisp_Object type
= Qnil
;
1343 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1345 type
= XCONS (obj
)->car
;
1346 obj
= XCONS (obj
)->cdr
;
1347 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1348 obj
= XCONS (obj
)->car
;
1351 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1352 { /* This is not the same as declining */
1358 else if (STRINGP (obj
))
1361 *size_ret
= XSTRING (obj
)->size
;
1362 *data_ret
= (unsigned char *) xmalloc (*size_ret
);
1363 memcpy (*data_ret
, (char *) XSTRING (obj
)->data
, *size_ret
);
1364 if (NILP (type
)) type
= QSTRING
;
1366 else if (SYMBOLP (obj
))
1370 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1371 (*data_ret
) [sizeof (Atom
)] = 0;
1372 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1373 if (NILP (type
)) type
= QATOM
;
1375 else if (INTEGERP (obj
)
1376 && XINT (obj
) < 0xFFFF
1377 && XINT (obj
) > -0xFFFF)
1381 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1382 (*data_ret
) [sizeof (short)] = 0;
1383 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1384 if (NILP (type
)) type
= QINTEGER
;
1386 else if (INTEGERP (obj
)
1387 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1388 && (INTEGERP (XCONS (obj
)->cdr
)
1389 || (CONSP (XCONS (obj
)->cdr
)
1390 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1394 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1395 (*data_ret
) [sizeof (long)] = 0;
1396 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1397 if (NILP (type
)) type
= QINTEGER
;
1399 else if (VECTORP (obj
))
1401 /* Lisp_Vectors may represent a set of ATOMs;
1402 a set of 16 or 32 bit INTEGERs;
1403 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1407 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1408 /* This vector is an ATOM set */
1410 if (NILP (type
)) type
= QATOM
;
1411 *size_ret
= XVECTOR (obj
)->size
;
1413 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1414 for (i
= 0; i
< *size_ret
; i
++)
1415 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1416 (*(Atom
**) data_ret
) [i
]
1417 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1419 Fsignal (Qerror
, /* Qselection_error */
1421 ("all elements of selection vector must have same type"),
1422 Fcons (obj
, Qnil
)));
1424 #if 0 /* #### MULTIPLE doesn't work yet */
1425 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1426 /* This vector is an ATOM_PAIR set */
1428 if (NILP (type
)) type
= QATOM_PAIR
;
1429 *size_ret
= XVECTOR (obj
)->size
;
1431 *data_ret
= (unsigned char *)
1432 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1433 for (i
= 0; i
< *size_ret
; i
++)
1434 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1436 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1437 if (XVECTOR (pair
)->size
!= 2)
1440 ("elements of the vector must be vectors of exactly two elements"),
1441 Fcons (pair
, Qnil
)));
1443 (*(Atom
**) data_ret
) [i
* 2]
1444 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1445 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1446 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1451 ("all elements of the vector must be of the same type"),
1452 Fcons (obj
, Qnil
)));
1457 /* This vector is an INTEGER set, or something like it */
1459 *size_ret
= XVECTOR (obj
)->size
;
1460 if (NILP (type
)) type
= QINTEGER
;
1462 for (i
= 0; i
< *size_ret
; i
++)
1463 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1465 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1466 Fsignal (Qerror
, /* Qselection_error */
1468 ("elements of selection vector must be integers or conses of integers"),
1469 Fcons (obj
, Qnil
)));
1471 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1472 for (i
= 0; i
< *size_ret
; i
++)
1473 if (*format_ret
== 32)
1474 (*((unsigned long **) data_ret
)) [i
]
1475 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1477 (*((unsigned short **) data_ret
)) [i
]
1478 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1482 Fsignal (Qerror
, /* Qselection_error */
1483 Fcons (build_string ("unrecognised selection data"),
1484 Fcons (obj
, Qnil
)));
1486 *type_ret
= symbol_to_x_atom (display
, type
);
1490 clean_local_selection_data (obj
)
1494 && INTEGERP (XCONS (obj
)->car
)
1495 && CONSP (XCONS (obj
)->cdr
)
1496 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1497 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1498 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1501 && INTEGERP (XCONS (obj
)->car
)
1502 && INTEGERP (XCONS (obj
)->cdr
))
1504 if (XINT (XCONS (obj
)->car
) == 0)
1505 return XCONS (obj
)->cdr
;
1506 if (XINT (XCONS (obj
)->car
) == -1)
1507 return make_number (- XINT (XCONS (obj
)->cdr
));
1512 int size
= XVECTOR (obj
)->size
;
1515 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1516 copy
= Fmake_vector (size
, Qnil
);
1517 for (i
= 0; i
< size
; i
++)
1518 XVECTOR (copy
)->contents
[i
]
1519 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1525 /* Called from XTread_socket to handle SelectionNotify events.
1526 If it's the selection we are waiting for, stop waiting. */
1529 x_handle_selection_notify (event
)
1530 XSelectionEvent
*event
;
1532 if (event
->requestor
!= reading_selection_window
)
1534 if (event
->selection
!= reading_which_selection
)
1537 XCONS (reading_selection_reply
)->car
= Qt
;
1541 DEFUN ("x-own-selection-internal",
1542 Fx_own_selection_internal
, Sx_own_selection_internal
,
1544 "Assert an X selection of the given TYPE with the given VALUE.\n\
1545 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1546 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1547 VALUE is typically a string, or a cons of two markers, but may be\n\
1548 anything that the functions on `selection-converter-alist' know about.")
1549 (selection_name
, selection_value
)
1550 Lisp_Object selection_name
, selection_value
;
1552 CHECK_SYMBOL (selection_name
, 0);
1553 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1554 x_own_selection (selection_name
, selection_value
);
1555 return selection_value
;
1559 /* Request the selection value from the owner. If we are the owner,
1560 simply return our selection value. If we are not the owner, this
1561 will block until all of the data has arrived. */
1563 DEFUN ("x-get-selection-internal",
1564 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1565 "Return text selected from some X window.\n\
1566 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1567 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1568 TYPE is the type of data desired, typically `STRING'.")
1569 (selection_symbol
, target_type
)
1570 Lisp_Object selection_symbol
, target_type
;
1572 Lisp_Object val
= Qnil
;
1573 struct gcpro gcpro1
, gcpro2
;
1574 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1575 CHECK_SYMBOL (selection_symbol
, 0);
1577 #if 0 /* #### MULTIPLE doesn't work yet */
1578 if (CONSP (target_type
)
1579 && XCONS (target_type
)->car
== QMULTIPLE
)
1581 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1582 /* So we don't destructively modify this... */
1583 target_type
= copy_multiple_data (target_type
);
1587 CHECK_SYMBOL (target_type
, 0);
1589 val
= x_get_local_selection (selection_symbol
, target_type
);
1593 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1598 && SYMBOLP (XCONS (val
)->car
))
1600 val
= XCONS (val
)->cdr
;
1601 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1602 val
= XCONS (val
)->car
;
1604 val
= clean_local_selection_data (val
);
1610 DEFUN ("x-disown-selection-internal",
1611 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1612 "If we own the selection SELECTION, disown it.\n\
1613 Disowning it means there is no such selection.")
1615 Lisp_Object selection
;
1618 Display
*display
= x_current_display
;
1620 Atom selection_atom
;
1621 XSelectionClearEvent event
;
1623 CHECK_SYMBOL (selection
, 0);
1625 timestamp
= last_event_timestamp
;
1627 timestamp
= cons_to_long (time
);
1629 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1630 return Qnil
; /* Don't disown the selection when we're not the owner. */
1632 selection_atom
= symbol_to_x_atom (display
, selection
);
1635 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1638 /* It doesn't seem to be guarenteed that a SelectionClear event will be
1639 generated for a window which owns the selection when that window sets
1640 the selection owner to None. The NCD server does, the MIT Sun4 server
1641 doesn't. So we synthesize one; this means we might get two, but
1642 that's ok, because the second one won't have any effect. */
1643 event
.display
= display
;
1644 event
.selection
= selection_atom
;
1645 event
.time
= timestamp
;
1646 x_handle_selection_clear (&event
);
1651 /* Get rid of all the selections in buffer BUFFER.
1652 This is used when we kill a buffer. */
1655 x_disown_buffer_selections (buffer
)
1659 struct buffer
*buf
= XBUFFER (buffer
);
1661 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1663 Lisp_Object elt
, value
;
1664 elt
= XCONS (tail
)->car
;
1665 value
= XCONS (elt
)->cdr
;
1666 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1667 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1668 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1672 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1674 "Whether the current Emacs process owns the given X Selection.\n\
1675 The arg should be the name of the selection in question, typically one of\n\
1676 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1677 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1678 For convenience, the symbol nil is the same as `PRIMARY',\n\
1679 and t is the same as `SECONDARY'.)")
1681 Lisp_Object selection
;
1683 CHECK_SYMBOL (selection
, 0);
1684 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1685 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1687 if (NILP (Fassq (selection
, Vselection_alist
)))
1692 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1694 "Whether there is an owner for the given X Selection.\n\
1695 The arg should be the name of the selection in question, typically one of\n\
1696 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1697 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1698 For convenience, the symbol nil is the same as `PRIMARY',\n\
1699 and t is the same as `SECONDARY'.)")
1701 Lisp_Object selection
;
1704 Display
*dpy
= x_current_display
;
1705 CHECK_SYMBOL (selection
, 0);
1706 if (!NILP (Fx_selection_owner_p (selection
)))
1709 owner
= XGetSelectionOwner (dpy
, symbol_to_x_atom (dpy
, selection
));
1711 return (owner
? Qt
: Qnil
);
1715 #ifdef CUT_BUFFER_SUPPORT
1717 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1719 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1721 initialize_cut_buffers (display
, window
)
1725 unsigned char *data
= (unsigned char *) "";
1727 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1728 PropModeAppend, data, 0)
1729 FROB (XA_CUT_BUFFER0
);
1730 FROB (XA_CUT_BUFFER1
);
1731 FROB (XA_CUT_BUFFER2
);
1732 FROB (XA_CUT_BUFFER3
);
1733 FROB (XA_CUT_BUFFER4
);
1734 FROB (XA_CUT_BUFFER5
);
1735 FROB (XA_CUT_BUFFER6
);
1736 FROB (XA_CUT_BUFFER7
);
1739 cut_buffers_initialized
= 1;
1743 #define CHECK_CUT_BUFFER(symbol,n) \
1744 { CHECK_SYMBOL ((symbol), (n)); \
1745 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1746 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1747 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1748 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1750 Fcons (build_string ("doesn't name a cut buffer"), \
1751 Fcons ((symbol), Qnil))); \
1754 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1755 Sx_get_cut_buffer_internal
, 1, 1, 0,
1756 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1760 Display
*display
= x_current_display
;
1761 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1763 unsigned char *data
;
1770 CHECK_CUT_BUFFER (buffer
, 0);
1771 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1773 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1774 &type
, &format
, &size
, 0);
1775 if (!data
) return Qnil
;
1777 if (format
!= 8 || type
!= XA_STRING
)
1779 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1780 Fcons (x_atom_to_symbol (display
, type
),
1781 Fcons (make_number (format
), Qnil
))));
1783 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1789 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1790 Sx_store_cut_buffer_internal
, 2, 2, 0,
1791 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1793 Lisp_Object buffer
, string
;
1795 Display
*display
= x_current_display
;
1796 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1798 unsigned char *data
;
1800 int bytes_remaining
;
1801 int max_bytes
= SELECTION_QUANTUM (display
);
1802 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1804 CHECK_CUT_BUFFER (buffer
, 0);
1805 CHECK_STRING (string
, 0);
1806 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1807 data
= (unsigned char *) XSTRING (string
)->data
;
1808 bytes
= XSTRING (string
)->size
;
1809 bytes_remaining
= bytes
;
1811 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1814 while (bytes_remaining
)
1816 int chunk
= (bytes_remaining
< max_bytes
1817 ? bytes_remaining
: max_bytes
);
1818 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1819 (bytes_remaining
== bytes
1824 bytes_remaining
-= chunk
;
1831 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1832 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1833 "Rotate the values of the cut buffers by the given number of steps;\n\
1834 positive means move values forward, negative means backward.")
1838 Display
*display
= x_current_display
;
1839 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1842 CHECK_NUMBER (n
, 0);
1843 if (XINT (n
) == 0) return n
;
1844 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1845 props
[0] = XA_CUT_BUFFER0
;
1846 props
[1] = XA_CUT_BUFFER1
;
1847 props
[2] = XA_CUT_BUFFER2
;
1848 props
[3] = XA_CUT_BUFFER3
;
1849 props
[4] = XA_CUT_BUFFER4
;
1850 props
[5] = XA_CUT_BUFFER5
;
1851 props
[6] = XA_CUT_BUFFER6
;
1852 props
[7] = XA_CUT_BUFFER7
;
1854 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1862 Xatoms_of_xselect ()
1864 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1867 /* Non-predefined atoms that we might end up using a lot */
1868 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1869 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1870 Xatom_TEXT
= ATOM ("TEXT");
1871 Xatom_DELETE
= ATOM ("DELETE");
1872 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1873 Xatom_INCR
= ATOM ("INCR");
1874 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1875 Xatom_TARGETS
= ATOM ("TARGETS");
1876 Xatom_NULL
= ATOM ("NULL");
1877 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1884 defsubr (&Sx_get_selection_internal
);
1885 defsubr (&Sx_own_selection_internal
);
1886 defsubr (&Sx_disown_selection_internal
);
1887 defsubr (&Sx_selection_owner_p
);
1888 defsubr (&Sx_selection_exists_p
);
1890 #ifdef CUT_BUFFER_SUPPORT
1891 defsubr (&Sx_get_cut_buffer_internal
);
1892 defsubr (&Sx_store_cut_buffer_internal
);
1893 defsubr (&Sx_rotate_cut_buffers_internal
);
1894 cut_buffers_initialized
= 0;
1897 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1898 staticpro (&reading_selection_reply
);
1899 reading_selection_window
= 0;
1900 reading_which_selection
= 0;
1902 property_change_wait_list
= 0;
1903 prop_location_tick
= 0;
1904 property_change_reply
= Fcons (Qnil
, Qnil
);
1905 staticpro (&property_change_reply
);
1907 Vselection_alist
= Qnil
;
1908 staticpro (&Vselection_alist
);
1910 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1911 "An alist associating X Windows selection-types with functions.\n\
1912 These functions are called to convert the selection, with three args:\n\
1913 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1914 a desired type to which the selection should be converted;\n\
1915 and the local selection value (whatever was given to `x-own-selection').\n\
1917 The function should return the value to send to the X server\n\
1918 \(typically a string). A return value of nil\n\
1919 means that the conversion could not be done.\n\
1920 A return value which is the symbol `NULL'\n\
1921 means that a side-effect was executed,\n\
1922 and there is no meaningful selection value.");
1923 Vselection_converter_alist
= Qnil
;
1925 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1926 "A list of functions to be called when Emacs loses an X selection.\n\
1927 \(This happens when some other X client makes its own selection\n\
1928 or when a Lisp program explicitly clears the selection.)\n\
1929 The functions are called with one argument, the selection type\n\
1930 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1931 Vx_lost_selection_hooks
= Qnil
;
1933 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1934 "A list of functions to be called when Emacs answers a selection request.\n\
1935 The functions are called with four arguments:\n\
1936 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1937 - the selection-type which Emacs was asked to convert the\n\
1938 selection into before sending (for example, `STRING' or `LENGTH');\n\
1939 - a flag indicating success or failure for responding to the request.\n\
1940 We might have failed (and declined the request) for any number of reasons,\n\
1941 including being asked for a selection that we no longer own, or being asked\n\
1942 to convert into a type that we don't know about or that is inappropriate.\n\
1943 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
1944 it merely informs you that they have happened.");
1945 Vx_sent_selection_hooks
= Qnil
;
1947 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
1948 "Number of seconds to wait for a selection reply from another X client.\n\
1949 If the selection owner doens't reply in this many seconds, we give up.\n\
1950 A value of 0 means wait as long as necessary. This is initialized from the\n\
1951 \"*selectionTimeout\" resource (which is expressed in milliseconds).");
1952 x_selection_timeout
= 0;
1954 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
1955 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
1956 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
1957 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
1958 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
1959 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1960 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
1961 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1962 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
1963 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
1964 QINCR
= intern ("INCR"); staticpro (&QINCR
);
1965 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
1966 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
1967 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
1968 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
1969 QNULL
= intern ("NULL"); staticpro (&QNULL
);
1971 #ifdef CUT_BUFFER_SUPPORT
1972 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
1973 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
1974 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
1975 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
1976 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
1977 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
1978 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
1979 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);