1 /* X Selection processing for emacs
2 Copyright (C) 1993, 1994 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 /* This converts a Lisp symbol to a server Atom, avoiding a server
110 roundtrip whenever possible. */
113 symbol_to_x_atom (display
, sym
)
118 if (NILP (sym
)) return 0;
119 if (EQ (sym
, QPRIMARY
)) return XA_PRIMARY
;
120 if (EQ (sym
, QSECONDARY
)) return XA_SECONDARY
;
121 if (EQ (sym
, QSTRING
)) return XA_STRING
;
122 if (EQ (sym
, QINTEGER
)) return XA_INTEGER
;
123 if (EQ (sym
, QATOM
)) return XA_ATOM
;
124 if (EQ (sym
, QCLIPBOARD
)) return Xatom_CLIPBOARD
;
125 if (EQ (sym
, QTIMESTAMP
)) return Xatom_TIMESTAMP
;
126 if (EQ (sym
, QTEXT
)) return Xatom_TEXT
;
127 if (EQ (sym
, QDELETE
)) return Xatom_DELETE
;
128 if (EQ (sym
, QMULTIPLE
)) return Xatom_MULTIPLE
;
129 if (EQ (sym
, QINCR
)) return Xatom_INCR
;
130 if (EQ (sym
, QEMACS_TMP
)) return Xatom_EMACS_TMP
;
131 if (EQ (sym
, QTARGETS
)) return Xatom_TARGETS
;
132 if (EQ (sym
, QNULL
)) return Xatom_NULL
;
133 #ifdef CUT_BUFFER_SUPPORT
134 if (EQ (sym
, QCUT_BUFFER0
)) return XA_CUT_BUFFER0
;
135 if (EQ (sym
, QCUT_BUFFER1
)) return XA_CUT_BUFFER1
;
136 if (EQ (sym
, QCUT_BUFFER2
)) return XA_CUT_BUFFER2
;
137 if (EQ (sym
, QCUT_BUFFER3
)) return XA_CUT_BUFFER3
;
138 if (EQ (sym
, QCUT_BUFFER4
)) return XA_CUT_BUFFER4
;
139 if (EQ (sym
, QCUT_BUFFER5
)) return XA_CUT_BUFFER5
;
140 if (EQ (sym
, QCUT_BUFFER6
)) return XA_CUT_BUFFER6
;
141 if (EQ (sym
, QCUT_BUFFER7
)) return XA_CUT_BUFFER7
;
143 if (!SYMBOLP (sym
)) abort ();
146 fprintf (stderr
, " XInternAtom %s\n", (char *) XSYMBOL (sym
)->name
->data
);
149 val
= XInternAtom (display
, (char *) XSYMBOL (sym
)->name
->data
, False
);
155 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
156 and calls to intern whenever possible. */
159 x_atom_to_symbol (display
, atom
)
165 if (! atom
) return Qnil
;
178 #ifdef CUT_BUFFER_SUPPORT
198 if (atom
== Xatom_CLIPBOARD
)
200 if (atom
== Xatom_TIMESTAMP
)
202 if (atom
== Xatom_TEXT
)
204 if (atom
== Xatom_DELETE
)
206 if (atom
== Xatom_MULTIPLE
)
208 if (atom
== Xatom_INCR
)
210 if (atom
== Xatom_EMACS_TMP
)
212 if (atom
== Xatom_TARGETS
)
214 if (atom
== Xatom_NULL
)
218 str
= XGetAtomName (display
, atom
);
221 fprintf (stderr
, " XGetAtomName --> %s\n", str
);
223 if (! str
) return Qnil
;
231 /* Do protocol to assert ourself as a selection owner.
232 Update the Vselection_alist so that we can reply to later requests for
236 x_own_selection (selection_name
, selection_value
)
237 Lisp_Object selection_name
, selection_value
;
239 Display
*display
= x_current_display
;
241 Window selecting_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
243 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
245 Time time
= last_event_timestamp
;
248 CHECK_SYMBOL (selection_name
, 0);
249 selection_atom
= symbol_to_x_atom (display
, selection_name
);
253 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
254 x_check_errors ("Can't set selection: %s");
258 /* Now update the local cache */
260 Lisp_Object selection_time
;
261 Lisp_Object selection_data
;
262 Lisp_Object prev_value
;
264 selection_time
= long_to_cons ((unsigned long) time
);
265 selection_data
= Fcons (selection_name
,
266 Fcons (selection_value
,
267 Fcons (selection_time
, Qnil
)));
268 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
270 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
272 /* If we already owned the selection, remove the old selection data.
273 Perhaps we should destructively modify it instead.
274 Don't use Fdelq as that may QUIT. */
275 if (!NILP (prev_value
))
277 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
278 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
279 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
281 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
288 /* Given a selection-name and desired type, look up our local copy of
289 the selection value and convert it to the type.
290 The value is nil or a string.
291 This function is used both for remote requests
292 and for local x-get-selection-internal.
294 This calls random Lisp code, and may signal or gc. */
297 x_get_local_selection (selection_symbol
, target_type
)
298 Lisp_Object selection_symbol
, target_type
;
300 Lisp_Object local_value
;
301 Lisp_Object handler_fn
, value
, type
, check
;
304 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
306 if (NILP (local_value
)) return Qnil
;
308 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
309 if (EQ (target_type
, QTIMESTAMP
))
312 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
315 else if (EQ (target_type
, QDELETE
))
318 Fx_disown_selection_internal
320 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
325 #if 0 /* #### MULTIPLE doesn't work yet */
326 else if (CONSP (target_type
)
327 && XCONS (target_type
)->car
== QMULTIPLE
)
332 pairs
= XCONS (target_type
)->cdr
;
333 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
++)
342 pair
= XVECTOR (pairs
)->contents
[i
];
343 XVECTOR (pair
)->contents
[1]
344 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
345 XVECTOR (pair
)->contents
[1]);
352 /* Don't allow a quit within the converter.
353 When the user types C-g, he would be surprised
354 if by luck it came during a converter. */
355 count
= specpdl_ptr
- specpdl
;
356 specbind (Qinhibit_quit
, Qt
);
358 CHECK_SYMBOL (target_type
, 0);
359 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
360 if (!NILP (handler_fn
))
361 value
= call3 (handler_fn
,
362 selection_symbol
, target_type
,
363 XCONS (XCONS (local_value
)->cdr
)->car
);
366 unbind_to (count
, Qnil
);
369 /* Make sure this value is of a type that we could transmit
370 to another X client. */
374 && SYMBOLP (XCONS (value
)->car
))
375 type
= XCONS (value
)->car
,
376 check
= XCONS (value
)->cdr
;
384 /* Check for a value that cons_to_long could handle. */
385 else if (CONSP (check
)
386 && INTEGERP (XCONS (check
)->car
)
387 && (INTEGERP (XCONS (check
)->cdr
)
389 (CONSP (XCONS (check
)->cdr
)
390 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
391 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
396 Fcons (build_string ("invalid data returned by selection-conversion function"),
397 Fcons (handler_fn
, Fcons (value
, Qnil
))));
400 /* Subroutines of x_reply_selection_request. */
402 /* Send a SelectionNotify event to the requestor with property=None,
403 meaning we were unable to do what they wanted. */
406 x_decline_selection_request (event
)
407 struct input_event
*event
;
409 XSelectionEvent reply
;
410 reply
.type
= SelectionNotify
;
411 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
412 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
413 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
414 reply
.time
= SELECTION_EVENT_TIME (event
);
415 reply
.target
= SELECTION_EVENT_TARGET (event
);
416 reply
.property
= None
;
419 XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
425 /* This is the selection request currently being processed.
426 It is set to zero when the request is fully processed. */
427 static struct input_event
*x_selection_current_request
;
429 /* Used as an unwind-protect clause so that, if a selection-converter signals
430 an error, we tell the requestor that we were unable to do what they wanted
431 before we throw to top-level or go into the debugger or whatever. */
434 x_selection_request_lisp_error (ignore
)
437 if (x_selection_current_request
!= 0)
438 x_decline_selection_request (x_selection_current_request
);
443 /* This stuff is so that INCR selections are reentrant (that is, so we can
444 be servicing multiple INCR selection requests simultaneously.) I haven't
445 actually tested that yet. */
447 /* Keep a list of the property changes that are awaited. */
457 struct prop_location
*next
;
460 static struct prop_location
*expect_property_change ();
461 static void wait_for_property_change ();
462 static void unexpect_property_change ();
463 static int waiting_for_other_props_on_window ();
465 static int prop_location_identifier
;
467 static Lisp_Object property_change_reply
;
469 static struct prop_location
*property_change_reply_object
;
471 static struct prop_location
*property_change_wait_list
;
473 /* Send the reply to a selection request event EVENT.
474 TYPE is the type of selection data requested.
475 DATA and SIZE describe the data to send, already converted.
476 FORMAT is the unit-size (in bits) of the data to be transmitted. */
479 x_reply_selection_request (event
, format
, data
, size
, type
)
480 struct input_event
*event
;
485 XSelectionEvent reply
;
486 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
487 Window window
= SELECTION_EVENT_REQUESTOR (event
);
489 int format_bytes
= format
/8;
490 int max_bytes
= SELECTION_QUANTUM (display
);
492 if (max_bytes
> MAX_SELECTION_QUANTUM
)
493 max_bytes
= MAX_SELECTION_QUANTUM
;
495 reply
.type
= SelectionNotify
;
496 reply
.display
= display
;
497 reply
.requestor
= window
;
498 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
499 reply
.time
= SELECTION_EVENT_TIME (event
);
500 reply
.target
= SELECTION_EVENT_TARGET (event
);
501 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
502 if (reply
.property
== None
)
503 reply
.property
= reply
.target
;
505 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
507 /* Store the data on the requested property.
508 If the selection is large, only store the first N bytes of it.
510 bytes_remaining
= size
* format_bytes
;
511 if (bytes_remaining
<= max_bytes
)
513 /* Send all the data at once, with minimal handshaking. */
515 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
518 XChangeProperty (display
, window
, reply
.property
, type
, format
,
519 PropModeReplace
, data
, size
);
520 /* At this point, the selection was successfully stored; ack it. */
521 XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
527 /* Send an INCR selection. */
528 struct prop_location
*wait_object
;
532 if (x_window_to_frame (window
)) /* #### debug */
533 error ("attempt to transfer an INCR to ourself!");
535 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
537 wait_object
= expect_property_change (display
, window
, reply
.property
,
540 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
541 32, PropModeReplace
, (unsigned char *)
542 &bytes_remaining
, 1);
543 XSelectInput (display
, window
, PropertyChangeMask
);
544 /* Tell 'em the INCR data is there... */
545 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
549 /* First, wait for the requestor to ack by deleting the property.
550 This can run random lisp code (process handlers) or signal. */
551 wait_for_property_change (wait_object
);
553 while (bytes_remaining
)
555 int i
= ((bytes_remaining
< max_bytes
)
562 = expect_property_change (display
, window
, reply
.property
,
565 fprintf (stderr
," INCR adding %d\n", i
);
567 /* Append the next chunk of data to the property. */
568 XChangeProperty (display
, window
, reply
.property
, type
, format
,
569 PropModeAppend
, data
, i
/ format_bytes
);
570 bytes_remaining
-= i
;
575 /* Now wait for the requestor to ack this chunk by deleting the
576 property. This can run random lisp code or signal.
578 wait_for_property_change (wait_object
);
580 /* Now write a zero-length chunk to the property to tell the requestor
583 fprintf (stderr
," INCR done\n");
586 if (! waiting_for_other_props_on_window (display
, window
))
587 XSelectInput (display
, window
, 0L);
589 XChangeProperty (display
, window
, reply
.property
, type
, format
,
590 PropModeReplace
, data
, 0);
596 /* Handle a SelectionRequest event EVENT.
597 This is called from keyboard.c when such an event is found in the queue. */
600 x_handle_selection_request (event
)
601 struct input_event
*event
;
603 struct gcpro gcpro1
, gcpro2
, gcpro3
;
604 Lisp_Object local_selection_data
;
605 Lisp_Object selection_symbol
;
606 Lisp_Object target_symbol
;
607 Lisp_Object converted_selection
;
608 Time local_selection_time
;
609 Lisp_Object successful_p
;
612 local_selection_data
= Qnil
;
613 target_symbol
= Qnil
;
614 converted_selection
= Qnil
;
617 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
619 selection_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
620 SELECTION_EVENT_SELECTION (event
));
622 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
624 if (NILP (local_selection_data
))
626 /* Someone asked for the selection, but we don't have it any more.
628 x_decline_selection_request (event
);
632 local_selection_time
= (Time
)
633 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
635 if (SELECTION_EVENT_TIME (event
) != CurrentTime
636 && local_selection_time
> SELECTION_EVENT_TIME (event
))
638 /* Someone asked for the selection, and we have one, but not the one
641 x_decline_selection_request (event
);
645 count
= specpdl_ptr
- specpdl
;
646 x_selection_current_request
= event
;
647 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
649 target_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
650 SELECTION_EVENT_TARGET (event
));
652 #if 0 /* #### MULTIPLE doesn't work yet */
653 if (EQ (target_symbol
, QMULTIPLE
))
654 target_symbol
= fetch_multiple_target (event
);
657 /* Convert lisp objects back into binary data */
660 = x_get_local_selection (selection_symbol
, target_symbol
);
662 if (! NILP (converted_selection
))
670 lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event
),
672 &data
, &type
, &size
, &format
, &nofree
);
674 x_reply_selection_request (event
, format
, data
, size
, type
);
677 /* Indicate we have successfully processed this event. */
678 x_selection_current_request
= 0;
683 unbind_to (count
, Qnil
);
689 /* Let random lisp code notice that the selection has been asked for. */
692 rest
= Vx_sent_selection_hooks
;
693 if (!EQ (rest
, Qunbound
))
694 for (; CONSP (rest
); rest
= Fcdr (rest
))
695 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
699 /* Handle a SelectionClear event EVENT, which indicates that some other
700 client cleared out our previously asserted selection.
701 This is called from keyboard.c when such an event is found in the queue. */
704 x_handle_selection_clear (event
)
705 struct input_event
*event
;
707 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
708 Atom selection
= SELECTION_EVENT_SELECTION (event
);
709 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
711 Lisp_Object selection_symbol
, local_selection_data
;
712 Time local_selection_time
;
714 selection_symbol
= x_atom_to_symbol (display
, selection
);
716 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
718 /* Well, we already believe that we don't own it, so that's just fine. */
719 if (NILP (local_selection_data
)) return;
721 local_selection_time
= (Time
)
722 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
724 /* This SelectionClear is for a selection that we no longer own, so we can
725 disregard it. (That is, we have reasserted the selection since this
726 request was generated.) */
728 if (changed_owner_time
!= CurrentTime
729 && local_selection_time
> changed_owner_time
)
732 /* Otherwise, we're really honest and truly being told to drop it.
733 Don't use Fdelq as that may QUIT;. */
735 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
736 Vselection_alist
= Fcdr (Vselection_alist
);
740 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
741 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
743 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
748 /* Let random lisp code notice that the selection has been stolen. */
752 rest
= Vx_lost_selection_hooks
;
753 if (!EQ (rest
, Qunbound
))
755 for (; CONSP (rest
); rest
= Fcdr (rest
))
756 call1 (Fcar (rest
), selection_symbol
);
757 prepare_menu_bars ();
758 redisplay_preserve_echo_area ();
764 /* Nonzero if any properties for DISPLAY and WINDOW
765 are on the list of what we are waiting for. */
768 waiting_for_other_props_on_window (display
, window
)
772 struct prop_location
*rest
= property_change_wait_list
;
774 if (rest
->display
== display
&& rest
->window
== window
)
781 /* Add an entry to the list of property changes we are waiting for.
782 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
783 The return value is a number that uniquely identifies
784 this awaited property change. */
786 static struct prop_location
*
787 expect_property_change (display
, window
, property
, state
)
790 Lisp_Object property
;
793 struct prop_location
*pl
794 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
795 pl
->identifier
= ++prop_location_identifier
;
796 pl
->display
= display
;
798 pl
->property
= property
;
799 pl
->desired_state
= state
;
800 pl
->next
= property_change_wait_list
;
802 property_change_wait_list
= pl
;
806 /* Delete an entry from the list of property changes we are waiting for.
807 IDENTIFIER is the number that uniquely identifies the entry. */
810 unexpect_property_change (location
)
811 struct prop_location
*location
;
813 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
816 if (rest
== location
)
819 prev
->next
= rest
->next
;
821 property_change_wait_list
= rest
->next
;
830 /* Remove the property change expectation element for IDENTIFIER. */
833 wait_for_property_change_unwind (identifierval
)
834 Lisp_Object identifierval
;
836 unexpect_property_change (XPNTR (identifierval
));
839 /* Actually wait for a property change.
840 IDENTIFIER should be the value that expect_property_change returned. */
843 wait_for_property_change (location
)
844 struct prop_location
*location
;
847 int count
= specpdl_ptr
- specpdl
;
850 XSET (tem
, Lisp_Cons
, location
);
852 /* Make sure to do unexpect_property_change if we quit or err. */
853 record_unwind_protect (wait_for_property_change_unwind
, tem
);
855 XCONS (property_change_reply
)->car
= Qnil
;
857 if (! location
->arrived
)
859 property_change_reply_object
= location
;
860 secs
= x_selection_timeout
/ 1000;
861 usecs
= (x_selection_timeout
% 1000) * 1000;
862 wait_reading_process_input (secs
, usecs
, property_change_reply
, 0);
864 if (NILP (XCONS (property_change_reply
)->car
))
865 error ("timed out waiting for property-notify event");
868 unbind_to (count
, Qnil
);
871 /* Called from XTread_socket in response to a PropertyNotify event. */
874 x_handle_property_notify (event
)
875 XPropertyEvent
*event
;
877 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
880 if (rest
->property
== event
->atom
881 && rest
->window
== event
->window
882 && rest
->display
== event
->display
883 && rest
->desired_state
== event
->state
)
886 fprintf (stderr
, "Saw expected prop-%s on %s\n",
887 (event
->state
== PropertyDelete
? "delete" : "change"),
888 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
895 /* If this is the one wait_for_property_change is waiting for,
896 tell it to wake up. */
897 if (rest
== property_change_reply_object
)
898 XCONS (property_change_reply
)->car
= Qt
;
901 prev
->next
= rest
->next
;
903 property_change_wait_list
= rest
->next
;
911 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
912 (event
->state
== PropertyDelete
? "delete" : "change"),
913 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
920 #if 0 /* #### MULTIPLE doesn't work yet */
923 fetch_multiple_target (event
)
924 XSelectionRequestEvent
*event
;
926 Display
*display
= event
->display
;
927 Window window
= event
->requestor
;
928 Atom target
= event
->target
;
929 Atom selection_atom
= event
->selection
;
934 x_get_window_property_as_lisp_data (display
, window
, target
,
935 QMULTIPLE
, selection_atom
));
939 copy_multiple_data (obj
)
946 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
948 CHECK_VECTOR (obj
, 0);
949 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
950 for (i
= 0; i
< size
; i
++)
952 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
953 CHECK_VECTOR (vec2
, 0);
954 if (XVECTOR (vec2
)->size
!= 2)
955 /* ??? Confusing error message */
956 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
957 Fcons (vec2
, Qnil
)));
958 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
959 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
960 = XVECTOR (vec2
)->contents
[0];
961 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
962 = XVECTOR (vec2
)->contents
[1];
970 /* Variables for communication with x_handle_selection_notify. */
971 static Atom reading_which_selection
;
972 static Lisp_Object reading_selection_reply
;
973 static Window reading_selection_window
;
975 /* Do protocol to read selection-data from the server.
976 Converts this to Lisp data and returns it. */
979 x_get_foreign_selection (selection_symbol
, target_type
)
980 Lisp_Object selection_symbol
, target_type
;
982 Display
*display
= x_current_display
;
984 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
986 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
988 Time requestor_time
= last_event_timestamp
;
989 Atom target_property
= Xatom_EMACS_TMP
;
990 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
994 if (CONSP (target_type
))
995 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
997 type_atom
= symbol_to_x_atom (display
, target_type
);
1001 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
1002 requestor_window
, requestor_time
);
1005 /* Prepare to block until the reply has been read. */
1006 reading_selection_window
= requestor_window
;
1007 reading_which_selection
= selection_atom
;
1008 XCONS (reading_selection_reply
)->car
= Qnil
;
1011 /* This allows quits. Also, don't wait forever. */
1012 secs
= x_selection_timeout
/ 1000;
1013 usecs
= (x_selection_timeout
% 1000) * 1000;
1014 wait_reading_process_input (secs
, usecs
, reading_selection_reply
, 0);
1017 x_check_errors ("Cannot get selection: %s");
1018 x_uncatch_errors ();
1021 if (NILP (XCONS (reading_selection_reply
)->car
))
1022 error ("timed out waiting for reply from selection owner");
1024 /* Otherwise, the selection is waiting for us on the requested property. */
1026 x_get_window_property_as_lisp_data (display
, requestor_window
,
1027 target_property
, target_type
,
1031 /* Subroutines of x_get_window_property_as_lisp_data */
1034 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
1035 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1040 unsigned char **data_ret
;
1042 Atom
*actual_type_ret
;
1043 int *actual_format_ret
;
1044 unsigned long *actual_size_ret
;
1048 unsigned long bytes_remaining
;
1050 unsigned char *tmp_data
= 0;
1052 int buffer_size
= SELECTION_QUANTUM (display
);
1053 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1056 /* First probe the thing to find out how big it is. */
1057 result
= XGetWindowProperty (display
, window
, property
,
1058 0, 0, False
, AnyPropertyType
,
1059 actual_type_ret
, actual_format_ret
,
1061 &bytes_remaining
, &tmp_data
);
1062 if (result
!= Success
)
1069 xfree ((char *) tmp_data
);
1071 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1077 total_size
= bytes_remaining
+ 1;
1078 *data_ret
= (unsigned char *) xmalloc (total_size
);
1080 /* Now read, until weve gotten it all. */
1081 while (bytes_remaining
)
1084 int last
= bytes_remaining
;
1087 = XGetWindowProperty (display
, window
, property
,
1088 offset
/4, buffer_size
/4,
1091 actual_type_ret
, actual_format_ret
,
1092 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1094 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1096 /* If this doesn't return Success at this point, it means that
1097 some clod deleted the selection while we were in the midst of
1098 reading it. Deal with that, I guess....
1100 if (result
!= Success
) break;
1101 *actual_size_ret
*= *actual_format_ret
/ 8;
1102 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1103 offset
+= *actual_size_ret
;
1104 xfree ((char *) tmp_data
);
1109 *bytes_ret
= offset
;
1113 receive_incremental_selection (display
, window
, property
, target_type
,
1114 min_size_bytes
, data_ret
, size_bytes_ret
,
1115 type_ret
, format_ret
, size_ret
)
1119 Lisp_Object target_type
; /* for error messages only */
1120 unsigned int min_size_bytes
;
1121 unsigned char **data_ret
;
1122 int *size_bytes_ret
;
1124 unsigned long *size_ret
;
1128 struct prop_location
*wait_object
;
1129 *size_bytes_ret
= min_size_bytes
;
1130 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1132 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1135 /* At this point, we have read an INCR property.
1136 Delete the property to ack it.
1137 (But first, prepare to receive the next event in this handshake.)
1139 Now, we must loop, waiting for the sending window to put a value on
1140 that property, then reading the property, then deleting it to ack.
1141 We are done when the sender places a property of length 0.
1144 XSelectInput (display
, window
, STANDARD_EVENT_SET
| PropertyChangeMask
);
1145 XDeleteProperty (display
, window
, property
);
1146 wait_object
= expect_property_change (display
, window
, property
,
1153 unsigned char *tmp_data
;
1155 wait_for_property_change (wait_object
);
1156 /* expect it again immediately, because x_get_window_property may
1157 .. no it wont, I dont get it.
1158 .. Ok, I get it now, the Xt code that implements INCR is broken.
1160 x_get_window_property (display
, window
, property
,
1161 &tmp_data
, &tmp_size_bytes
,
1162 type_ret
, format_ret
, size_ret
, 1);
1164 if (tmp_size_bytes
== 0) /* we're done */
1167 fprintf (stderr
, " read INCR done\n");
1169 if (! waiting_for_other_props_on_window (display
, window
))
1170 XSelectInput (display
, window
, STANDARD_EVENT_SET
);
1171 unexpect_property_change (wait_object
);
1172 if (tmp_data
) xfree (tmp_data
);
1177 XDeleteProperty (display
, window
, property
);
1178 wait_object
= expect_property_change (display
, window
, property
,
1184 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1186 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1189 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1190 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1192 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1193 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1195 bcopy (tmp_data
, (*data_ret
) + offset
, tmp_size_bytes
);
1196 offset
+= tmp_size_bytes
;
1201 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1202 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1203 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1206 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1211 Lisp_Object target_type
; /* for error messages only */
1212 Atom selection_atom
; /* for error messages only */
1216 unsigned long actual_size
;
1217 unsigned char *data
= 0;
1221 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1222 &actual_type
, &actual_format
, &actual_size
, 1);
1225 int there_is_a_selection_owner
;
1227 there_is_a_selection_owner
1228 = XGetSelectionOwner (display
, selection_atom
);
1230 while (1) /* Note debugger can no longer return, so this is obsolete */
1232 there_is_a_selection_owner
?
1233 Fcons (build_string ("selection owner couldn't convert"),
1235 ? Fcons (target_type
,
1236 Fcons (x_atom_to_symbol (display
, actual_type
),
1238 : Fcons (target_type
, Qnil
))
1239 : Fcons (build_string ("no selection"),
1240 Fcons (x_atom_to_symbol (display
, selection_atom
),
1244 if (actual_type
== Xatom_INCR
)
1246 /* That wasn't really the data, just the beginning. */
1248 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1250 XFree ((char *) data
);
1252 receive_incremental_selection (display
, window
, property
, target_type
,
1253 min_size_bytes
, &data
, &bytes
,
1254 &actual_type
, &actual_format
,
1259 XDeleteProperty (display
, window
, property
);
1263 /* It's been read. Now convert it to a lisp object in some semi-rational
1265 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1266 actual_type
, actual_format
);
1268 xfree ((char *) data
);
1272 /* These functions convert from the selection data read from the server into
1273 something that we can use from Lisp, and vice versa.
1275 Type: Format: Size: Lisp Type:
1276 ----- ------- ----- -----------
1279 ATOM 32 > 1 Vector of Symbols
1281 * 16 > 1 Vector of Integers
1282 * 32 1 if <=16 bits: Integer
1283 if > 16 bits: Cons of top16, bot16
1284 * 32 > 1 Vector of the above
1286 When converting a Lisp number to C, it is assumed to be of format 16 if
1287 it is an integer, and of format 32 if it is a cons of two integers.
1289 When converting a vector of numbers from Lisp to C, it is assumed to be
1290 of format 16 if every element in the vector is an integer, and is assumed
1291 to be of format 32 if any element is a cons of two integers.
1293 When converting an object to C, it may be of the form (SYMBOL . <data>)
1294 where SYMBOL is what we should claim that the type is. Format and
1295 representation are as above. */
1300 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1302 unsigned char *data
;
1307 if (type
== Xatom_NULL
)
1310 /* Convert any 8-bit data to a string, for compactness. */
1311 else if (format
== 8)
1312 return make_string ((char *) data
, size
);
1314 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1315 a vector of symbols.
1317 else if (type
== XA_ATOM
)
1320 if (size
== sizeof (Atom
))
1321 return x_atom_to_symbol (display
, *((Atom
*) data
));
1324 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1325 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1326 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1331 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1332 If the number is > 16 bits, convert it to a cons of integers,
1333 16 bits in each half.
1335 else if (format
== 32 && size
== sizeof (long))
1336 return long_to_cons (((unsigned long *) data
) [0]);
1337 else if (format
== 16 && size
== sizeof (short))
1338 return make_number ((int) (((unsigned short *) data
) [0]));
1340 /* Convert any other kind of data to a vector of numbers, represented
1341 as above (as an integer, or a cons of two 16 bit integers.)
1343 else if (format
== 16)
1346 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1347 for (i
= 0; i
< size
/ 4; i
++)
1349 int j
= (int) ((unsigned short *) data
) [i
];
1350 Faset (v
, i
, make_number (j
));
1357 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1358 for (i
= 0; i
< size
/ 4; i
++)
1360 unsigned long j
= ((unsigned long *) data
) [i
];
1361 Faset (v
, i
, long_to_cons (j
));
1369 lisp_data_to_selection_data (display
, obj
,
1370 data_ret
, type_ret
, size_ret
,
1371 format_ret
, nofree_ret
)
1374 unsigned char **data_ret
;
1376 unsigned int *size_ret
;
1380 Lisp_Object type
= Qnil
;
1384 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1386 type
= XCONS (obj
)->car
;
1387 obj
= XCONS (obj
)->cdr
;
1388 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1389 obj
= XCONS (obj
)->car
;
1392 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1393 { /* This is not the same as declining */
1399 else if (STRINGP (obj
))
1402 *size_ret
= XSTRING (obj
)->size
;
1403 *data_ret
= XSTRING (obj
)->data
;
1405 if (NILP (type
)) type
= QSTRING
;
1407 else if (SYMBOLP (obj
))
1411 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1412 (*data_ret
) [sizeof (Atom
)] = 0;
1413 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1414 if (NILP (type
)) type
= QATOM
;
1416 else if (INTEGERP (obj
)
1417 && XINT (obj
) < 0xFFFF
1418 && XINT (obj
) > -0xFFFF)
1422 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1423 (*data_ret
) [sizeof (short)] = 0;
1424 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1425 if (NILP (type
)) type
= QINTEGER
;
1427 else if (INTEGERP (obj
)
1428 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1429 && (INTEGERP (XCONS (obj
)->cdr
)
1430 || (CONSP (XCONS (obj
)->cdr
)
1431 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1435 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1436 (*data_ret
) [sizeof (long)] = 0;
1437 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1438 if (NILP (type
)) type
= QINTEGER
;
1440 else if (VECTORP (obj
))
1442 /* Lisp_Vectors may represent a set of ATOMs;
1443 a set of 16 or 32 bit INTEGERs;
1444 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1448 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1449 /* This vector is an ATOM set */
1451 if (NILP (type
)) type
= QATOM
;
1452 *size_ret
= XVECTOR (obj
)->size
;
1454 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1455 for (i
= 0; i
< *size_ret
; i
++)
1456 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1457 (*(Atom
**) data_ret
) [i
]
1458 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1460 Fsignal (Qerror
, /* Qselection_error */
1462 ("all elements of selection vector must have same type"),
1463 Fcons (obj
, Qnil
)));
1465 #if 0 /* #### MULTIPLE doesn't work yet */
1466 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1467 /* This vector is an ATOM_PAIR set */
1469 if (NILP (type
)) type
= QATOM_PAIR
;
1470 *size_ret
= XVECTOR (obj
)->size
;
1472 *data_ret
= (unsigned char *)
1473 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1474 for (i
= 0; i
< *size_ret
; i
++)
1475 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1477 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1478 if (XVECTOR (pair
)->size
!= 2)
1481 ("elements of the vector must be vectors of exactly two elements"),
1482 Fcons (pair
, Qnil
)));
1484 (*(Atom
**) data_ret
) [i
* 2]
1485 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1486 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1487 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1492 ("all elements of the vector must be of the same type"),
1493 Fcons (obj
, Qnil
)));
1498 /* This vector is an INTEGER set, or something like it */
1500 *size_ret
= XVECTOR (obj
)->size
;
1501 if (NILP (type
)) type
= QINTEGER
;
1503 for (i
= 0; i
< *size_ret
; i
++)
1504 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1506 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1507 Fsignal (Qerror
, /* Qselection_error */
1509 ("elements of selection vector must be integers or conses of integers"),
1510 Fcons (obj
, Qnil
)));
1512 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1513 for (i
= 0; i
< *size_ret
; i
++)
1514 if (*format_ret
== 32)
1515 (*((unsigned long **) data_ret
)) [i
]
1516 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1518 (*((unsigned short **) data_ret
)) [i
]
1519 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1523 Fsignal (Qerror
, /* Qselection_error */
1524 Fcons (build_string ("unrecognised selection data"),
1525 Fcons (obj
, Qnil
)));
1527 *type_ret
= symbol_to_x_atom (display
, type
);
1531 clean_local_selection_data (obj
)
1535 && INTEGERP (XCONS (obj
)->car
)
1536 && CONSP (XCONS (obj
)->cdr
)
1537 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1538 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1539 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1542 && INTEGERP (XCONS (obj
)->car
)
1543 && INTEGERP (XCONS (obj
)->cdr
))
1545 if (XINT (XCONS (obj
)->car
) == 0)
1546 return XCONS (obj
)->cdr
;
1547 if (XINT (XCONS (obj
)->car
) == -1)
1548 return make_number (- XINT (XCONS (obj
)->cdr
));
1553 int size
= XVECTOR (obj
)->size
;
1556 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1557 copy
= Fmake_vector (size
, Qnil
);
1558 for (i
= 0; i
< size
; i
++)
1559 XVECTOR (copy
)->contents
[i
]
1560 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1566 /* Called from XTread_socket to handle SelectionNotify events.
1567 If it's the selection we are waiting for, stop waiting. */
1570 x_handle_selection_notify (event
)
1571 XSelectionEvent
*event
;
1573 if (event
->requestor
!= reading_selection_window
)
1575 if (event
->selection
!= reading_which_selection
)
1578 XCONS (reading_selection_reply
)->car
= Qt
;
1582 DEFUN ("x-own-selection-internal",
1583 Fx_own_selection_internal
, Sx_own_selection_internal
,
1585 "Assert an X selection of the given TYPE with the given VALUE.\n\
1586 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1587 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1588 VALUE is typically a string, or a cons of two markers, but may be\n\
1589 anything that the functions on `selection-converter-alist' know about.")
1590 (selection_name
, selection_value
)
1591 Lisp_Object selection_name
, selection_value
;
1594 CHECK_SYMBOL (selection_name
, 0);
1595 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1596 x_own_selection (selection_name
, selection_value
);
1597 return selection_value
;
1601 /* Request the selection value from the owner. If we are the owner,
1602 simply return our selection value. If we are not the owner, this
1603 will block until all of the data has arrived. */
1605 DEFUN ("x-get-selection-internal",
1606 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1607 "Return text selected from some X window.\n\
1608 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1609 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1610 TYPE is the type of data desired, typically `STRING'.")
1611 (selection_symbol
, target_type
)
1612 Lisp_Object selection_symbol
, target_type
;
1614 Lisp_Object val
= Qnil
;
1615 struct gcpro gcpro1
, gcpro2
;
1616 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1618 CHECK_SYMBOL (selection_symbol
, 0);
1620 #if 0 /* #### MULTIPLE doesn't work yet */
1621 if (CONSP (target_type
)
1622 && XCONS (target_type
)->car
== QMULTIPLE
)
1624 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1625 /* So we don't destructively modify this... */
1626 target_type
= copy_multiple_data (target_type
);
1630 CHECK_SYMBOL (target_type
, 0);
1632 val
= x_get_local_selection (selection_symbol
, target_type
);
1636 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1641 && SYMBOLP (XCONS (val
)->car
))
1643 val
= XCONS (val
)->cdr
;
1644 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1645 val
= XCONS (val
)->car
;
1647 val
= clean_local_selection_data (val
);
1653 DEFUN ("x-disown-selection-internal",
1654 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1655 "If we own the selection SELECTION, disown it.\n\
1656 Disowning it means there is no such selection.")
1658 Lisp_Object selection
;
1661 Display
*display
= x_current_display
;
1663 Atom selection_atom
;
1664 XSelectionClearEvent event
;
1667 CHECK_SYMBOL (selection
, 0);
1669 timestamp
= last_event_timestamp
;
1671 timestamp
= cons_to_long (time
);
1673 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1674 return Qnil
; /* Don't disown the selection when we're not the owner. */
1676 selection_atom
= symbol_to_x_atom (display
, selection
);
1679 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1682 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1683 generated for a window which owns the selection when that window sets
1684 the selection owner to None. The NCD server does, the MIT Sun4 server
1685 doesn't. So we synthesize one; this means we might get two, but
1686 that's ok, because the second one won't have any effect. */
1687 SELECTION_EVENT_DISPLAY (&event
) = display
;
1688 SELECTION_EVENT_SELECTION (&event
) = selection_atom
;
1689 SELECTION_EVENT_TIME (&event
) = timestamp
;
1690 x_handle_selection_clear (&event
);
1695 /* Get rid of all the selections in buffer BUFFER.
1696 This is used when we kill a buffer. */
1699 x_disown_buffer_selections (buffer
)
1703 struct buffer
*buf
= XBUFFER (buffer
);
1705 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1707 Lisp_Object elt
, value
;
1708 elt
= XCONS (tail
)->car
;
1709 value
= XCONS (elt
)->cdr
;
1710 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1711 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1712 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1716 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1718 "Whether the current Emacs process owns the given X Selection.\n\
1719 The arg should be the name of the selection in question, typically one of\n\
1720 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1721 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1722 For convenience, the symbol nil is the same as `PRIMARY',\n\
1723 and t is the same as `SECONDARY'.)")
1725 Lisp_Object selection
;
1728 CHECK_SYMBOL (selection
, 0);
1729 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1730 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1732 if (NILP (Fassq (selection
, Vselection_alist
)))
1737 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1739 "Whether there is an owner for the given X Selection.\n\
1740 The arg should be the name of the selection in question, typically one of\n\
1741 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1742 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1743 For convenience, the symbol nil is the same as `PRIMARY',\n\
1744 and t is the same as `SECONDARY'.)")
1746 Lisp_Object selection
;
1750 Display
*dpy
= x_current_display
;
1752 CHECK_SYMBOL (selection
, 0);
1753 if (!NILP (Fx_selection_owner_p (selection
)))
1755 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1756 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1757 atom
= symbol_to_x_atom (dpy
, selection
);
1761 owner
= XGetSelectionOwner (dpy
, atom
);
1763 return (owner
? Qt
: Qnil
);
1767 #ifdef CUT_BUFFER_SUPPORT
1769 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1771 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1773 initialize_cut_buffers (display
, window
)
1777 unsigned char *data
= (unsigned char *) "";
1779 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1780 PropModeAppend, data, 0)
1781 FROB (XA_CUT_BUFFER0
);
1782 FROB (XA_CUT_BUFFER1
);
1783 FROB (XA_CUT_BUFFER2
);
1784 FROB (XA_CUT_BUFFER3
);
1785 FROB (XA_CUT_BUFFER4
);
1786 FROB (XA_CUT_BUFFER5
);
1787 FROB (XA_CUT_BUFFER6
);
1788 FROB (XA_CUT_BUFFER7
);
1791 cut_buffers_initialized
= 1;
1795 #define CHECK_CUT_BUFFER(symbol,n) \
1796 { CHECK_SYMBOL ((symbol), (n)); \
1797 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1798 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1799 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1800 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1802 Fcons (build_string ("doesn't name a cut buffer"), \
1803 Fcons ((symbol), Qnil))); \
1806 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1807 Sx_get_cut_buffer_internal
, 1, 1, 0,
1808 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1812 Display
*display
= x_current_display
;
1813 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1815 unsigned char *data
;
1823 CHECK_CUT_BUFFER (buffer
, 0);
1824 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1826 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1827 &type
, &format
, &size
, 0);
1828 if (!data
) return Qnil
;
1830 if (format
!= 8 || type
!= XA_STRING
)
1832 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1833 Fcons (x_atom_to_symbol (display
, type
),
1834 Fcons (make_number (format
), Qnil
))));
1836 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1842 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1843 Sx_store_cut_buffer_internal
, 2, 2, 0,
1844 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1846 Lisp_Object buffer
, string
;
1848 Display
*display
= x_current_display
;
1849 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1851 unsigned char *data
;
1853 int bytes_remaining
;
1854 int max_bytes
= SELECTION_QUANTUM (display
);
1855 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1858 CHECK_CUT_BUFFER (buffer
, 0);
1859 CHECK_STRING (string
, 0);
1860 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1861 data
= (unsigned char *) XSTRING (string
)->data
;
1862 bytes
= XSTRING (string
)->size
;
1863 bytes_remaining
= bytes
;
1865 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1869 /* Don't mess up with an empty value. */
1870 if (!bytes_remaining
)
1871 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1872 PropModeReplace
, data
, 0);
1874 while (bytes_remaining
)
1876 int chunk
= (bytes_remaining
< max_bytes
1877 ? bytes_remaining
: max_bytes
);
1878 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1879 (bytes_remaining
== bytes
1884 bytes_remaining
-= chunk
;
1891 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1892 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1893 "Rotate the values of the cut buffers by the given number of steps;\n\
1894 positive means move values forward, negative means backward.")
1898 Display
*display
= x_current_display
;
1899 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1903 CHECK_NUMBER (n
, 0);
1904 if (XINT (n
) == 0) return n
;
1905 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1906 props
[0] = XA_CUT_BUFFER0
;
1907 props
[1] = XA_CUT_BUFFER1
;
1908 props
[2] = XA_CUT_BUFFER2
;
1909 props
[3] = XA_CUT_BUFFER3
;
1910 props
[4] = XA_CUT_BUFFER4
;
1911 props
[5] = XA_CUT_BUFFER5
;
1912 props
[6] = XA_CUT_BUFFER6
;
1913 props
[7] = XA_CUT_BUFFER7
;
1915 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1923 Xatoms_of_xselect ()
1925 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1928 /* Non-predefined atoms that we might end up using a lot */
1929 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1930 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1931 Xatom_TEXT
= ATOM ("TEXT");
1932 Xatom_DELETE
= ATOM ("DELETE");
1933 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1934 Xatom_INCR
= ATOM ("INCR");
1935 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1936 Xatom_TARGETS
= ATOM ("TARGETS");
1937 Xatom_NULL
= ATOM ("NULL");
1938 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1945 defsubr (&Sx_get_selection_internal
);
1946 defsubr (&Sx_own_selection_internal
);
1947 defsubr (&Sx_disown_selection_internal
);
1948 defsubr (&Sx_selection_owner_p
);
1949 defsubr (&Sx_selection_exists_p
);
1951 #ifdef CUT_BUFFER_SUPPORT
1952 defsubr (&Sx_get_cut_buffer_internal
);
1953 defsubr (&Sx_store_cut_buffer_internal
);
1954 defsubr (&Sx_rotate_cut_buffers_internal
);
1955 cut_buffers_initialized
= 0;
1958 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1959 staticpro (&reading_selection_reply
);
1960 reading_selection_window
= 0;
1961 reading_which_selection
= 0;
1963 property_change_wait_list
= 0;
1964 prop_location_identifier
= 0;
1965 property_change_reply
= Fcons (Qnil
, Qnil
);
1966 staticpro (&property_change_reply
);
1968 Vselection_alist
= Qnil
;
1969 staticpro (&Vselection_alist
);
1971 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1972 "An alist associating X Windows selection-types with functions.\n\
1973 These functions are called to convert the selection, with three args:\n\
1974 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1975 a desired type to which the selection should be converted;\n\
1976 and the local selection value (whatever was given to `x-own-selection').\n\
1978 The function should return the value to send to the X server\n\
1979 \(typically a string). A return value of nil\n\
1980 means that the conversion could not be done.\n\
1981 A return value which is the symbol `NULL'\n\
1982 means that a side-effect was executed,\n\
1983 and there is no meaningful selection value.");
1984 Vselection_converter_alist
= Qnil
;
1986 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1987 "A list of functions to be called when Emacs loses an X selection.\n\
1988 \(This happens when some other X client makes its own selection\n\
1989 or when a Lisp program explicitly clears the selection.)\n\
1990 The functions are called with one argument, the selection type\n\
1991 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1992 Vx_lost_selection_hooks
= Qnil
;
1994 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1995 "A list of functions to be called when Emacs answers a selection request.\n\
1996 The functions are called with four arguments:\n\
1997 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1998 - the selection-type which Emacs was asked to convert the\n\
1999 selection into before sending (for example, `STRING' or `LENGTH');\n\
2000 - a flag indicating success or failure for responding to the request.\n\
2001 We might have failed (and declined the request) for any number of reasons,\n\
2002 including being asked for a selection that we no longer own, or being asked\n\
2003 to convert into a type that we don't know about or that is inappropriate.\n\
2004 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
2005 it merely informs you that they have happened.");
2006 Vx_sent_selection_hooks
= Qnil
;
2008 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
2009 "Number of milliseconds to wait for a selection reply.\n\
2010 If the selection owner doens't reply in this time, we give up.\n\
2011 A value of 0 means wait as long as necessary. This is initialized from the\n\
2012 \"*selectionTimeout\" resource.");
2013 x_selection_timeout
= 0;
2015 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
2016 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
2017 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
2018 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
2019 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
2020 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
2021 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
2022 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
2023 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
2024 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
2025 QINCR
= intern ("INCR"); staticpro (&QINCR
);
2026 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
2027 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
2028 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
2029 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
2030 QNULL
= intern ("NULL"); staticpro (&QNULL
);
2032 #ifdef CUT_BUFFER_SUPPORT
2033 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
2034 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
2035 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
2036 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
2037 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
2038 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
2039 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
2040 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);