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 /* 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
);
252 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
255 /* Now update the local cache */
257 Lisp_Object selection_time
;
258 Lisp_Object selection_data
;
259 Lisp_Object prev_value
;
261 selection_time
= long_to_cons ((unsigned long) time
);
262 selection_data
= Fcons (selection_name
,
263 Fcons (selection_value
,
264 Fcons (selection_time
, Qnil
)));
265 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
267 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
269 /* If we already owned the selection, remove the old selection data.
270 Perhaps we should destructively modify it instead.
271 Don't use Fdelq as that may QUIT. */
272 if (!NILP (prev_value
))
274 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
275 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
276 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
278 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
285 /* Given a selection-name and desired type, look up our local copy of
286 the selection value and convert it to the type.
287 The value is nil or a string.
288 This function is used both for remote requests
289 and for local x-get-selection-internal.
291 This calls random Lisp code, and may signal or gc. */
294 x_get_local_selection (selection_symbol
, target_type
)
295 Lisp_Object selection_symbol
, target_type
;
297 Lisp_Object local_value
;
298 Lisp_Object handler_fn
, value
, type
, check
;
301 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
303 if (NILP (local_value
)) return Qnil
;
305 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
306 if (EQ (target_type
, QTIMESTAMP
))
309 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
312 else if (EQ (target_type
, QDELETE
))
315 Fx_disown_selection_internal
317 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
322 #if 0 /* #### MULTIPLE doesn't work yet */
323 else if (CONSP (target_type
)
324 && XCONS (target_type
)->car
== QMULTIPLE
)
329 pairs
= XCONS (target_type
)->cdr
;
330 size
= XVECTOR (pairs
)->size
;
331 /* If the target is MULTIPLE, then target_type looks like
332 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
333 We modify the second element of each pair in the vector and
334 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
336 for (i
= 0; i
< size
; i
++)
339 pair
= XVECTOR (pairs
)->contents
[i
];
340 XVECTOR (pair
)->contents
[1]
341 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
342 XVECTOR (pair
)->contents
[1]);
349 /* Don't allow a quit within the converter.
350 When the user types C-g, he would be surprised
351 if by luck it came during a converter. */
352 count
= specpdl_ptr
- specpdl
;
353 specbind (Qinhibit_quit
, Qt
);
355 CHECK_SYMBOL (target_type
, 0);
356 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
357 if (!NILP (handler_fn
))
358 value
= call3 (handler_fn
,
359 selection_symbol
, target_type
,
360 XCONS (XCONS (local_value
)->cdr
)->car
);
363 unbind_to (count
, Qnil
);
366 /* Make sure this value is of a type that we could transmit
367 to another X client. */
371 && SYMBOLP (XCONS (value
)->car
))
372 type
= XCONS (value
)->car
,
373 check
= XCONS (value
)->cdr
;
381 /* Check for a value that cons_to_long could handle. */
382 else if (CONSP (check
)
383 && INTEGERP (XCONS (check
)->car
)
384 && (INTEGERP (XCONS (check
)->cdr
)
386 (CONSP (XCONS (check
)->cdr
)
387 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
388 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
393 Fcons (build_string ("invalid data returned by selection-conversion function"),
394 Fcons (handler_fn
, Fcons (value
, Qnil
))));
397 /* Subroutines of x_reply_selection_request. */
399 /* Send a SelectionNotify event to the requestor with property=None,
400 meaning we were unable to do what they wanted. */
403 x_decline_selection_request (event
)
404 struct input_event
*event
;
406 XSelectionEvent reply
;
407 reply
.type
= SelectionNotify
;
408 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
409 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
410 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
411 reply
.time
= SELECTION_EVENT_TIME (event
);
412 reply
.target
= SELECTION_EVENT_TARGET (event
);
413 reply
.property
= None
;
416 (void) XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
421 /* This is the selection request currently being processed.
422 It is set to zero when the request is fully processed. */
423 static struct input_event
*x_selection_current_request
;
425 /* Used as an unwind-protect clause so that, if a selection-converter signals
426 an error, we tell the requestor that we were unable to do what they wanted
427 before we throw to top-level or go into the debugger or whatever. */
430 x_selection_request_lisp_error (ignore
)
433 if (x_selection_current_request
!= 0)
434 x_decline_selection_request (x_selection_current_request
);
439 /* This stuff is so that INCR selections are reentrant (that is, so we can
440 be servicing multiple INCR selection requests simultaneously.) I haven't
441 actually tested that yet. */
443 /* Keep a list of the property changes that are awaited. */
453 struct prop_location
*next
;
456 static struct prop_location
*expect_property_change ();
457 static void wait_for_property_change ();
458 static void unexpect_property_change ();
459 static int waiting_for_other_props_on_window ();
461 static int prop_location_identifier
;
463 static Lisp_Object property_change_reply
;
465 static struct prop_location
*property_change_reply_object
;
467 static struct prop_location
*property_change_wait_list
;
469 /* Send the reply to a selection request event EVENT.
470 TYPE is the type of selection data requested.
471 DATA and SIZE describe the data to send, already converted.
472 FORMAT is the unit-size (in bits) of the data to be transmitted. */
475 x_reply_selection_request (event
, format
, data
, size
, type
)
476 struct input_event
*event
;
481 XSelectionEvent reply
;
482 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
483 Window window
= SELECTION_EVENT_REQUESTOR (event
);
485 int format_bytes
= format
/8;
486 int max_bytes
= SELECTION_QUANTUM (display
);
488 if (max_bytes
> MAX_SELECTION_QUANTUM
)
489 max_bytes
= MAX_SELECTION_QUANTUM
;
491 reply
.type
= SelectionNotify
;
492 reply
.display
= display
;
493 reply
.requestor
= window
;
494 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
495 reply
.time
= SELECTION_EVENT_TIME (event
);
496 reply
.target
= SELECTION_EVENT_TARGET (event
);
497 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
498 if (reply
.property
== None
)
499 reply
.property
= reply
.target
;
501 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
503 /* Store the data on the requested property.
504 If the selection is large, only store the first N bytes of it.
506 bytes_remaining
= size
* format_bytes
;
507 if (bytes_remaining
<= max_bytes
)
509 /* Send all the data at once, with minimal handshaking. */
511 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
514 XChangeProperty (display
, window
, reply
.property
, type
, format
,
515 PropModeReplace
, data
, size
);
516 /* At this point, the selection was successfully stored; ack it. */
517 XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
523 /* Send an INCR selection. */
524 struct prop_location
*wait_object
;
528 if (x_window_to_frame (window
)) /* #### debug */
529 error ("attempt to transfer an INCR to ourself!");
531 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
533 wait_object
= expect_property_change (display
, window
, reply
.property
,
536 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
537 32, PropModeReplace
, (unsigned char *)
538 &bytes_remaining
, 1);
539 XSelectInput (display
, window
, PropertyChangeMask
);
540 /* Tell 'em the INCR data is there... */
541 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
545 /* First, wait for the requestor to ack by deleting the property.
546 This can run random lisp code (process handlers) or signal. */
547 wait_for_property_change (wait_object
);
549 while (bytes_remaining
)
551 int i
= ((bytes_remaining
< max_bytes
)
558 = expect_property_change (display
, window
, reply
.property
,
561 fprintf (stderr
," INCR adding %d\n", i
);
563 /* Append the next chunk of data to the property. */
564 XChangeProperty (display
, window
, reply
.property
, type
, format
,
565 PropModeAppend
, data
, i
/ format_bytes
);
566 bytes_remaining
-= i
;
571 /* Now wait for the requestor to ack this chunk by deleting the
572 property. This can run random lisp code or signal.
574 wait_for_property_change (wait_object
);
576 /* Now write a zero-length chunk to the property to tell the requestor
579 fprintf (stderr
," INCR done\n");
582 if (! waiting_for_other_props_on_window (display
, window
))
583 XSelectInput (display
, window
, 0L);
585 XChangeProperty (display
, window
, reply
.property
, type
, format
,
586 PropModeReplace
, data
, 0);
592 /* Handle a SelectionRequest event EVENT.
593 This is called from keyboard.c when such an event is found in the queue. */
596 x_handle_selection_request (event
)
597 struct input_event
*event
;
599 struct gcpro gcpro1
, gcpro2
, gcpro3
;
600 Lisp_Object local_selection_data
;
601 Lisp_Object selection_symbol
;
602 Lisp_Object target_symbol
;
603 Lisp_Object converted_selection
;
604 Time local_selection_time
;
605 Lisp_Object successful_p
;
608 local_selection_data
= Qnil
;
609 target_symbol
= Qnil
;
610 converted_selection
= Qnil
;
613 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
615 selection_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
616 SELECTION_EVENT_SELECTION (event
));
618 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
620 if (NILP (local_selection_data
))
622 /* Someone asked for the selection, but we don't have it any more.
624 x_decline_selection_request (event
);
628 local_selection_time
= (Time
)
629 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
631 if (SELECTION_EVENT_TIME (event
) != CurrentTime
632 && local_selection_time
> SELECTION_EVENT_TIME (event
))
634 /* Someone asked for the selection, and we have one, but not the one
637 x_decline_selection_request (event
);
641 count
= specpdl_ptr
- specpdl
;
642 x_selection_current_request
= event
;
643 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
645 target_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
646 SELECTION_EVENT_TARGET (event
));
648 #if 0 /* #### MULTIPLE doesn't work yet */
649 if (EQ (target_symbol
, QMULTIPLE
))
650 target_symbol
= fetch_multiple_target (event
);
653 /* Convert lisp objects back into binary data */
656 = x_get_local_selection (selection_symbol
, target_symbol
);
658 if (! NILP (converted_selection
))
666 lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event
),
668 &data
, &type
, &size
, &format
, &nofree
);
670 x_reply_selection_request (event
, format
, data
, size
, type
);
673 /* Indicate we have successfully processed this event. */
674 x_selection_current_request
= 0;
679 unbind_to (count
, Qnil
);
685 /* Let random lisp code notice that the selection has been asked for. */
688 rest
= Vx_sent_selection_hooks
;
689 if (!EQ (rest
, Qunbound
))
690 for (; CONSP (rest
); rest
= Fcdr (rest
))
691 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
695 /* Handle a SelectionClear event EVENT, which indicates that some other
696 client cleared out our previously asserted selection.
697 This is called from keyboard.c when such an event is found in the queue. */
700 x_handle_selection_clear (event
)
701 struct input_event
*event
;
703 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
704 Atom selection
= SELECTION_EVENT_SELECTION (event
);
705 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
707 Lisp_Object selection_symbol
, local_selection_data
;
708 Time local_selection_time
;
710 selection_symbol
= x_atom_to_symbol (display
, selection
);
712 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
714 /* Well, we already believe that we don't own it, so that's just fine. */
715 if (NILP (local_selection_data
)) return;
717 local_selection_time
= (Time
)
718 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
720 /* This SelectionClear is for a selection that we no longer own, so we can
721 disregard it. (That is, we have reasserted the selection since this
722 request was generated.) */
724 if (changed_owner_time
!= CurrentTime
725 && local_selection_time
> changed_owner_time
)
728 /* Otherwise, we're really honest and truly being told to drop it.
729 Don't use Fdelq as that may QUIT;. */
731 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
732 Vselection_alist
= Fcdr (Vselection_alist
);
736 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
737 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
739 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
744 /* Let random lisp code notice that the selection has been stolen. */
748 rest
= Vx_lost_selection_hooks
;
749 if (!EQ (rest
, Qunbound
))
751 for (; CONSP (rest
); rest
= Fcdr (rest
))
752 call1 (Fcar (rest
), selection_symbol
);
753 prepare_menu_bars ();
754 redisplay_preserve_echo_area ();
760 /* Nonzero if any properties for DISPLAY and WINDOW
761 are on the list of what we are waiting for. */
764 waiting_for_other_props_on_window (display
, window
)
768 struct prop_location
*rest
= property_change_wait_list
;
770 if (rest
->display
== display
&& rest
->window
== window
)
777 /* Add an entry to the list of property changes we are waiting for.
778 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
779 The return value is a number that uniquely identifies
780 this awaited property change. */
782 static struct prop_location
*
783 expect_property_change (display
, window
, property
, state
)
786 Lisp_Object property
;
789 struct prop_location
*pl
790 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
791 pl
->identifier
= ++prop_location_identifier
;
792 pl
->display
= display
;
794 pl
->property
= property
;
795 pl
->desired_state
= state
;
796 pl
->next
= property_change_wait_list
;
798 property_change_wait_list
= pl
;
802 /* Delete an entry from the list of property changes we are waiting for.
803 IDENTIFIER is the number that uniquely identifies the entry. */
806 unexpect_property_change (location
)
807 struct prop_location
*location
;
809 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
812 if (rest
== location
)
815 prev
->next
= rest
->next
;
817 property_change_wait_list
= rest
->next
;
826 /* Remove the property change expectation element for IDENTIFIER. */
829 wait_for_property_change_unwind (identifierval
)
830 Lisp_Object identifierval
;
832 unexpect_property_change (XPNTR (identifierval
));
835 /* Actually wait for a property change.
836 IDENTIFIER should be the value that expect_property_change returned. */
839 wait_for_property_change (location
)
840 struct prop_location
*location
;
843 int count
= specpdl_ptr
- specpdl
;
846 XSET (tem
, Lisp_Cons
, location
);
848 /* Make sure to do unexpect_property_change if we quit or err. */
849 record_unwind_protect (wait_for_property_change_unwind
, tem
);
851 XCONS (property_change_reply
)->car
= Qnil
;
853 if (! location
->arrived
)
855 property_change_reply_object
= location
;
856 secs
= x_selection_timeout
/ 1000;
857 usecs
= (x_selection_timeout
% 1000) * 1000;
858 wait_reading_process_input (secs
, usecs
, property_change_reply
, 0);
860 if (NILP (XCONS (property_change_reply
)->car
))
861 error ("timed out waiting for property-notify event");
864 unbind_to (count
, Qnil
);
867 /* Called from XTread_socket in response to a PropertyNotify event. */
870 x_handle_property_notify (event
)
871 XPropertyEvent
*event
;
873 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
876 if (rest
->property
== event
->atom
877 && rest
->window
== event
->window
878 && rest
->display
== event
->display
879 && rest
->desired_state
== event
->state
)
882 fprintf (stderr
, "Saw expected prop-%s on %s\n",
883 (event
->state
== PropertyDelete
? "delete" : "change"),
884 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
891 /* If this is the one wait_for_property_change is waiting for,
892 tell it to wake up. */
893 if (rest
== property_change_reply_object
)
894 XCONS (property_change_reply
)->car
= Qt
;
897 prev
->next
= rest
->next
;
899 property_change_wait_list
= rest
->next
;
907 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
908 (event
->state
== PropertyDelete
? "delete" : "change"),
909 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
916 #if 0 /* #### MULTIPLE doesn't work yet */
919 fetch_multiple_target (event
)
920 XSelectionRequestEvent
*event
;
922 Display
*display
= event
->display
;
923 Window window
= event
->requestor
;
924 Atom target
= event
->target
;
925 Atom selection_atom
= event
->selection
;
930 x_get_window_property_as_lisp_data (display
, window
, target
,
931 QMULTIPLE
, selection_atom
));
935 copy_multiple_data (obj
)
942 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
944 CHECK_VECTOR (obj
, 0);
945 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
946 for (i
= 0; i
< size
; i
++)
948 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
949 CHECK_VECTOR (vec2
, 0);
950 if (XVECTOR (vec2
)->size
!= 2)
951 /* ??? Confusing error message */
952 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
953 Fcons (vec2
, Qnil
)));
954 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
955 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
956 = XVECTOR (vec2
)->contents
[0];
957 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
958 = XVECTOR (vec2
)->contents
[1];
966 /* Variables for communication with x_handle_selection_notify. */
967 static Atom reading_which_selection
;
968 static Lisp_Object reading_selection_reply
;
969 static Window reading_selection_window
;
971 /* Do protocol to read selection-data from the server.
972 Converts this to Lisp data and returns it. */
975 x_get_foreign_selection (selection_symbol
, target_type
)
976 Lisp_Object selection_symbol
, target_type
;
978 Display
*display
= x_current_display
;
980 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
982 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
984 Time requestor_time
= last_event_timestamp
;
985 Atom target_property
= Xatom_EMACS_TMP
;
986 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
990 if (CONSP (target_type
))
991 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
993 type_atom
= symbol_to_x_atom (display
, target_type
);
997 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
998 requestor_window
, requestor_time
);
1001 /* Prepare to block until the reply has been read. */
1002 reading_selection_window
= requestor_window
;
1003 reading_which_selection
= selection_atom
;
1004 XCONS (reading_selection_reply
)->car
= Qnil
;
1007 /* This allows quits. Also, don't wait forever. */
1008 secs
= x_selection_timeout
/ 1000;
1009 usecs
= (x_selection_timeout
% 1000) * 1000;
1010 wait_reading_process_input (secs
, usecs
, reading_selection_reply
, 0);
1013 x_check_errors ("Cannot get selection: %s");
1014 x_uncatch_errors ();
1017 if (NILP (XCONS (reading_selection_reply
)->car
))
1018 error ("timed out waiting for reply from selection owner");
1020 /* Otherwise, the selection is waiting for us on the requested property. */
1022 x_get_window_property_as_lisp_data (display
, requestor_window
,
1023 target_property
, target_type
,
1027 /* Subroutines of x_get_window_property_as_lisp_data */
1030 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
1031 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1036 unsigned char **data_ret
;
1038 Atom
*actual_type_ret
;
1039 int *actual_format_ret
;
1040 unsigned long *actual_size_ret
;
1044 unsigned long bytes_remaining
;
1046 unsigned char *tmp_data
= 0;
1048 int buffer_size
= SELECTION_QUANTUM (display
);
1049 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1052 /* First probe the thing to find out how big it is. */
1053 result
= XGetWindowProperty (display
, window
, property
,
1054 0, 0, False
, AnyPropertyType
,
1055 actual_type_ret
, actual_format_ret
,
1057 &bytes_remaining
, &tmp_data
);
1058 if (result
!= Success
)
1065 xfree ((char *) tmp_data
);
1067 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1073 total_size
= bytes_remaining
+ 1;
1074 *data_ret
= (unsigned char *) xmalloc (total_size
);
1076 /* Now read, until weve gotten it all. */
1077 while (bytes_remaining
)
1080 int last
= bytes_remaining
;
1083 = XGetWindowProperty (display
, window
, property
,
1084 offset
/4, buffer_size
/4,
1087 actual_type_ret
, actual_format_ret
,
1088 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1090 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1092 /* If this doesn't return Success at this point, it means that
1093 some clod deleted the selection while we were in the midst of
1094 reading it. Deal with that, I guess....
1096 if (result
!= Success
) break;
1097 *actual_size_ret
*= *actual_format_ret
/ 8;
1098 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1099 offset
+= *actual_size_ret
;
1100 xfree ((char *) tmp_data
);
1105 *bytes_ret
= offset
;
1109 receive_incremental_selection (display
, window
, property
, target_type
,
1110 min_size_bytes
, data_ret
, size_bytes_ret
,
1111 type_ret
, format_ret
, size_ret
)
1115 Lisp_Object target_type
; /* for error messages only */
1116 unsigned int min_size_bytes
;
1117 unsigned char **data_ret
;
1118 int *size_bytes_ret
;
1120 unsigned long *size_ret
;
1124 struct prop_location
*wait_object
;
1125 *size_bytes_ret
= min_size_bytes
;
1126 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1128 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1131 /* At this point, we have read an INCR property.
1132 Delete the property to ack it.
1133 (But first, prepare to receive the next event in this handshake.)
1135 Now, we must loop, waiting for the sending window to put a value on
1136 that property, then reading the property, then deleting it to ack.
1137 We are done when the sender places a property of length 0.
1140 XSelectInput (display
, window
, STANDARD_EVENT_SET
| PropertyChangeMask
);
1141 XDeleteProperty (display
, window
, property
);
1142 wait_object
= expect_property_change (display
, window
, property
,
1149 unsigned char *tmp_data
;
1151 wait_for_property_change (wait_object
);
1152 /* expect it again immediately, because x_get_window_property may
1153 .. no it wont, I dont get it.
1154 .. Ok, I get it now, the Xt code that implements INCR is broken.
1156 x_get_window_property (display
, window
, property
,
1157 &tmp_data
, &tmp_size_bytes
,
1158 type_ret
, format_ret
, size_ret
, 1);
1160 if (tmp_size_bytes
== 0) /* we're done */
1163 fprintf (stderr
, " read INCR done\n");
1165 if (! waiting_for_other_props_on_window (display
, window
))
1166 XSelectInput (display
, window
, STANDARD_EVENT_SET
);
1167 unexpect_property_change (wait_object
);
1168 if (tmp_data
) xfree (tmp_data
);
1173 XDeleteProperty (display
, window
, property
);
1174 wait_object
= expect_property_change (display
, window
, property
,
1180 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1182 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1185 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1186 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1188 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1189 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1191 bcopy (tmp_data
, (*data_ret
) + offset
, tmp_size_bytes
);
1192 offset
+= tmp_size_bytes
;
1197 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1198 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1199 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1202 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1207 Lisp_Object target_type
; /* for error messages only */
1208 Atom selection_atom
; /* for error messages only */
1212 unsigned long actual_size
;
1213 unsigned char *data
= 0;
1217 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1218 &actual_type
, &actual_format
, &actual_size
, 1);
1221 int there_is_a_selection_owner
;
1223 there_is_a_selection_owner
1224 = XGetSelectionOwner (display
, selection_atom
);
1226 while (1) /* Note debugger can no longer return, so this is obsolete */
1228 there_is_a_selection_owner
?
1229 Fcons (build_string ("selection owner couldn't convert"),
1231 ? Fcons (target_type
,
1232 Fcons (x_atom_to_symbol (display
, actual_type
),
1234 : Fcons (target_type
, Qnil
))
1235 : Fcons (build_string ("no selection"),
1236 Fcons (x_atom_to_symbol (display
, selection_atom
),
1240 if (actual_type
== Xatom_INCR
)
1242 /* That wasn't really the data, just the beginning. */
1244 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1246 XFree ((char *) data
);
1248 receive_incremental_selection (display
, window
, property
, target_type
,
1249 min_size_bytes
, &data
, &bytes
,
1250 &actual_type
, &actual_format
,
1255 XDeleteProperty (display
, window
, property
);
1259 /* It's been read. Now convert it to a lisp object in some semi-rational
1261 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1262 actual_type
, actual_format
);
1264 xfree ((char *) data
);
1268 /* These functions convert from the selection data read from the server into
1269 something that we can use from Lisp, and vice versa.
1271 Type: Format: Size: Lisp Type:
1272 ----- ------- ----- -----------
1275 ATOM 32 > 1 Vector of Symbols
1277 * 16 > 1 Vector of Integers
1278 * 32 1 if <=16 bits: Integer
1279 if > 16 bits: Cons of top16, bot16
1280 * 32 > 1 Vector of the above
1282 When converting a Lisp number to C, it is assumed to be of format 16 if
1283 it is an integer, and of format 32 if it is a cons of two integers.
1285 When converting a vector of numbers from Lisp to C, it is assumed to be
1286 of format 16 if every element in the vector is an integer, and is assumed
1287 to be of format 32 if any element is a cons of two integers.
1289 When converting an object to C, it may be of the form (SYMBOL . <data>)
1290 where SYMBOL is what we should claim that the type is. Format and
1291 representation are as above. */
1296 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1298 unsigned char *data
;
1303 if (type
== Xatom_NULL
)
1306 /* Convert any 8-bit data to a string, for compactness. */
1307 else if (format
== 8)
1308 return make_string ((char *) data
, size
);
1310 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1311 a vector of symbols.
1313 else if (type
== XA_ATOM
)
1316 if (size
== sizeof (Atom
))
1317 return x_atom_to_symbol (display
, *((Atom
*) data
));
1320 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1321 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1322 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1327 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1328 If the number is > 16 bits, convert it to a cons of integers,
1329 16 bits in each half.
1331 else if (format
== 32 && size
== sizeof (long))
1332 return long_to_cons (((unsigned long *) data
) [0]);
1333 else if (format
== 16 && size
== sizeof (short))
1334 return make_number ((int) (((unsigned short *) data
) [0]));
1336 /* Convert any other kind of data to a vector of numbers, represented
1337 as above (as an integer, or a cons of two 16 bit integers.)
1339 else if (format
== 16)
1342 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1343 for (i
= 0; i
< size
/ 4; i
++)
1345 int j
= (int) ((unsigned short *) data
) [i
];
1346 Faset (v
, i
, make_number (j
));
1353 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1354 for (i
= 0; i
< size
/ 4; i
++)
1356 unsigned long j
= ((unsigned long *) data
) [i
];
1357 Faset (v
, i
, long_to_cons (j
));
1365 lisp_data_to_selection_data (display
, obj
,
1366 data_ret
, type_ret
, size_ret
,
1367 format_ret
, nofree_ret
)
1370 unsigned char **data_ret
;
1372 unsigned int *size_ret
;
1376 Lisp_Object type
= Qnil
;
1380 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1382 type
= XCONS (obj
)->car
;
1383 obj
= XCONS (obj
)->cdr
;
1384 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1385 obj
= XCONS (obj
)->car
;
1388 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1389 { /* This is not the same as declining */
1395 else if (STRINGP (obj
))
1398 *size_ret
= XSTRING (obj
)->size
;
1399 *data_ret
= XSTRING (obj
)->data
;
1401 if (NILP (type
)) type
= QSTRING
;
1403 else if (SYMBOLP (obj
))
1407 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1408 (*data_ret
) [sizeof (Atom
)] = 0;
1409 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1410 if (NILP (type
)) type
= QATOM
;
1412 else if (INTEGERP (obj
)
1413 && XINT (obj
) < 0xFFFF
1414 && XINT (obj
) > -0xFFFF)
1418 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1419 (*data_ret
) [sizeof (short)] = 0;
1420 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1421 if (NILP (type
)) type
= QINTEGER
;
1423 else if (INTEGERP (obj
)
1424 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1425 && (INTEGERP (XCONS (obj
)->cdr
)
1426 || (CONSP (XCONS (obj
)->cdr
)
1427 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1431 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1432 (*data_ret
) [sizeof (long)] = 0;
1433 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1434 if (NILP (type
)) type
= QINTEGER
;
1436 else if (VECTORP (obj
))
1438 /* Lisp_Vectors may represent a set of ATOMs;
1439 a set of 16 or 32 bit INTEGERs;
1440 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1444 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1445 /* This vector is an ATOM set */
1447 if (NILP (type
)) type
= QATOM
;
1448 *size_ret
= XVECTOR (obj
)->size
;
1450 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1451 for (i
= 0; i
< *size_ret
; i
++)
1452 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1453 (*(Atom
**) data_ret
) [i
]
1454 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1456 Fsignal (Qerror
, /* Qselection_error */
1458 ("all elements of selection vector must have same type"),
1459 Fcons (obj
, Qnil
)));
1461 #if 0 /* #### MULTIPLE doesn't work yet */
1462 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1463 /* This vector is an ATOM_PAIR set */
1465 if (NILP (type
)) type
= QATOM_PAIR
;
1466 *size_ret
= XVECTOR (obj
)->size
;
1468 *data_ret
= (unsigned char *)
1469 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1470 for (i
= 0; i
< *size_ret
; i
++)
1471 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1473 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1474 if (XVECTOR (pair
)->size
!= 2)
1477 ("elements of the vector must be vectors of exactly two elements"),
1478 Fcons (pair
, Qnil
)));
1480 (*(Atom
**) data_ret
) [i
* 2]
1481 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1482 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1483 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1488 ("all elements of the vector must be of the same type"),
1489 Fcons (obj
, Qnil
)));
1494 /* This vector is an INTEGER set, or something like it */
1496 *size_ret
= XVECTOR (obj
)->size
;
1497 if (NILP (type
)) type
= QINTEGER
;
1499 for (i
= 0; i
< *size_ret
; i
++)
1500 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1502 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1503 Fsignal (Qerror
, /* Qselection_error */
1505 ("elements of selection vector must be integers or conses of integers"),
1506 Fcons (obj
, Qnil
)));
1508 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1509 for (i
= 0; i
< *size_ret
; i
++)
1510 if (*format_ret
== 32)
1511 (*((unsigned long **) data_ret
)) [i
]
1512 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1514 (*((unsigned short **) data_ret
)) [i
]
1515 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1519 Fsignal (Qerror
, /* Qselection_error */
1520 Fcons (build_string ("unrecognised selection data"),
1521 Fcons (obj
, Qnil
)));
1523 *type_ret
= symbol_to_x_atom (display
, type
);
1527 clean_local_selection_data (obj
)
1531 && INTEGERP (XCONS (obj
)->car
)
1532 && CONSP (XCONS (obj
)->cdr
)
1533 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1534 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1535 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1538 && INTEGERP (XCONS (obj
)->car
)
1539 && INTEGERP (XCONS (obj
)->cdr
))
1541 if (XINT (XCONS (obj
)->car
) == 0)
1542 return XCONS (obj
)->cdr
;
1543 if (XINT (XCONS (obj
)->car
) == -1)
1544 return make_number (- XINT (XCONS (obj
)->cdr
));
1549 int size
= XVECTOR (obj
)->size
;
1552 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1553 copy
= Fmake_vector (size
, Qnil
);
1554 for (i
= 0; i
< size
; i
++)
1555 XVECTOR (copy
)->contents
[i
]
1556 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1562 /* Called from XTread_socket to handle SelectionNotify events.
1563 If it's the selection we are waiting for, stop waiting. */
1566 x_handle_selection_notify (event
)
1567 XSelectionEvent
*event
;
1569 if (event
->requestor
!= reading_selection_window
)
1571 if (event
->selection
!= reading_which_selection
)
1574 XCONS (reading_selection_reply
)->car
= Qt
;
1578 DEFUN ("x-own-selection-internal",
1579 Fx_own_selection_internal
, Sx_own_selection_internal
,
1581 "Assert an X selection of the given TYPE with the given VALUE.\n\
1582 TYPE 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 VALUE is typically a string, or a cons of two markers, but may be\n\
1585 anything that the functions on `selection-converter-alist' know about.")
1586 (selection_name
, selection_value
)
1587 Lisp_Object selection_name
, selection_value
;
1590 CHECK_SYMBOL (selection_name
, 0);
1591 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1592 x_own_selection (selection_name
, selection_value
);
1593 return selection_value
;
1597 /* Request the selection value from the owner. If we are the owner,
1598 simply return our selection value. If we are not the owner, this
1599 will block until all of the data has arrived. */
1601 DEFUN ("x-get-selection-internal",
1602 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1603 "Return text selected from some X window.\n\
1604 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1605 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1606 TYPE is the type of data desired, typically `STRING'.")
1607 (selection_symbol
, target_type
)
1608 Lisp_Object selection_symbol
, target_type
;
1610 Lisp_Object val
= Qnil
;
1611 struct gcpro gcpro1
, gcpro2
;
1612 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1614 CHECK_SYMBOL (selection_symbol
, 0);
1616 #if 0 /* #### MULTIPLE doesn't work yet */
1617 if (CONSP (target_type
)
1618 && XCONS (target_type
)->car
== QMULTIPLE
)
1620 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1621 /* So we don't destructively modify this... */
1622 target_type
= copy_multiple_data (target_type
);
1626 CHECK_SYMBOL (target_type
, 0);
1628 val
= x_get_local_selection (selection_symbol
, target_type
);
1632 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1637 && SYMBOLP (XCONS (val
)->car
))
1639 val
= XCONS (val
)->cdr
;
1640 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1641 val
= XCONS (val
)->car
;
1643 val
= clean_local_selection_data (val
);
1649 DEFUN ("x-disown-selection-internal",
1650 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1651 "If we own the selection SELECTION, disown it.\n\
1652 Disowning it means there is no such selection.")
1654 Lisp_Object selection
;
1657 Display
*display
= x_current_display
;
1659 Atom selection_atom
;
1660 XSelectionClearEvent event
;
1663 CHECK_SYMBOL (selection
, 0);
1665 timestamp
= last_event_timestamp
;
1667 timestamp
= cons_to_long (time
);
1669 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1670 return Qnil
; /* Don't disown the selection when we're not the owner. */
1672 selection_atom
= symbol_to_x_atom (display
, selection
);
1675 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1678 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1679 generated for a window which owns the selection when that window sets
1680 the selection owner to None. The NCD server does, the MIT Sun4 server
1681 doesn't. So we synthesize one; this means we might get two, but
1682 that's ok, because the second one won't have any effect. */
1683 SELECTION_EVENT_DISPLAY (&event
) = display
;
1684 SELECTION_EVENT_SELECTION (&event
) = selection_atom
;
1685 SELECTION_EVENT_TIME (&event
) = timestamp
;
1686 x_handle_selection_clear (&event
);
1691 /* Get rid of all the selections in buffer BUFFER.
1692 This is used when we kill a buffer. */
1695 x_disown_buffer_selections (buffer
)
1699 struct buffer
*buf
= XBUFFER (buffer
);
1701 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1703 Lisp_Object elt
, value
;
1704 elt
= XCONS (tail
)->car
;
1705 value
= XCONS (elt
)->cdr
;
1706 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1707 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1708 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1712 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1714 "Whether the current Emacs process owns the given X Selection.\n\
1715 The arg should be the name of the selection in question, typically one of\n\
1716 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1717 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1718 For convenience, the symbol nil is the same as `PRIMARY',\n\
1719 and t is the same as `SECONDARY'.)")
1721 Lisp_Object selection
;
1724 CHECK_SYMBOL (selection
, 0);
1725 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1726 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1728 if (NILP (Fassq (selection
, Vselection_alist
)))
1733 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1735 "Whether there is an owner for the given X Selection.\n\
1736 The arg should be the name of the selection in question, typically one of\n\
1737 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1738 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1739 For convenience, the symbol nil is the same as `PRIMARY',\n\
1740 and t is the same as `SECONDARY'.)")
1742 Lisp_Object selection
;
1746 Display
*dpy
= x_current_display
;
1748 CHECK_SYMBOL (selection
, 0);
1749 if (!NILP (Fx_selection_owner_p (selection
)))
1751 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1752 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1753 atom
= symbol_to_x_atom (dpy
, selection
);
1757 owner
= XGetSelectionOwner (dpy
, atom
);
1759 return (owner
? Qt
: Qnil
);
1763 #ifdef CUT_BUFFER_SUPPORT
1765 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1767 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1769 initialize_cut_buffers (display
, window
)
1773 unsigned char *data
= (unsigned char *) "";
1775 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1776 PropModeAppend, data, 0)
1777 FROB (XA_CUT_BUFFER0
);
1778 FROB (XA_CUT_BUFFER1
);
1779 FROB (XA_CUT_BUFFER2
);
1780 FROB (XA_CUT_BUFFER3
);
1781 FROB (XA_CUT_BUFFER4
);
1782 FROB (XA_CUT_BUFFER5
);
1783 FROB (XA_CUT_BUFFER6
);
1784 FROB (XA_CUT_BUFFER7
);
1787 cut_buffers_initialized
= 1;
1791 #define CHECK_CUT_BUFFER(symbol,n) \
1792 { CHECK_SYMBOL ((symbol), (n)); \
1793 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1794 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1795 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1796 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1798 Fcons (build_string ("doesn't name a cut buffer"), \
1799 Fcons ((symbol), Qnil))); \
1802 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1803 Sx_get_cut_buffer_internal
, 1, 1, 0,
1804 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1808 Display
*display
= x_current_display
;
1809 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1811 unsigned char *data
;
1819 CHECK_CUT_BUFFER (buffer
, 0);
1820 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1822 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1823 &type
, &format
, &size
, 0);
1824 if (!data
) return Qnil
;
1826 if (format
!= 8 || type
!= XA_STRING
)
1828 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1829 Fcons (x_atom_to_symbol (display
, type
),
1830 Fcons (make_number (format
), Qnil
))));
1832 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1838 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1839 Sx_store_cut_buffer_internal
, 2, 2, 0,
1840 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1842 Lisp_Object buffer
, string
;
1844 Display
*display
= x_current_display
;
1845 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1847 unsigned char *data
;
1849 int bytes_remaining
;
1850 int max_bytes
= SELECTION_QUANTUM (display
);
1851 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1854 CHECK_CUT_BUFFER (buffer
, 0);
1855 CHECK_STRING (string
, 0);
1856 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1857 data
= (unsigned char *) XSTRING (string
)->data
;
1858 bytes
= XSTRING (string
)->size
;
1859 bytes_remaining
= bytes
;
1861 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1865 /* Don't mess up with an empty value. */
1866 if (!bytes_remaining
)
1867 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1868 PropModeReplace
, data
, 0);
1870 while (bytes_remaining
)
1872 int chunk
= (bytes_remaining
< max_bytes
1873 ? bytes_remaining
: max_bytes
);
1874 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1875 (bytes_remaining
== bytes
1880 bytes_remaining
-= chunk
;
1887 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1888 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1889 "Rotate the values of the cut buffers by the given number of steps;\n\
1890 positive means move values forward, negative means backward.")
1894 Display
*display
= x_current_display
;
1895 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1899 CHECK_NUMBER (n
, 0);
1900 if (XINT (n
) == 0) return n
;
1901 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1902 props
[0] = XA_CUT_BUFFER0
;
1903 props
[1] = XA_CUT_BUFFER1
;
1904 props
[2] = XA_CUT_BUFFER2
;
1905 props
[3] = XA_CUT_BUFFER3
;
1906 props
[4] = XA_CUT_BUFFER4
;
1907 props
[5] = XA_CUT_BUFFER5
;
1908 props
[6] = XA_CUT_BUFFER6
;
1909 props
[7] = XA_CUT_BUFFER7
;
1911 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1919 Xatoms_of_xselect ()
1921 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1924 /* Non-predefined atoms that we might end up using a lot */
1925 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1926 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1927 Xatom_TEXT
= ATOM ("TEXT");
1928 Xatom_DELETE
= ATOM ("DELETE");
1929 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1930 Xatom_INCR
= ATOM ("INCR");
1931 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1932 Xatom_TARGETS
= ATOM ("TARGETS");
1933 Xatom_NULL
= ATOM ("NULL");
1934 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1941 defsubr (&Sx_get_selection_internal
);
1942 defsubr (&Sx_own_selection_internal
);
1943 defsubr (&Sx_disown_selection_internal
);
1944 defsubr (&Sx_selection_owner_p
);
1945 defsubr (&Sx_selection_exists_p
);
1947 #ifdef CUT_BUFFER_SUPPORT
1948 defsubr (&Sx_get_cut_buffer_internal
);
1949 defsubr (&Sx_store_cut_buffer_internal
);
1950 defsubr (&Sx_rotate_cut_buffers_internal
);
1951 cut_buffers_initialized
= 0;
1954 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1955 staticpro (&reading_selection_reply
);
1956 reading_selection_window
= 0;
1957 reading_which_selection
= 0;
1959 property_change_wait_list
= 0;
1960 prop_location_identifier
= 0;
1961 property_change_reply
= Fcons (Qnil
, Qnil
);
1962 staticpro (&property_change_reply
);
1964 Vselection_alist
= Qnil
;
1965 staticpro (&Vselection_alist
);
1967 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1968 "An alist associating X Windows selection-types with functions.\n\
1969 These functions are called to convert the selection, with three args:\n\
1970 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1971 a desired type to which the selection should be converted;\n\
1972 and the local selection value (whatever was given to `x-own-selection').\n\
1974 The function should return the value to send to the X server\n\
1975 \(typically a string). A return value of nil\n\
1976 means that the conversion could not be done.\n\
1977 A return value which is the symbol `NULL'\n\
1978 means that a side-effect was executed,\n\
1979 and there is no meaningful selection value.");
1980 Vselection_converter_alist
= Qnil
;
1982 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1983 "A list of functions to be called when Emacs loses an X selection.\n\
1984 \(This happens when some other X client makes its own selection\n\
1985 or when a Lisp program explicitly clears the selection.)\n\
1986 The functions are called with one argument, the selection type\n\
1987 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1988 Vx_lost_selection_hooks
= Qnil
;
1990 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1991 "A list of functions to be called when Emacs answers a selection request.\n\
1992 The functions are called with four arguments:\n\
1993 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1994 - the selection-type which Emacs was asked to convert the\n\
1995 selection into before sending (for example, `STRING' or `LENGTH');\n\
1996 - a flag indicating success or failure for responding to the request.\n\
1997 We might have failed (and declined the request) for any number of reasons,\n\
1998 including being asked for a selection that we no longer own, or being asked\n\
1999 to convert into a type that we don't know about or that is inappropriate.\n\
2000 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
2001 it merely informs you that they have happened.");
2002 Vx_sent_selection_hooks
= Qnil
;
2004 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
2005 "Number of milliseconds to wait for a selection reply.\n\
2006 If the selection owner doens't reply in this time, we give up.\n\
2007 A value of 0 means wait as long as necessary. This is initialized from the\n\
2008 \"*selectionTimeout\" resource.");
2009 x_selection_timeout
= 0;
2011 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
2012 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
2013 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
2014 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
2015 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
2016 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
2017 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
2018 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
2019 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
2020 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
2021 QINCR
= intern ("INCR"); staticpro (&QINCR
);
2022 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
2023 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
2024 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
2025 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
2026 QNULL
= intern ("NULL"); staticpro (&QNULL
);
2028 #ifdef CUT_BUFFER_SUPPORT
2029 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
2030 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
2031 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
2032 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
2033 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
2034 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
2035 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
2036 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);