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! */
474 /* Store the data on the requested property.
475 If the selection is large, only store the first N bytes of it.
477 bytes_remaining
= size
* format_bytes
;
478 if (bytes_remaining
<= max_bytes
)
480 /* Send all the data at once, with minimal handshaking. */
482 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 XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
494 /* Send an INCR selection. */
499 if (x_window_to_frame (window
)) /* #### debug */
500 error ("attempt to transfer an INCR to ourself!");
502 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
504 prop_id
= expect_property_change (display
, window
, reply
.property
,
507 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
508 32, PropModeReplace
, (unsigned char *)
509 &bytes_remaining
, 1);
510 XSelectInput (display
, window
, PropertyChangeMask
);
511 /* Tell 'em the INCR data is there... */
512 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
516 /* First, wait for the requestor to ack by deleting the property.
517 This can run random lisp code (process handlers) or signal. */
518 wait_for_property_change (prop_id
);
520 while (bytes_remaining
)
522 int i
= ((bytes_remaining
< max_bytes
)
528 prop_id
= expect_property_change (display
, window
, reply
.property
,
531 fprintf (stderr
," INCR adding %d\n", i
);
533 /* Append the next chunk of data to the property. */
534 XChangeProperty (display
, window
, reply
.property
, type
, format
,
535 PropModeAppend
, data
, i
/ format_bytes
);
536 bytes_remaining
-= i
;
541 /* Now wait for the requestor to ack this chunk by deleting the
542 property. This can run random lisp code or signal.
544 wait_for_property_change (prop_id
);
546 /* Now write a zero-length chunk to the property to tell the requestor
549 fprintf (stderr
," INCR done\n");
552 if (! waiting_for_other_props_on_window (display
, window
))
553 XSelectInput (display
, window
, 0L);
555 XChangeProperty (display
, window
, reply
.property
, type
, format
,
556 PropModeReplace
, data
, 0);
562 /* Handle a SelectionRequest event EVENT.
563 This is called from keyboard.c when such an event is found in the queue. */
566 x_handle_selection_request (event
)
567 struct input_event
*event
;
569 struct gcpro gcpro1
, gcpro2
, gcpro3
;
570 Lisp_Object local_selection_data
= Qnil
;
571 Lisp_Object selection_symbol
;
572 Lisp_Object target_symbol
= Qnil
;
573 Lisp_Object converted_selection
= Qnil
;
574 Time local_selection_time
;
575 Lisp_Object successful_p
= Qnil
;
578 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
580 selection_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
581 SELECTION_EVENT_SELECTION (event
));
583 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
585 if (NILP (local_selection_data
))
587 /* Someone asked for the selection, but we don't have it any more.
589 x_decline_selection_request (event
);
593 local_selection_time
= (Time
)
594 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
596 if (SELECTION_EVENT_TIME (event
) != CurrentTime
597 && local_selection_time
> SELECTION_EVENT_TIME (event
))
599 /* Someone asked for the selection, and we have one, but not the one
602 x_decline_selection_request (event
);
606 count
= specpdl_ptr
- specpdl
;
607 x_selection_current_request
= event
;
608 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
610 target_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
611 SELECTION_EVENT_TARGET (event
));
613 #if 0 /* #### MULTIPLE doesn't work yet */
614 if (EQ (target_symbol
, QMULTIPLE
))
615 target_symbol
= fetch_multiple_target (event
);
618 /* Convert lisp objects back into binary data */
621 = x_get_local_selection (selection_symbol
, target_symbol
);
623 if (! NILP (converted_selection
))
631 lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event
),
633 &data
, &type
, &size
, &format
, &nofree
);
635 x_reply_selection_request (event
, format
, data
, size
, type
);
638 /* Indicate we have successfully processed this event. */
639 x_selection_current_request
= 0;
644 unbind_to (count
, Qnil
);
650 /* Let random lisp code notice that the selection has been asked for. */
652 Lisp_Object rest
= Vx_sent_selection_hooks
;
653 if (!EQ (rest
, Qunbound
))
654 for (; CONSP (rest
); rest
= Fcdr (rest
))
655 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
659 /* Handle a SelectionClear event EVENT, which indicates that some other
660 client cleared out our previously asserted selection.
661 This is called from keyboard.c when such an event is found in the queue. */
664 x_handle_selection_clear (event
)
665 struct input_event
*event
;
667 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
668 Atom selection
= SELECTION_EVENT_SELECTION (event
);
669 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
671 Lisp_Object selection_symbol
, local_selection_data
;
672 Time local_selection_time
;
674 selection_symbol
= x_atom_to_symbol (display
, selection
);
676 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
678 /* Well, we already believe that we don't own it, so that's just fine. */
679 if (NILP (local_selection_data
)) return;
681 local_selection_time
= (Time
)
682 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
684 /* This SelectionClear is for a selection that we no longer own, so we can
685 disregard it. (That is, we have reasserted the selection since this
686 request was generated.) */
688 if (changed_owner_time
!= CurrentTime
689 && local_selection_time
> changed_owner_time
)
692 /* Otherwise, we're really honest and truly being told to drop it.
693 Don't use Fdelq as that may QUIT;. */
695 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
696 Vselection_alist
= Fcdr (Vselection_alist
);
700 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
701 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
703 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
708 /* Let random lisp code notice that the selection has been stolen. */
711 Lisp_Object rest
= Vx_lost_selection_hooks
;
712 if (!EQ (rest
, Qunbound
))
713 for (; CONSP (rest
); rest
= Fcdr (rest
))
714 call1 (Fcar (rest
), selection_symbol
);
719 /* This stuff is so that INCR selections are reentrant (that is, so we can
720 be servicing multiple INCR selection requests simultaneously.) I haven't
721 actually tested that yet. */
723 static int prop_location_identifier
;
725 static Lisp_Object property_change_reply
;
726 static int property_change_reply_identifier
;
728 /* Keep a list of the property changes that are awaited. */
737 struct prop_location
*next
;
740 static struct prop_location
*property_change_wait_list
;
743 property_deleted_p (identifier
)
746 struct prop_location
*rest
= property_change_wait_list
;
748 if (rest
->identifier
== (int) identifier
)
755 /* Nonzero if any properties for DISPLAY and WINDOW
756 are on the list of what we are waiting for. */
759 waiting_for_other_props_on_window (display
, window
)
763 struct prop_location
*rest
= property_change_wait_list
;
765 if (rest
->display
== display
&& rest
->window
== window
)
772 /* Add an entry to the list of property changes we are waiting for.
773 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
774 The return value is a number that uniquely identifies
775 this awaited property change. */
778 expect_property_change (display
, window
, property
, state
)
781 Lisp_Object property
;
784 struct prop_location
*pl
785 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
786 pl
->identifier
= ++prop_location_identifier
;
787 pl
->display
= display
;
789 pl
->property
= property
;
790 pl
->desired_state
= state
;
791 pl
->next
= property_change_wait_list
;
792 property_change_wait_list
= pl
;
793 return pl
->identifier
;
796 /* Delete an entry from the list of property changes we are waiting for.
797 IDENTIFIER is the number that uniquely identifies the entry. */
800 unexpect_property_change (identifier
)
803 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
806 if (rest
->identifier
== identifier
)
809 prev
->next
= rest
->next
;
811 property_change_wait_list
= rest
->next
;
820 /* Remove the property change expectation element for IDENTIFIER. */
823 wait_for_property_change_unwind (identifierval
)
824 Lisp_Object identifierval
;
826 unexpect_property_change (XFASTINT (identifierval
));
829 /* Actually wait for a property change.
830 IDENTIFIER should be the value that expect_property_change returned. */
833 wait_for_property_change (identifier
)
836 int count
= specpdl_ptr
- specpdl
;
838 /* Make sure to do unexpect_property_change if we quit or err. */
839 record_unwind_protect (wait_for_property_change_unwind
,
840 make_number (identifier
));
842 XCONS (property_change_reply
)->car
= Qnil
;
843 property_change_reply_identifier
= identifier
;
844 secs
= x_selection_timeout
/ 1000;
845 usecs
= (x_selection_timeout
% 1000) * 1000;
846 wait_reading_process_input (secs
, usecs
, property_change_reply
, 0);
848 if (NILP (XCONS (property_change_reply
)->car
))
849 error ("timed out waiting for property-notify event");
851 unbind_to (count
, Qnil
);
854 /* Called from XTread_socket in response to a PropertyNotify event. */
857 x_handle_property_notify (event
)
858 XPropertyEvent
*event
;
860 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
863 if (rest
->property
== event
->atom
864 && rest
->window
== event
->window
865 && rest
->display
== event
->display
866 && rest
->desired_state
== event
->state
)
869 fprintf (stderr
, "Saw expected prop-%s on %s\n",
870 (event
->state
== PropertyDelete
? "delete" : "change"),
871 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
876 /* If this is the one wait_for_property_change is waiting for,
877 tell it to wake up. */
878 if (rest
->identifier
== property_change_reply_identifier
)
879 XCONS (property_change_reply
)->car
= Qt
;
882 prev
->next
= rest
->next
;
884 property_change_wait_list
= rest
->next
;
892 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
893 (event
->state
== PropertyDelete
? "delete" : "change"),
894 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
901 #if 0 /* #### MULTIPLE doesn't work yet */
904 fetch_multiple_target (event
)
905 XSelectionRequestEvent
*event
;
907 Display
*display
= event
->display
;
908 Window window
= event
->requestor
;
909 Atom target
= event
->target
;
910 Atom selection_atom
= event
->selection
;
915 x_get_window_property_as_lisp_data (display
, window
, target
,
916 QMULTIPLE
, selection_atom
));
920 copy_multiple_data (obj
)
927 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
929 CHECK_VECTOR (obj
, 0);
930 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
931 for (i
= 0; i
< size
; i
++)
933 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
934 CHECK_VECTOR (vec2
, 0);
935 if (XVECTOR (vec2
)->size
!= 2)
936 /* ??? Confusing error message */
937 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
938 Fcons (vec2
, Qnil
)));
939 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
940 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
941 = XVECTOR (vec2
)->contents
[0];
942 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
943 = XVECTOR (vec2
)->contents
[1];
951 /* Variables for communication with x_handle_selection_notify. */
952 static Atom reading_which_selection
;
953 static Lisp_Object reading_selection_reply
;
954 static Window reading_selection_window
;
956 /* Do protocol to read selection-data from the server.
957 Converts this to Lisp data and returns it. */
960 x_get_foreign_selection (selection_symbol
, target_type
)
961 Lisp_Object selection_symbol
, target_type
;
963 Display
*display
= x_current_display
;
965 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
967 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
969 Time requestor_time
= last_event_timestamp
;
970 Atom target_property
= Xatom_EMACS_TMP
;
971 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
975 if (CONSP (target_type
))
976 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
978 type_atom
= symbol_to_x_atom (display
, target_type
);
981 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
982 requestor_window
, requestor_time
);
985 /* Prepare to block until the reply has been read. */
986 reading_selection_window
= requestor_window
;
987 reading_which_selection
= selection_atom
;
988 XCONS (reading_selection_reply
)->car
= Qnil
;
991 /* This allows quits. Also, don't wait forever. */
992 secs
= x_selection_timeout
/ 1000;
993 usecs
= (x_selection_timeout
% 1000) * 1000;
994 wait_reading_process_input (secs
, usecs
, reading_selection_reply
, 0);
996 if (NILP (XCONS (reading_selection_reply
)->car
))
997 error ("timed out waiting for reply from selection owner");
999 /* Otherwise, the selection is waiting for us on the requested property. */
1001 x_get_window_property_as_lisp_data (display
, requestor_window
,
1002 target_property
, target_type
,
1006 /* Subroutines of x_get_window_property_as_lisp_data */
1009 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
1010 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1015 unsigned char **data_ret
;
1017 Atom
*actual_type_ret
;
1018 int *actual_format_ret
;
1019 unsigned long *actual_size_ret
;
1023 unsigned long bytes_remaining
;
1025 unsigned char *tmp_data
= 0;
1027 int buffer_size
= SELECTION_QUANTUM (display
);
1028 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1031 /* First probe the thing to find out how big it is. */
1032 result
= XGetWindowProperty (display
, window
, property
,
1033 0, 0, False
, AnyPropertyType
,
1034 actual_type_ret
, actual_format_ret
,
1036 &bytes_remaining
, &tmp_data
);
1037 if (result
!= Success
)
1044 xfree ((char *) tmp_data
);
1046 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1052 total_size
= bytes_remaining
+ 1;
1053 *data_ret
= (unsigned char *) xmalloc (total_size
);
1055 /* Now read, until weve gotten it all. */
1056 while (bytes_remaining
)
1059 int last
= bytes_remaining
;
1062 = XGetWindowProperty (display
, window
, property
,
1063 offset
/4, buffer_size
/4,
1066 actual_type_ret
, actual_format_ret
,
1067 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1069 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1071 /* If this doesn't return Success at this point, it means that
1072 some clod deleted the selection while we were in the midst of
1073 reading it. Deal with that, I guess....
1075 if (result
!= Success
) break;
1076 *actual_size_ret
*= *actual_format_ret
/ 8;
1077 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1078 offset
+= *actual_size_ret
;
1079 xfree ((char *) tmp_data
);
1084 *bytes_ret
= offset
;
1088 receive_incremental_selection (display
, window
, property
, target_type
,
1089 min_size_bytes
, data_ret
, size_bytes_ret
,
1090 type_ret
, format_ret
, size_ret
)
1094 Lisp_Object target_type
; /* for error messages only */
1095 unsigned int min_size_bytes
;
1096 unsigned char **data_ret
;
1097 int *size_bytes_ret
;
1099 unsigned long *size_ret
;
1104 *size_bytes_ret
= min_size_bytes
;
1105 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1107 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1110 /* At this point, we have read an INCR property.
1111 Delete the property to ack it.
1112 (But first, prepare to receive the next event in this handshake.)
1114 Now, we must loop, waiting for the sending window to put a value on
1115 that property, then reading the property, then deleting it to ack.
1116 We are done when the sender places a property of length 0.
1119 XSelectInput (display
, window
, STANDARD_EVENT_SET
| PropertyChangeMask
);
1120 XDeleteProperty (display
, window
, property
);
1121 prop_id
= expect_property_change (display
, window
, property
,
1128 unsigned char *tmp_data
;
1130 wait_for_property_change (prop_id
);
1131 /* expect it again immediately, because x_get_window_property may
1132 .. no it wont, I dont get it.
1133 .. Ok, I get it now, the Xt code that implements INCR is broken.
1135 x_get_window_property (display
, window
, property
,
1136 &tmp_data
, &tmp_size_bytes
,
1137 type_ret
, format_ret
, size_ret
, 1);
1139 if (tmp_size_bytes
== 0) /* we're done */
1142 fprintf (stderr
, " read INCR done\n");
1144 if (! waiting_for_other_props_on_window (display
, window
))
1145 XSelectInput (display
, window
, STANDARD_EVENT_SET
);
1146 unexpect_property_change (prop_id
);
1147 if (tmp_data
) xfree (tmp_data
);
1152 XDeleteProperty (display
, window
, property
);
1153 prop_id
= expect_property_change (display
, window
, property
,
1159 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1161 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1164 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1165 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1167 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1168 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1170 bcopy (tmp_data
, (*data_ret
) + offset
, tmp_size_bytes
);
1171 offset
+= tmp_size_bytes
;
1176 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1177 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1178 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1181 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1186 Lisp_Object target_type
; /* for error messages only */
1187 Atom selection_atom
; /* for error messages only */
1191 unsigned long actual_size
;
1192 unsigned char *data
= 0;
1196 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1197 &actual_type
, &actual_format
, &actual_size
, 1);
1200 int there_is_a_selection_owner
;
1202 there_is_a_selection_owner
1203 = XGetSelectionOwner (display
, selection_atom
);
1205 while (1) /* Note debugger can no longer return, so this is obsolete */
1207 there_is_a_selection_owner
?
1208 Fcons (build_string ("selection owner couldn't convert"),
1210 ? Fcons (target_type
,
1211 Fcons (x_atom_to_symbol (display
, actual_type
),
1213 : Fcons (target_type
, Qnil
))
1214 : Fcons (build_string ("no selection"),
1215 Fcons (x_atom_to_symbol (display
, selection_atom
),
1219 if (actual_type
== Xatom_INCR
)
1221 /* That wasn't really the data, just the beginning. */
1223 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1225 XFree ((char *) data
);
1227 receive_incremental_selection (display
, window
, property
, target_type
,
1228 min_size_bytes
, &data
, &bytes
,
1229 &actual_type
, &actual_format
,
1234 XDeleteProperty (display
, window
, property
);
1238 /* It's been read. Now convert it to a lisp object in some semi-rational
1240 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1241 actual_type
, actual_format
);
1243 xfree ((char *) data
);
1247 /* These functions convert from the selection data read from the server into
1248 something that we can use from Lisp, and vice versa.
1250 Type: Format: Size: Lisp Type:
1251 ----- ------- ----- -----------
1254 ATOM 32 > 1 Vector of Symbols
1256 * 16 > 1 Vector of Integers
1257 * 32 1 if <=16 bits: Integer
1258 if > 16 bits: Cons of top16, bot16
1259 * 32 > 1 Vector of the above
1261 When converting a Lisp number to C, it is assumed to be of format 16 if
1262 it is an integer, and of format 32 if it is a cons of two integers.
1264 When converting a vector of numbers from Lisp to C, it is assumed to be
1265 of format 16 if every element in the vector is an integer, and is assumed
1266 to be of format 32 if any element is a cons of two integers.
1268 When converting an object to C, it may be of the form (SYMBOL . <data>)
1269 where SYMBOL is what we should claim that the type is. Format and
1270 representation are as above. */
1275 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1277 unsigned char *data
;
1282 if (type
== Xatom_NULL
)
1285 /* Convert any 8-bit data to a string, for compactness. */
1286 else if (format
== 8)
1287 return make_string ((char *) data
, size
);
1289 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1290 a vector of symbols.
1292 else if (type
== XA_ATOM
)
1295 if (size
== sizeof (Atom
))
1296 return x_atom_to_symbol (display
, *((Atom
*) data
));
1299 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1300 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1301 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1306 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1307 If the number is > 16 bits, convert it to a cons of integers,
1308 16 bits in each half.
1310 else if (format
== 32 && size
== sizeof (long))
1311 return long_to_cons (((unsigned long *) data
) [0]);
1312 else if (format
== 16 && size
== sizeof (short))
1313 return make_number ((int) (((unsigned short *) data
) [0]));
1315 /* Convert any other kind of data to a vector of numbers, represented
1316 as above (as an integer, or a cons of two 16 bit integers.)
1318 else if (format
== 16)
1321 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1322 for (i
= 0; i
< size
/ 4; i
++)
1324 int j
= (int) ((unsigned short *) data
) [i
];
1325 Faset (v
, i
, make_number (j
));
1332 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1333 for (i
= 0; i
< size
/ 4; i
++)
1335 unsigned long j
= ((unsigned long *) data
) [i
];
1336 Faset (v
, i
, long_to_cons (j
));
1344 lisp_data_to_selection_data (display
, obj
,
1345 data_ret
, type_ret
, size_ret
,
1346 format_ret
, nofree_ret
)
1349 unsigned char **data_ret
;
1351 unsigned int *size_ret
;
1355 Lisp_Object type
= Qnil
;
1359 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1361 type
= XCONS (obj
)->car
;
1362 obj
= XCONS (obj
)->cdr
;
1363 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1364 obj
= XCONS (obj
)->car
;
1367 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1368 { /* This is not the same as declining */
1374 else if (STRINGP (obj
))
1377 *size_ret
= XSTRING (obj
)->size
;
1378 *data_ret
= XSTRING (obj
)->data
;
1380 if (NILP (type
)) type
= QSTRING
;
1382 else if (SYMBOLP (obj
))
1386 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1387 (*data_ret
) [sizeof (Atom
)] = 0;
1388 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1389 if (NILP (type
)) type
= QATOM
;
1391 else if (INTEGERP (obj
)
1392 && XINT (obj
) < 0xFFFF
1393 && XINT (obj
) > -0xFFFF)
1397 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1398 (*data_ret
) [sizeof (short)] = 0;
1399 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1400 if (NILP (type
)) type
= QINTEGER
;
1402 else if (INTEGERP (obj
)
1403 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1404 && (INTEGERP (XCONS (obj
)->cdr
)
1405 || (CONSP (XCONS (obj
)->cdr
)
1406 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1410 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1411 (*data_ret
) [sizeof (long)] = 0;
1412 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1413 if (NILP (type
)) type
= QINTEGER
;
1415 else if (VECTORP (obj
))
1417 /* Lisp_Vectors may represent a set of ATOMs;
1418 a set of 16 or 32 bit INTEGERs;
1419 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1423 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1424 /* This vector is an ATOM set */
1426 if (NILP (type
)) type
= QATOM
;
1427 *size_ret
= XVECTOR (obj
)->size
;
1429 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1430 for (i
= 0; i
< *size_ret
; i
++)
1431 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1432 (*(Atom
**) data_ret
) [i
]
1433 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1435 Fsignal (Qerror
, /* Qselection_error */
1437 ("all elements of selection vector must have same type"),
1438 Fcons (obj
, Qnil
)));
1440 #if 0 /* #### MULTIPLE doesn't work yet */
1441 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1442 /* This vector is an ATOM_PAIR set */
1444 if (NILP (type
)) type
= QATOM_PAIR
;
1445 *size_ret
= XVECTOR (obj
)->size
;
1447 *data_ret
= (unsigned char *)
1448 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1449 for (i
= 0; i
< *size_ret
; i
++)
1450 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1452 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1453 if (XVECTOR (pair
)->size
!= 2)
1456 ("elements of the vector must be vectors of exactly two elements"),
1457 Fcons (pair
, Qnil
)));
1459 (*(Atom
**) data_ret
) [i
* 2]
1460 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1461 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1462 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1467 ("all elements of the vector must be of the same type"),
1468 Fcons (obj
, Qnil
)));
1473 /* This vector is an INTEGER set, or something like it */
1475 *size_ret
= XVECTOR (obj
)->size
;
1476 if (NILP (type
)) type
= QINTEGER
;
1478 for (i
= 0; i
< *size_ret
; i
++)
1479 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1481 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1482 Fsignal (Qerror
, /* Qselection_error */
1484 ("elements of selection vector must be integers or conses of integers"),
1485 Fcons (obj
, Qnil
)));
1487 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1488 for (i
= 0; i
< *size_ret
; i
++)
1489 if (*format_ret
== 32)
1490 (*((unsigned long **) data_ret
)) [i
]
1491 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1493 (*((unsigned short **) data_ret
)) [i
]
1494 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1498 Fsignal (Qerror
, /* Qselection_error */
1499 Fcons (build_string ("unrecognised selection data"),
1500 Fcons (obj
, Qnil
)));
1502 *type_ret
= symbol_to_x_atom (display
, type
);
1506 clean_local_selection_data (obj
)
1510 && INTEGERP (XCONS (obj
)->car
)
1511 && CONSP (XCONS (obj
)->cdr
)
1512 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1513 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1514 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1517 && INTEGERP (XCONS (obj
)->car
)
1518 && INTEGERP (XCONS (obj
)->cdr
))
1520 if (XINT (XCONS (obj
)->car
) == 0)
1521 return XCONS (obj
)->cdr
;
1522 if (XINT (XCONS (obj
)->car
) == -1)
1523 return make_number (- XINT (XCONS (obj
)->cdr
));
1528 int size
= XVECTOR (obj
)->size
;
1531 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1532 copy
= Fmake_vector (size
, Qnil
);
1533 for (i
= 0; i
< size
; i
++)
1534 XVECTOR (copy
)->contents
[i
]
1535 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1541 /* Called from XTread_socket to handle SelectionNotify events.
1542 If it's the selection we are waiting for, stop waiting. */
1545 x_handle_selection_notify (event
)
1546 XSelectionEvent
*event
;
1548 if (event
->requestor
!= reading_selection_window
)
1550 if (event
->selection
!= reading_which_selection
)
1553 XCONS (reading_selection_reply
)->car
= Qt
;
1557 DEFUN ("x-own-selection-internal",
1558 Fx_own_selection_internal
, Sx_own_selection_internal
,
1560 "Assert an X selection of the given TYPE with the given VALUE.\n\
1561 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1562 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1563 VALUE is typically a string, or a cons of two markers, but may be\n\
1564 anything that the functions on `selection-converter-alist' know about.")
1565 (selection_name
, selection_value
)
1566 Lisp_Object selection_name
, selection_value
;
1568 CHECK_SYMBOL (selection_name
, 0);
1569 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1570 x_own_selection (selection_name
, selection_value
);
1571 return selection_value
;
1575 /* Request the selection value from the owner. If we are the owner,
1576 simply return our selection value. If we are not the owner, this
1577 will block until all of the data has arrived. */
1579 DEFUN ("x-get-selection-internal",
1580 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1581 "Return text selected from some X window.\n\
1582 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1583 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1584 TYPE is the type of data desired, typically `STRING'.")
1585 (selection_symbol
, target_type
)
1586 Lisp_Object selection_symbol
, target_type
;
1588 Lisp_Object val
= Qnil
;
1589 struct gcpro gcpro1
, gcpro2
;
1590 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1591 CHECK_SYMBOL (selection_symbol
, 0);
1593 #if 0 /* #### MULTIPLE doesn't work yet */
1594 if (CONSP (target_type
)
1595 && XCONS (target_type
)->car
== QMULTIPLE
)
1597 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1598 /* So we don't destructively modify this... */
1599 target_type
= copy_multiple_data (target_type
);
1603 CHECK_SYMBOL (target_type
, 0);
1605 val
= x_get_local_selection (selection_symbol
, target_type
);
1609 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1614 && SYMBOLP (XCONS (val
)->car
))
1616 val
= XCONS (val
)->cdr
;
1617 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1618 val
= XCONS (val
)->car
;
1620 val
= clean_local_selection_data (val
);
1626 DEFUN ("x-disown-selection-internal",
1627 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1628 "If we own the selection SELECTION, disown it.\n\
1629 Disowning it means there is no such selection.")
1631 Lisp_Object selection
;
1634 Display
*display
= x_current_display
;
1636 Atom selection_atom
;
1637 XSelectionClearEvent event
;
1639 CHECK_SYMBOL (selection
, 0);
1641 timestamp
= last_event_timestamp
;
1643 timestamp
= cons_to_long (time
);
1645 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1646 return Qnil
; /* Don't disown the selection when we're not the owner. */
1648 selection_atom
= symbol_to_x_atom (display
, selection
);
1651 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1654 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1655 generated for a window which owns the selection when that window sets
1656 the selection owner to None. The NCD server does, the MIT Sun4 server
1657 doesn't. So we synthesize one; this means we might get two, but
1658 that's ok, because the second one won't have any effect. */
1659 event
.display
= display
;
1660 event
.selection
= selection_atom
;
1661 event
.time
= timestamp
;
1662 x_handle_selection_clear (&event
);
1667 /* Get rid of all the selections in buffer BUFFER.
1668 This is used when we kill a buffer. */
1671 x_disown_buffer_selections (buffer
)
1675 struct buffer
*buf
= XBUFFER (buffer
);
1677 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1679 Lisp_Object elt
, value
;
1680 elt
= XCONS (tail
)->car
;
1681 value
= XCONS (elt
)->cdr
;
1682 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1683 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1684 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1688 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1690 "Whether the current Emacs process owns the given X Selection.\n\
1691 The arg should be the name of the selection in question, typically one of\n\
1692 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1693 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1694 For convenience, the symbol nil is the same as `PRIMARY',\n\
1695 and t is the same as `SECONDARY'.)")
1697 Lisp_Object selection
;
1699 CHECK_SYMBOL (selection
, 0);
1700 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1701 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1703 if (NILP (Fassq (selection
, Vselection_alist
)))
1708 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1710 "Whether there is an owner for the given X Selection.\n\
1711 The arg should be the name of the selection in question, typically one of\n\
1712 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1713 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1714 For convenience, the symbol nil is the same as `PRIMARY',\n\
1715 and t is the same as `SECONDARY'.)")
1717 Lisp_Object selection
;
1721 Display
*dpy
= x_current_display
;
1722 CHECK_SYMBOL (selection
, 0);
1723 if (!NILP (Fx_selection_owner_p (selection
)))
1725 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1726 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1727 atom
= symbol_to_x_atom (dpy
, selection
);
1731 owner
= XGetSelectionOwner (dpy
, atom
);
1733 return (owner
? Qt
: Qnil
);
1737 #ifdef CUT_BUFFER_SUPPORT
1739 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1741 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1743 initialize_cut_buffers (display
, window
)
1747 unsigned char *data
= (unsigned char *) "";
1749 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1750 PropModeAppend, data, 0)
1751 FROB (XA_CUT_BUFFER0
);
1752 FROB (XA_CUT_BUFFER1
);
1753 FROB (XA_CUT_BUFFER2
);
1754 FROB (XA_CUT_BUFFER3
);
1755 FROB (XA_CUT_BUFFER4
);
1756 FROB (XA_CUT_BUFFER5
);
1757 FROB (XA_CUT_BUFFER6
);
1758 FROB (XA_CUT_BUFFER7
);
1761 cut_buffers_initialized
= 1;
1765 #define CHECK_CUT_BUFFER(symbol,n) \
1766 { CHECK_SYMBOL ((symbol), (n)); \
1767 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1768 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1769 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1770 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1772 Fcons (build_string ("doesn't name a cut buffer"), \
1773 Fcons ((symbol), Qnil))); \
1776 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1777 Sx_get_cut_buffer_internal
, 1, 1, 0,
1778 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1782 Display
*display
= x_current_display
;
1783 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1785 unsigned char *data
;
1792 CHECK_CUT_BUFFER (buffer
, 0);
1793 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1795 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1796 &type
, &format
, &size
, 0);
1797 if (!data
) return Qnil
;
1799 if (format
!= 8 || type
!= XA_STRING
)
1801 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1802 Fcons (x_atom_to_symbol (display
, type
),
1803 Fcons (make_number (format
), Qnil
))));
1805 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1811 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1812 Sx_store_cut_buffer_internal
, 2, 2, 0,
1813 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1815 Lisp_Object buffer
, string
;
1817 Display
*display
= x_current_display
;
1818 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1820 unsigned char *data
;
1822 int bytes_remaining
;
1823 int max_bytes
= SELECTION_QUANTUM (display
);
1824 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1826 CHECK_CUT_BUFFER (buffer
, 0);
1827 CHECK_STRING (string
, 0);
1828 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1829 data
= (unsigned char *) XSTRING (string
)->data
;
1830 bytes
= XSTRING (string
)->size
;
1831 bytes_remaining
= bytes
;
1833 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1837 /* Don't mess up with an empty value. */
1838 if (!bytes_remaining
)
1839 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1840 PropModeReplace
, data
, 0);
1842 while (bytes_remaining
)
1844 int chunk
= (bytes_remaining
< max_bytes
1845 ? bytes_remaining
: max_bytes
);
1846 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1847 (bytes_remaining
== bytes
1852 bytes_remaining
-= chunk
;
1859 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1860 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1861 "Rotate the values of the cut buffers by the given number of steps;\n\
1862 positive means move values forward, negative means backward.")
1866 Display
*display
= x_current_display
;
1867 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1870 CHECK_NUMBER (n
, 0);
1871 if (XINT (n
) == 0) return n
;
1872 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1873 props
[0] = XA_CUT_BUFFER0
;
1874 props
[1] = XA_CUT_BUFFER1
;
1875 props
[2] = XA_CUT_BUFFER2
;
1876 props
[3] = XA_CUT_BUFFER3
;
1877 props
[4] = XA_CUT_BUFFER4
;
1878 props
[5] = XA_CUT_BUFFER5
;
1879 props
[6] = XA_CUT_BUFFER6
;
1880 props
[7] = XA_CUT_BUFFER7
;
1882 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1890 Xatoms_of_xselect ()
1892 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1895 /* Non-predefined atoms that we might end up using a lot */
1896 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1897 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1898 Xatom_TEXT
= ATOM ("TEXT");
1899 Xatom_DELETE
= ATOM ("DELETE");
1900 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1901 Xatom_INCR
= ATOM ("INCR");
1902 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1903 Xatom_TARGETS
= ATOM ("TARGETS");
1904 Xatom_NULL
= ATOM ("NULL");
1905 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1912 defsubr (&Sx_get_selection_internal
);
1913 defsubr (&Sx_own_selection_internal
);
1914 defsubr (&Sx_disown_selection_internal
);
1915 defsubr (&Sx_selection_owner_p
);
1916 defsubr (&Sx_selection_exists_p
);
1918 #ifdef CUT_BUFFER_SUPPORT
1919 defsubr (&Sx_get_cut_buffer_internal
);
1920 defsubr (&Sx_store_cut_buffer_internal
);
1921 defsubr (&Sx_rotate_cut_buffers_internal
);
1922 cut_buffers_initialized
= 0;
1925 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1926 staticpro (&reading_selection_reply
);
1927 reading_selection_window
= 0;
1928 reading_which_selection
= 0;
1930 property_change_wait_list
= 0;
1931 prop_location_identifier
= 0;
1932 property_change_reply
= Fcons (Qnil
, Qnil
);
1933 staticpro (&property_change_reply
);
1935 Vselection_alist
= Qnil
;
1936 staticpro (&Vselection_alist
);
1938 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1939 "An alist associating X Windows selection-types with functions.\n\
1940 These functions are called to convert the selection, with three args:\n\
1941 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1942 a desired type to which the selection should be converted;\n\
1943 and the local selection value (whatever was given to `x-own-selection').\n\
1945 The function should return the value to send to the X server\n\
1946 \(typically a string). A return value of nil\n\
1947 means that the conversion could not be done.\n\
1948 A return value which is the symbol `NULL'\n\
1949 means that a side-effect was executed,\n\
1950 and there is no meaningful selection value.");
1951 Vselection_converter_alist
= Qnil
;
1953 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1954 "A list of functions to be called when Emacs loses an X selection.\n\
1955 \(This happens when some other X client makes its own selection\n\
1956 or when a Lisp program explicitly clears the selection.)\n\
1957 The functions are called with one argument, the selection type\n\
1958 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1959 Vx_lost_selection_hooks
= Qnil
;
1961 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1962 "A list of functions to be called when Emacs answers a selection request.\n\
1963 The functions are called with four arguments:\n\
1964 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1965 - the selection-type which Emacs was asked to convert the\n\
1966 selection into before sending (for example, `STRING' or `LENGTH');\n\
1967 - a flag indicating success or failure for responding to the request.\n\
1968 We might have failed (and declined the request) for any number of reasons,\n\
1969 including being asked for a selection that we no longer own, or being asked\n\
1970 to convert into a type that we don't know about or that is inappropriate.\n\
1971 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
1972 it merely informs you that they have happened.");
1973 Vx_sent_selection_hooks
= Qnil
;
1975 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
1976 "Number of milliseconds to wait for a selection reply.\n\
1977 If the selection owner doens't reply in this time, we give up.\n\
1978 A value of 0 means wait as long as necessary. This is initialized from the\n\
1979 \"*selectionTimeout\" resource.");
1980 x_selection_timeout
= 0;
1982 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
1983 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
1984 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
1985 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
1986 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
1987 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1988 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
1989 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1990 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
1991 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
1992 QINCR
= intern ("INCR"); staticpro (&QINCR
);
1993 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
1994 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
1995 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
1996 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
1997 QNULL
= intern ("NULL"); staticpro (&QNULL
);
1999 #ifdef CUT_BUFFER_SUPPORT
2000 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
2001 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
2002 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
2003 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
2004 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
2005 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
2006 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
2007 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);