1 /* X Selection processing for emacs
2 Copyright (C) 1993 Free Software Foundation.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
20 /* x_handle_selection_notify
21 x_reply_selection_request */
24 /* Rewritten by jwz */
29 #include <stdio.h> /* termhooks.h needs this */
30 #include "termhooks.h"
32 #include "xterm.h" /* for all of the X includes */
33 #include "dispextern.h" /* frame.h seems to want this */
34 #include "frame.h" /* Need this to get the X window of selected_frame */
35 #include "blockinput.h"
39 #define CUT_BUFFER_SUPPORT
41 static Atom Xatom_CLIPBOARD
, Xatom_TIMESTAMP
, Xatom_TEXT
, Xatom_DELETE
,
42 Xatom_MULTIPLE
, Xatom_INCR
, Xatom_EMACS_TMP
, Xatom_TARGETS
, Xatom_NULL
,
45 Lisp_Object QPRIMARY
, QSECONDARY
, QSTRING
, QINTEGER
, QCLIPBOARD
, QTIMESTAMP
,
46 QTEXT
, QDELETE
, QMULTIPLE
, QINCR
, QEMACS_TMP
, QTARGETS
, QATOM
, QNULL
,
49 #ifdef CUT_BUFFER_SUPPORT
50 Lisp_Object QCUT_BUFFER0
, QCUT_BUFFER1
, QCUT_BUFFER2
, QCUT_BUFFER3
,
51 QCUT_BUFFER4
, QCUT_BUFFER5
, QCUT_BUFFER6
, QCUT_BUFFER7
;
54 Lisp_Object Vx_lost_selection_hooks
;
55 Lisp_Object Vx_sent_selection_hooks
;
57 /* If this is a smaller number than the max-request-size of the display,
58 emacs will use INCR selection transfer when the selection is larger
59 than this. The max-request-size is usually around 64k, so if you want
60 emacs to use incremental selection transfers when the selection is
61 smaller than that, set this. I added this mostly for debugging the
62 incremental transfer stuff, but it might improve server performance.
64 #define MAX_SELECTION_QUANTUM 0xFFFFFF
67 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
69 #define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
72 /* The timestamp of the last input event Emacs received from the X server. */
73 unsigned long last_event_timestamp
;
75 /* This is an association list whose elements are of the form
76 ( selection-name selection-value selection-timestamp )
77 selection-name is a lisp symbol, whose name is the name of an X Atom.
78 selection-value is the value that emacs owns for that selection.
79 It may be any kind of Lisp object.
80 selection-timestamp is the time at which emacs began owning this selection,
81 as a cons of two 16-bit numbers (making a 32 bit time.)
82 If there is an entry in this alist, then it can be assumed that emacs owns
84 The only (eq) parts of this list that are visible from Lisp are the
87 Lisp_Object Vselection_alist
;
89 /* This is an alist whose CARs are selection-types (whose names are the same
90 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
91 call to convert the given Emacs selection value to a string representing
92 the given selection type. This is for Lisp-level extension of the emacs
95 Lisp_Object Vselection_converter_alist
;
97 /* If the selection owner takes too long to reply to a selection request,
98 we give up on it. This is in milliseconds (0 = no timeout.)
100 int x_selection_timeout
;
103 /* Utility functions */
105 static void lisp_data_to_selection_data ();
106 static Lisp_Object
selection_data_to_lisp_data ();
107 static Lisp_Object
x_get_window_property_as_lisp_data ();
109 static int expect_property_change ();
110 static void wait_for_property_change ();
111 static void unexpect_property_change ();
112 static int waiting_for_other_props_on_window ();
114 /* This converts a Lisp symbol to a server Atom, avoiding a server
115 roundtrip whenever possible. */
118 symbol_to_x_atom (display
, sym
)
123 if (NILP (sym
)) return 0;
124 if (EQ (sym
, QPRIMARY
)) return XA_PRIMARY
;
125 if (EQ (sym
, QSECONDARY
)) return XA_SECONDARY
;
126 if (EQ (sym
, QSTRING
)) return XA_STRING
;
127 if (EQ (sym
, QINTEGER
)) return XA_INTEGER
;
128 if (EQ (sym
, QATOM
)) return XA_ATOM
;
129 if (EQ (sym
, QCLIPBOARD
)) return Xatom_CLIPBOARD
;
130 if (EQ (sym
, QTIMESTAMP
)) return Xatom_TIMESTAMP
;
131 if (EQ (sym
, QTEXT
)) return Xatom_TEXT
;
132 if (EQ (sym
, QDELETE
)) return Xatom_DELETE
;
133 if (EQ (sym
, QMULTIPLE
)) return Xatom_MULTIPLE
;
134 if (EQ (sym
, QINCR
)) return Xatom_INCR
;
135 if (EQ (sym
, QEMACS_TMP
)) return Xatom_EMACS_TMP
;
136 if (EQ (sym
, QTARGETS
)) return Xatom_TARGETS
;
137 if (EQ (sym
, QNULL
)) return Xatom_NULL
;
138 #ifdef CUT_BUFFER_SUPPORT
139 if (EQ (sym
, QCUT_BUFFER0
)) return XA_CUT_BUFFER0
;
140 if (EQ (sym
, QCUT_BUFFER1
)) return XA_CUT_BUFFER1
;
141 if (EQ (sym
, QCUT_BUFFER2
)) return XA_CUT_BUFFER2
;
142 if (EQ (sym
, QCUT_BUFFER3
)) return XA_CUT_BUFFER3
;
143 if (EQ (sym
, QCUT_BUFFER4
)) return XA_CUT_BUFFER4
;
144 if (EQ (sym
, QCUT_BUFFER5
)) return XA_CUT_BUFFER5
;
145 if (EQ (sym
, QCUT_BUFFER6
)) return XA_CUT_BUFFER6
;
146 if (EQ (sym
, QCUT_BUFFER7
)) return XA_CUT_BUFFER7
;
148 if (!SYMBOLP (sym
)) abort ();
151 fprintf (stderr
, " XInternAtom %s\n", (char *) XSYMBOL (sym
)->name
->data
);
154 val
= XInternAtom (display
, (char *) XSYMBOL (sym
)->name
->data
, False
);
160 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
161 and calls to intern whenever possible. */
164 x_atom_to_symbol (display
, atom
)
170 if (! atom
) return Qnil
;
183 #ifdef CUT_BUFFER_SUPPORT
203 if (atom
== Xatom_CLIPBOARD
)
205 if (atom
== Xatom_TIMESTAMP
)
207 if (atom
== Xatom_TEXT
)
209 if (atom
== Xatom_DELETE
)
211 if (atom
== Xatom_MULTIPLE
)
213 if (atom
== Xatom_INCR
)
215 if (atom
== Xatom_EMACS_TMP
)
217 if (atom
== Xatom_TARGETS
)
219 if (atom
== Xatom_NULL
)
223 str
= XGetAtomName (display
, atom
);
226 fprintf (stderr
, " XGetAtomName --> %s\n", str
);
228 if (! str
) return Qnil
;
236 /* Do protocol to assert ourself as a selection owner.
237 Update the Vselection_alist so that we can reply to later requests for
241 x_own_selection (selection_name
, selection_value
)
242 Lisp_Object selection_name
, selection_value
;
244 Display
*display
= x_current_display
;
246 Window selecting_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
248 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
250 Time time
= last_event_timestamp
;
253 CHECK_SYMBOL (selection_name
, 0);
254 selection_atom
= symbol_to_x_atom (display
, selection_name
);
257 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
260 /* Now update the local cache */
262 Lisp_Object selection_time
;
263 Lisp_Object selection_data
;
264 Lisp_Object prev_value
;
266 selection_time
= long_to_cons ((unsigned long) time
);
267 selection_data
= Fcons (selection_name
,
268 Fcons (selection_value
,
269 Fcons (selection_time
, Qnil
)));
270 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
272 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
274 /* If we already owned the selection, remove the old selection data.
275 Perhaps we should destructively modify it instead.
276 Don't use Fdelq as that may QUIT. */
277 if (!NILP (prev_value
))
279 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
280 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
281 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
283 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
290 /* Given a selection-name and desired type, look up our local copy of
291 the selection value and convert it to the type.
292 The value is nil or a string.
293 This function is used both for remote requests
294 and for local x-get-selection-internal.
296 This calls random Lisp code, and may signal or gc. */
299 x_get_local_selection (selection_symbol
, target_type
)
300 Lisp_Object selection_symbol
, target_type
;
302 Lisp_Object local_value
;
303 Lisp_Object handler_fn
, value
, type
, check
;
306 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
308 if (NILP (local_value
)) return Qnil
;
310 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
311 if (EQ (target_type
, QTIMESTAMP
))
314 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
317 else if (EQ (target_type
, QDELETE
))
320 Fx_disown_selection_internal
322 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
327 #if 0 /* #### MULTIPLE doesn't work yet */
328 else if (CONSP (target_type
)
329 && XCONS (target_type
)->car
== QMULTIPLE
)
331 Lisp_Object pairs
= XCONS (target_type
)->cdr
;
332 int size
= XVECTOR (pairs
)->size
;
334 /* If the target is MULTIPLE, then target_type looks like
335 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
336 We modify the second element of each pair in the vector and
337 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
339 for (i
= 0; i
< size
; i
++)
341 Lisp_Object pair
= XVECTOR (pairs
)->contents
[i
];
342 XVECTOR (pair
)->contents
[1]
343 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
344 XVECTOR (pair
)->contents
[1]);
351 /* Don't allow a quit within the converter.
352 When the user types C-g, he would be surprised
353 if by luck it came during a converter. */
354 count
= specpdl_ptr
- specpdl
;
355 specbind (Qinhibit_quit
, Qt
);
357 CHECK_SYMBOL (target_type
, 0);
358 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
359 if (!NILP (handler_fn
))
360 value
= call3 (handler_fn
,
361 selection_symbol
, target_type
,
362 XCONS (XCONS (local_value
)->cdr
)->car
);
365 unbind_to (count
, Qnil
);
368 /* Make sure this value is of a type that we could transmit
369 to another X client. */
373 && SYMBOLP (XCONS (value
)->car
))
374 type
= XCONS (value
)->car
,
375 check
= XCONS (value
)->cdr
;
383 /* Check for a value that cons_to_long could handle. */
384 else if (CONSP (check
)
385 && INTEGERP (XCONS (check
)->car
)
386 && (INTEGERP (XCONS (check
)->cdr
)
388 (CONSP (XCONS (check
)->cdr
)
389 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
390 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
395 Fcons (build_string ("invalid data returned by selection-conversion function"),
396 Fcons (handler_fn
, Fcons (value
, Qnil
))));
399 /* Subroutines of x_reply_selection_request. */
401 /* Send a SelectionNotify event to the requestor with property=None,
402 meaning we were unable to do what they wanted. */
405 x_decline_selection_request (event
)
406 struct input_event
*event
;
408 XSelectionEvent reply
;
409 reply
.type
= SelectionNotify
;
410 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
411 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
412 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
413 reply
.time
= SELECTION_EVENT_TIME (event
);
414 reply
.target
= SELECTION_EVENT_TARGET (event
);
415 reply
.property
= None
;
418 (void) XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
423 /* This is the selection request currently being processed.
424 It is set to zero when the request is fully processed. */
425 static struct input_event
*x_selection_current_request
;
427 /* Used as an unwind-protect clause so that, if a selection-converter signals
428 an error, we tell the requestor that we were unable to do what they wanted
429 before we throw to top-level or go into the debugger or whatever. */
432 x_selection_request_lisp_error (ignore
)
435 if (x_selection_current_request
!= 0)
436 x_decline_selection_request (x_selection_current_request
);
440 /* Send the reply to a selection request event EVENT.
441 TYPE is the type of selection data requested.
442 DATA and SIZE describe the data to send, already converted.
443 FORMAT is the unit-size (in bits) of the data to be transmitted. */
446 x_reply_selection_request (event
, format
, data
, size
, type
)
447 struct input_event
*event
;
452 XSelectionEvent reply
;
453 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
454 Window window
= SELECTION_EVENT_REQUESTOR (event
);
456 int format_bytes
= format
/8;
457 int max_bytes
= SELECTION_QUANTUM (display
);
459 if (max_bytes
> MAX_SELECTION_QUANTUM
)
460 max_bytes
= MAX_SELECTION_QUANTUM
;
462 reply
.type
= SelectionNotify
;
463 reply
.display
= display
;
464 reply
.requestor
= window
;
465 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
466 reply
.time
= SELECTION_EVENT_TIME (event
);
467 reply
.target
= SELECTION_EVENT_TARGET (event
);
468 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
469 if (reply
.property
== None
)
470 reply
.property
= reply
.target
;
472 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
475 /* Store the data on the requested property.
476 If the selection is large, only store the first N bytes of it.
478 bytes_remaining
= size
* format_bytes
;
479 if (bytes_remaining
<= max_bytes
)
481 /* Send all the data at once, with minimal handshaking. */
483 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
485 XChangeProperty (display
, window
, reply
.property
, type
, format
,
486 PropModeReplace
, data
, size
);
487 /* At this point, the selection was successfully stored; ack it. */
488 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
492 /* Send an INCR selection. */
495 if (x_window_to_frame (window
)) /* #### debug */
496 error ("attempt to transfer an INCR to ourself!");
498 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
500 prop_id
= expect_property_change (display
, window
, reply
.property
,
503 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
504 32, PropModeReplace
, (unsigned char *)
505 &bytes_remaining
, 1);
506 XSelectInput (display
, window
, PropertyChangeMask
);
507 /* Tell 'em the INCR data is there... */
508 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
510 /* First, wait for the requestor to ack by deleting the property.
511 This can run random lisp code (process handlers) or signal. */
512 wait_for_property_change (prop_id
);
514 while (bytes_remaining
)
516 int i
= ((bytes_remaining
< max_bytes
)
519 prop_id
= expect_property_change (display
, window
, reply
.property
,
522 fprintf (stderr
," INCR adding %d\n", i
);
524 /* Append the next chunk of data to the property. */
525 XChangeProperty (display
, window
, reply
.property
, type
, format
,
526 PropModeAppend
, data
, i
/ format_bytes
);
527 bytes_remaining
-= i
;
530 /* Now wait for the requestor to ack this chunk by deleting the
531 property. This can run random lisp code or signal.
533 wait_for_property_change (prop_id
);
535 /* Now write a zero-length chunk to the property to tell the requestor
538 fprintf (stderr
," INCR done\n");
540 if (! waiting_for_other_props_on_window (display
, window
))
541 XSelectInput (display
, window
, 0L);
543 XChangeProperty (display
, window
, reply
.property
, type
, format
,
544 PropModeReplace
, data
, 0);
550 /* Handle a SelectionRequest event EVENT.
551 This is called from keyboard.c when such an event is found in the queue. */
554 x_handle_selection_request (event
)
555 struct input_event
*event
;
557 struct gcpro gcpro1
, gcpro2
, gcpro3
;
558 XSelectionEvent reply
;
559 Lisp_Object local_selection_data
= Qnil
;
560 Lisp_Object selection_symbol
;
561 Lisp_Object target_symbol
= Qnil
;
562 Lisp_Object converted_selection
= Qnil
;
563 Time local_selection_time
;
564 Lisp_Object successful_p
= Qnil
;
567 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
569 reply
.type
= SelectionNotify
; /* Construct the reply event */
570 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
571 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
572 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
573 reply
.time
= SELECTION_EVENT_TIME (event
);
574 reply
.target
= SELECTION_EVENT_TARGET (event
);
575 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
576 if (reply
.property
== None
)
577 reply
.property
= reply
.target
;
579 selection_symbol
= x_atom_to_symbol (reply
.display
,
580 SELECTION_EVENT_SELECTION (event
));
582 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
585 # define CDR(x) (XCONS (x)->cdr)
586 # define CAR(x) (XCONS (x)->car)
587 /* This list isn't user-visible, so it can't "go bad." */
588 if (!CONSP (local_selection_data
)) abort ();
589 if (!CONSP (CDR (local_selection_data
))) abort ();
590 if (!CONSP (CDR (CDR (local_selection_data
)))) abort ();
591 if (!NILP (CDR (CDR (CDR (local_selection_data
))))) abort ();
592 if (!CONSP (CAR (CDR (CDR (local_selection_data
))))) abort ();
593 if (!INTEGERP (CAR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
594 if (!INTEGERP (CDR (CAR (CDR (CDR (local_selection_data
)))))) abort ();
599 if (NILP (local_selection_data
))
601 /* Someone asked for the selection, but we don't have it any more.
603 x_decline_selection_request (event
);
607 local_selection_time
= (Time
)
608 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
610 if (SELECTION_EVENT_TIME (event
) != CurrentTime
611 && local_selection_time
> SELECTION_EVENT_TIME (event
))
613 /* Someone asked for the selection, and we have one, but not the one
616 x_decline_selection_request (event
);
620 count
= specpdl_ptr
- specpdl
;
621 x_selection_current_request
= event
;
622 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
624 target_symbol
= x_atom_to_symbol (reply
.display
,
625 SELECTION_EVENT_TARGET (event
));
627 #if 0 /* #### MULTIPLE doesn't work yet */
628 if (EQ (target_symbol
, QMULTIPLE
))
629 target_symbol
= fetch_multiple_target (event
);
632 /* Convert lisp objects back into binary data */
635 = x_get_local_selection (selection_symbol
, target_symbol
);
637 if (! NILP (converted_selection
))
643 lisp_data_to_selection_data (reply
.display
, converted_selection
,
644 &data
, &type
, &size
, &format
);
646 x_reply_selection_request (event
, format
, data
, size
, type
);
649 /* Indicate we have successfully processed this event. */
650 x_selection_current_request
= 0;
654 unbind_to (count
, Qnil
);
660 /* Let random lisp code notice that the selection has been asked for. */
662 Lisp_Object rest
= Vx_sent_selection_hooks
;
663 if (!EQ (rest
, Qunbound
))
664 for (; CONSP (rest
); rest
= Fcdr (rest
))
665 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
669 /* Handle a SelectionClear event EVENT, which indicates that some other
670 client cleared out our previously asserted selection.
671 This is called from keyboard.c when such an event is found in the queue. */
674 x_handle_selection_clear (event
)
675 struct input_event
*event
;
677 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
678 Atom selection
= SELECTION_EVENT_SELECTION (event
);
679 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
681 Lisp_Object selection_symbol
, local_selection_data
;
682 Time local_selection_time
;
684 selection_symbol
= x_atom_to_symbol (display
, selection
);
686 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
688 /* Well, we already believe that we don't own it, so that's just fine. */
689 if (NILP (local_selection_data
)) return;
691 local_selection_time
= (Time
)
692 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
694 /* This SelectionClear is for a selection that we no longer own, so we can
695 disregard it. (That is, we have reasserted the selection since this
696 request was generated.) */
698 if (changed_owner_time
!= CurrentTime
699 && local_selection_time
> changed_owner_time
)
702 /* Otherwise, we're really honest and truly being told to drop it.
703 Don't use Fdelq as that may QUIT;. */
705 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
706 Vselection_alist
= Fcdr (Vselection_alist
);
710 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
711 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
713 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
718 /* Let random lisp code notice that the selection has been stolen. */
721 Lisp_Object rest
= Vx_lost_selection_hooks
;
722 if (!EQ (rest
, Qunbound
))
723 for (; CONSP (rest
); rest
= Fcdr (rest
))
724 call1 (Fcar (rest
), selection_symbol
);
729 /* This stuff is so that INCR selections are reentrant (that is, so we can
730 be servicing multiple INCR selection requests simultaneously.) I haven't
731 actually tested that yet. */
733 static int prop_location_tick
;
735 static Lisp_Object property_change_reply
;
736 static int property_change_reply_tick
;
738 /* Keep a list of the property changes that are awaited. */
747 struct prop_location
*next
;
750 static struct prop_location
*property_change_wait_list
;
753 property_deleted_p (tick
)
756 struct prop_location
*rest
= property_change_wait_list
;
758 if (rest
->tick
== (int) tick
)
765 /* Nonzero if any properties for DISPLAY and WINDOW
766 are on the list of what we are waiting for. */
769 waiting_for_other_props_on_window (display
, window
)
773 struct prop_location
*rest
= property_change_wait_list
;
775 if (rest
->display
== display
&& rest
->window
== window
)
782 /* Add an entry to the list of property changes we are waiting for.
783 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
784 The return value is a number that uniquely identifies
785 this awaited property change. */
788 expect_property_change (display
, window
, property
, state
)
791 Lisp_Object property
;
794 struct prop_location
*pl
795 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
796 pl
->tick
= ++prop_location_tick
;
797 pl
->display
= display
;
799 pl
->property
= property
;
800 pl
->desired_state
= state
;
801 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 TICK is the number that uniquely identifies the entry. */
810 unexpect_property_change (tick
)
813 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
816 if (rest
->tick
== tick
)
819 prev
->next
= rest
->next
;
821 property_change_wait_list
= rest
->next
;
830 /* Actually wait for a property change.
831 TICK should be the value that expect_property_change returned. */
834 wait_for_property_change (tick
)
836 XCONS (property_change_reply
)->car
= Qnil
;
837 property_change_reply_tick
= tick
;
838 wait_reading_process_input (0, 0, property_change_reply
, 0);
841 /* Called from XTread_socket in response to a PropertyNotify event. */
844 x_handle_property_notify (event
)
845 XPropertyEvent
*event
;
847 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
850 if (rest
->property
== event
->atom
851 && rest
->window
== event
->window
852 && rest
->display
== event
->display
853 && rest
->desired_state
== event
->state
)
856 fprintf (stderr
, "Saw expected prop-%s on %s\n",
857 (event
->state
== PropertyDelete
? "delete" : "change"),
858 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
863 /* If this is the one wait_for_property_change is waiting for,
864 tell it to wake up. */
865 if (rest
->tick
== property_change_reply_tick
)
866 XCONS (property_change_reply
)->car
= Qt
;
869 prev
->next
= rest
->next
;
871 property_change_wait_list
= rest
->next
;
879 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
880 (event
->state
== PropertyDelete
? "delete" : "change"),
881 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
888 #if 0 /* #### MULTIPLE doesn't work yet */
891 fetch_multiple_target (event
)
892 XSelectionRequestEvent
*event
;
894 Display
*display
= event
->display
;
895 Window window
= event
->requestor
;
896 Atom target
= event
->target
;
897 Atom selection_atom
= event
->selection
;
902 x_get_window_property_as_lisp_data (display
, window
, target
,
903 QMULTIPLE
, selection_atom
));
907 copy_multiple_data (obj
)
914 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
916 CHECK_VECTOR (obj
, 0);
917 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
918 for (i
= 0; i
< size
; i
++)
920 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
921 CHECK_VECTOR (vec2
, 0);
922 if (XVECTOR (vec2
)->size
!= 2)
923 /* ??? Confusing error message */
924 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
925 Fcons (vec2
, Qnil
)));
926 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
927 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
928 = XVECTOR (vec2
)->contents
[0];
929 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
930 = XVECTOR (vec2
)->contents
[1];
938 /* Variables for communication with x_handle_selection_notify. */
939 static Atom reading_which_selection
;
940 static Lisp_Object reading_selection_reply
;
941 static Window reading_selection_window
;
943 /* Do protocol to read selection-data from the server.
944 Converts this to Lisp data and returns it. */
947 x_get_foreign_selection (selection_symbol
, target_type
)
948 Lisp_Object selection_symbol
, target_type
;
950 Display
*display
= x_current_display
;
952 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
954 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
956 Time requestor_time
= last_event_timestamp
;
957 Atom target_property
= Xatom_EMACS_TMP
;
958 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
962 if (CONSP (target_type
))
963 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
965 type_atom
= symbol_to_x_atom (display
, target_type
);
968 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
969 requestor_window
, requestor_time
);
972 /* Prepare to block until the reply has been read. */
973 reading_selection_window
= requestor_window
;
974 reading_which_selection
= selection_atom
;
975 XCONS (reading_selection_reply
)->car
= Qnil
;
978 /* This allows quits. Also, don't wait forever. */
979 secs
= x_selection_timeout
/ 1000;
980 usecs
= (x_selection_timeout
% 1000) * 1000;
981 wait_reading_process_input (secs
, usecs
, reading_selection_reply
, 0);
983 if (NILP (XCONS (reading_selection_reply
)->car
))
984 error ("timed out waiting for reply from selection owner");
986 /* Otherwise, the selection is waiting for us on the requested property. */
988 x_get_window_property_as_lisp_data (display
, requestor_window
,
989 target_property
, target_type
,
993 /* Subroutines of x_get_window_property_as_lisp_data */
996 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
997 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1002 unsigned char **data_ret
;
1004 Atom
*actual_type_ret
;
1005 int *actual_format_ret
;
1006 unsigned long *actual_size_ret
;
1010 unsigned long bytes_remaining
;
1012 unsigned char *tmp_data
= 0;
1014 int buffer_size
= SELECTION_QUANTUM (display
);
1015 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1018 /* First probe the thing to find out how big it is. */
1019 result
= XGetWindowProperty (display
, window
, property
,
1020 0, 0, False
, AnyPropertyType
,
1021 actual_type_ret
, actual_format_ret
,
1023 &bytes_remaining
, &tmp_data
);
1025 if (result
!= Success
)
1032 XFree ((char *) tmp_data
);
1035 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1037 if (delete_p
) XDeleteProperty (display
, window
, property
);
1041 total_size
= bytes_remaining
+ 1;
1042 *data_ret
= (unsigned char *) xmalloc (total_size
);
1044 /* Now read, until weve gotten it all. */
1046 while (bytes_remaining
)
1049 int last
= bytes_remaining
;
1052 = XGetWindowProperty (display
, window
, property
,
1053 offset
/4, buffer_size
/4,
1054 (delete_p
? True
: False
),
1056 actual_type_ret
, actual_format_ret
,
1057 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1059 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1061 /* If this doesn't return Success at this point, it means that
1062 some clod deleted the selection while we were in the midst of
1063 reading it. Deal with that, I guess....
1065 if (result
!= Success
) break;
1066 *actual_size_ret
*= *actual_format_ret
/ 8;
1067 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1068 offset
+= *actual_size_ret
;
1069 XFree ((char *) tmp_data
);
1072 *bytes_ret
= offset
;
1076 receive_incremental_selection (display
, window
, property
, target_type
,
1077 min_size_bytes
, data_ret
, size_bytes_ret
,
1078 type_ret
, format_ret
, size_ret
)
1082 Lisp_Object target_type
; /* for error messages only */
1083 unsigned int min_size_bytes
;
1084 unsigned char **data_ret
;
1085 int *size_bytes_ret
;
1087 unsigned long *size_ret
;
1092 *size_bytes_ret
= min_size_bytes
;
1093 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1095 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1097 /* At this point, we have read an INCR property, and deleted it (which
1098 is how we ack its receipt: the sending window will be selecting
1099 PropertyNotify events on our window to notice this.)
1101 Now, we must loop, waiting for the sending window to put a value on
1102 that property, then reading the property, then deleting it to ack.
1103 We are done when the sender places a property of length 0.
1105 prop_id
= expect_property_change (display
, window
, property
,
1109 unsigned char *tmp_data
;
1111 wait_for_property_change (prop_id
);
1112 /* expect it again immediately, because x_get_window_property may
1113 .. no it wont, I dont get it.
1114 .. Ok, I get it now, the Xt code that implements INCR is broken.
1116 prop_id
= expect_property_change (display
, window
, property
,
1118 x_get_window_property (display
, window
, property
,
1119 &tmp_data
, &tmp_size_bytes
,
1120 type_ret
, format_ret
, size_ret
, 1);
1122 if (tmp_size_bytes
== 0) /* we're done */
1125 fprintf (stderr
, " read INCR done\n");
1127 unexpect_property_change (prop_id
);
1128 if (tmp_data
) xfree (tmp_data
);
1132 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1134 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1137 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1138 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1140 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1141 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1143 memcpy ((*data_ret
) + offset
, tmp_data
, tmp_size_bytes
);
1144 offset
+= tmp_size_bytes
;
1149 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1150 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1151 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1154 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1159 Lisp_Object target_type
; /* for error messages only */
1160 Atom selection_atom
; /* for error messages only */
1164 unsigned long actual_size
;
1165 unsigned char *data
= 0;
1169 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1170 &actual_type
, &actual_format
, &actual_size
, 1);
1173 int there_is_a_selection_owner
;
1175 there_is_a_selection_owner
1176 = XGetSelectionOwner (display
, selection_atom
);
1178 while (1) /* Note debugger can no longer return, so this is obsolete */
1180 there_is_a_selection_owner
?
1181 Fcons (build_string ("selection owner couldn't convert"),
1183 ? Fcons (target_type
,
1184 Fcons (x_atom_to_symbol (display
, actual_type
),
1186 : Fcons (target_type
, Qnil
))
1187 : Fcons (build_string ("no selection"),
1188 Fcons (x_atom_to_symbol (display
, selection_atom
),
1192 if (actual_type
== Xatom_INCR
)
1194 /* That wasn't really the data, just the beginning. */
1196 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1198 XFree ((char *) data
);
1200 receive_incremental_selection (display
, window
, property
, target_type
,
1201 min_size_bytes
, &data
, &bytes
,
1202 &actual_type
, &actual_format
,
1206 /* It's been read. Now convert it to a lisp object in some semi-rational
1208 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1209 actual_type
, actual_format
);
1211 xfree ((char *) data
);
1215 /* These functions convert from the selection data read from the server into
1216 something that we can use from Lisp, and vice versa.
1218 Type: Format: Size: Lisp Type:
1219 ----- ------- ----- -----------
1222 ATOM 32 > 1 Vector of Symbols
1224 * 16 > 1 Vector of Integers
1225 * 32 1 if <=16 bits: Integer
1226 if > 16 bits: Cons of top16, bot16
1227 * 32 > 1 Vector of the above
1229 When converting a Lisp number to C, it is assumed to be of format 16 if
1230 it is an integer, and of format 32 if it is a cons of two integers.
1232 When converting a vector of numbers from Lisp to C, it is assumed to be
1233 of format 16 if every element in the vector is an integer, and is assumed
1234 to be of format 32 if any element is a cons of two integers.
1236 When converting an object to C, it may be of the form (SYMBOL . <data>)
1237 where SYMBOL is what we should claim that the type is. Format and
1238 representation are as above. */
1243 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1245 unsigned char *data
;
1250 if (type
== Xatom_NULL
)
1253 /* Convert any 8-bit data to a string, for compactness. */
1254 else if (format
== 8)
1255 return make_string ((char *) data
, size
);
1257 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1258 a vector of symbols.
1260 else if (type
== XA_ATOM
)
1263 if (size
== sizeof (Atom
))
1264 return x_atom_to_symbol (display
, *((Atom
*) data
));
1267 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1268 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1269 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1274 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1275 If the number is > 16 bits, convert it to a cons of integers,
1276 16 bits in each half.
1278 else if (format
== 32 && size
== sizeof (long))
1279 return long_to_cons (((unsigned long *) data
) [0]);
1280 else if (format
== 16 && size
== sizeof (short))
1281 return make_number ((int) (((unsigned short *) data
) [0]));
1283 /* Convert any other kind of data to a vector of numbers, represented
1284 as above (as an integer, or a cons of two 16 bit integers.)
1286 else if (format
== 16)
1289 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1290 for (i
= 0; i
< size
/ 4; i
++)
1292 int j
= (int) ((unsigned short *) data
) [i
];
1293 Faset (v
, i
, make_number (j
));
1300 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1301 for (i
= 0; i
< size
/ 4; i
++)
1303 unsigned long j
= ((unsigned long *) data
) [i
];
1304 Faset (v
, i
, long_to_cons (j
));
1312 lisp_data_to_selection_data (display
, obj
,
1313 data_ret
, type_ret
, size_ret
, format_ret
)
1316 unsigned char **data_ret
;
1318 unsigned int *size_ret
;
1321 Lisp_Object type
= Qnil
;
1322 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1324 type
= XCONS (obj
)->car
;
1325 obj
= XCONS (obj
)->cdr
;
1326 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1327 obj
= XCONS (obj
)->car
;
1330 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1331 { /* This is not the same as declining */
1337 else if (STRINGP (obj
))
1340 *size_ret
= XSTRING (obj
)->size
;
1341 *data_ret
= (unsigned char *) xmalloc (*size_ret
);
1342 memcpy (*data_ret
, (char *) XSTRING (obj
)->data
, *size_ret
);
1343 if (NILP (type
)) type
= QSTRING
;
1345 else if (SYMBOLP (obj
))
1349 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1350 (*data_ret
) [sizeof (Atom
)] = 0;
1351 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1352 if (NILP (type
)) type
= QATOM
;
1354 else if (INTEGERP (obj
)
1355 && XINT (obj
) < 0xFFFF
1356 && XINT (obj
) > -0xFFFF)
1360 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1361 (*data_ret
) [sizeof (short)] = 0;
1362 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1363 if (NILP (type
)) type
= QINTEGER
;
1365 else if (INTEGERP (obj
)
1366 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1367 && (INTEGERP (XCONS (obj
)->cdr
)
1368 || (CONSP (XCONS (obj
)->cdr
)
1369 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1373 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1374 (*data_ret
) [sizeof (long)] = 0;
1375 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1376 if (NILP (type
)) type
= QINTEGER
;
1378 else if (VECTORP (obj
))
1380 /* Lisp_Vectors may represent a set of ATOMs;
1381 a set of 16 or 32 bit INTEGERs;
1382 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1386 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1387 /* This vector is an ATOM set */
1389 if (NILP (type
)) type
= QATOM
;
1390 *size_ret
= XVECTOR (obj
)->size
;
1392 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1393 for (i
= 0; i
< *size_ret
; i
++)
1394 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1395 (*(Atom
**) data_ret
) [i
]
1396 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1398 Fsignal (Qerror
, /* Qselection_error */
1400 ("all elements of selection vector must have same type"),
1401 Fcons (obj
, Qnil
)));
1403 #if 0 /* #### MULTIPLE doesn't work yet */
1404 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1405 /* This vector is an ATOM_PAIR set */
1407 if (NILP (type
)) type
= QATOM_PAIR
;
1408 *size_ret
= XVECTOR (obj
)->size
;
1410 *data_ret
= (unsigned char *)
1411 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1412 for (i
= 0; i
< *size_ret
; i
++)
1413 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1415 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1416 if (XVECTOR (pair
)->size
!= 2)
1419 ("elements of the vector must be vectors of exactly two elements"),
1420 Fcons (pair
, Qnil
)));
1422 (*(Atom
**) data_ret
) [i
* 2]
1423 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1424 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1425 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1430 ("all elements of the vector must be of the same type"),
1431 Fcons (obj
, Qnil
)));
1436 /* This vector is an INTEGER set, or something like it */
1438 *size_ret
= XVECTOR (obj
)->size
;
1439 if (NILP (type
)) type
= QINTEGER
;
1441 for (i
= 0; i
< *size_ret
; i
++)
1442 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1444 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1445 Fsignal (Qerror
, /* Qselection_error */
1447 ("elements of selection vector must be integers or conses of integers"),
1448 Fcons (obj
, Qnil
)));
1450 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1451 for (i
= 0; i
< *size_ret
; i
++)
1452 if (*format_ret
== 32)
1453 (*((unsigned long **) data_ret
)) [i
]
1454 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1456 (*((unsigned short **) data_ret
)) [i
]
1457 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1461 Fsignal (Qerror
, /* Qselection_error */
1462 Fcons (build_string ("unrecognised selection data"),
1463 Fcons (obj
, Qnil
)));
1465 *type_ret
= symbol_to_x_atom (display
, type
);
1469 clean_local_selection_data (obj
)
1473 && INTEGERP (XCONS (obj
)->car
)
1474 && CONSP (XCONS (obj
)->cdr
)
1475 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1476 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1477 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1480 && INTEGERP (XCONS (obj
)->car
)
1481 && INTEGERP (XCONS (obj
)->cdr
))
1483 if (XINT (XCONS (obj
)->car
) == 0)
1484 return XCONS (obj
)->cdr
;
1485 if (XINT (XCONS (obj
)->car
) == -1)
1486 return make_number (- XINT (XCONS (obj
)->cdr
));
1491 int size
= XVECTOR (obj
)->size
;
1494 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1495 copy
= Fmake_vector (size
, Qnil
);
1496 for (i
= 0; i
< size
; i
++)
1497 XVECTOR (copy
)->contents
[i
]
1498 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1504 /* Called from XTread_socket to handle SelectionNotify events.
1505 If it's the selection we are waiting for, stop waiting. */
1508 x_handle_selection_notify (event
)
1509 XSelectionEvent
*event
;
1511 if (event
->requestor
!= reading_selection_window
)
1513 if (event
->selection
!= reading_which_selection
)
1516 XCONS (reading_selection_reply
)->car
= Qt
;
1520 DEFUN ("x-own-selection-internal",
1521 Fx_own_selection_internal
, Sx_own_selection_internal
,
1523 "Assert an X selection of the given TYPE with the given VALUE.\n\
1524 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1525 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1526 VALUE is typically a string, or a cons of two markers, but may be\n\
1527 anything that the functions on `selection-converter-alist' know about.")
1528 (selection_name
, selection_value
)
1529 Lisp_Object selection_name
, selection_value
;
1531 CHECK_SYMBOL (selection_name
, 0);
1532 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1533 x_own_selection (selection_name
, selection_value
);
1534 return selection_value
;
1538 /* Request the selection value from the owner. If we are the owner,
1539 simply return our selection value. If we are not the owner, this
1540 will block until all of the data has arrived. */
1542 DEFUN ("x-get-selection-internal",
1543 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1544 "Return text selected from some X window.\n\
1545 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1546 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1547 TYPE is the type of data desired, typically `STRING'.")
1548 (selection_symbol
, target_type
)
1549 Lisp_Object selection_symbol
, target_type
;
1551 Lisp_Object val
= Qnil
;
1552 struct gcpro gcpro1
, gcpro2
;
1553 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1554 CHECK_SYMBOL (selection_symbol
, 0);
1556 #if 0 /* #### MULTIPLE doesn't work yet */
1557 if (CONSP (target_type
)
1558 && XCONS (target_type
)->car
== QMULTIPLE
)
1560 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1561 /* So we don't destructively modify this... */
1562 target_type
= copy_multiple_data (target_type
);
1566 CHECK_SYMBOL (target_type
, 0);
1568 val
= x_get_local_selection (selection_symbol
, target_type
);
1572 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1577 && SYMBOLP (XCONS (val
)->car
))
1579 val
= XCONS (val
)->cdr
;
1580 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1581 val
= XCONS (val
)->car
;
1583 val
= clean_local_selection_data (val
);
1589 DEFUN ("x-disown-selection-internal",
1590 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1591 "If we own the selection SELECTION, disown it.\n\
1592 Disowning it means there is no such selection.")
1594 Lisp_Object selection
;
1597 Display
*display
= x_current_display
;
1599 Atom selection_atom
;
1600 XSelectionClearEvent event
;
1602 CHECK_SYMBOL (selection
, 0);
1604 timestamp
= last_event_timestamp
;
1606 timestamp
= cons_to_long (time
);
1608 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1609 return Qnil
; /* Don't disown the selection when we're not the owner. */
1611 selection_atom
= symbol_to_x_atom (display
, selection
);
1614 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1617 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1618 generated for a window which owns the selection when that window sets
1619 the selection owner to None. The NCD server does, the MIT Sun4 server
1620 doesn't. So we synthesize one; this means we might get two, but
1621 that's ok, because the second one won't have any effect. */
1622 event
.display
= display
;
1623 event
.selection
= selection_atom
;
1624 event
.time
= timestamp
;
1625 x_handle_selection_clear (&event
);
1630 /* Get rid of all the selections in buffer BUFFER.
1631 This is used when we kill a buffer. */
1634 x_disown_buffer_selections (buffer
)
1638 struct buffer
*buf
= XBUFFER (buffer
);
1640 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1642 Lisp_Object elt
, value
;
1643 elt
= XCONS (tail
)->car
;
1644 value
= XCONS (elt
)->cdr
;
1645 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1646 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1647 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1651 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1653 "Whether the current Emacs process owns the given X Selection.\n\
1654 The arg should be the name of the selection in question, typically one of\n\
1655 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1656 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1657 For convenience, the symbol nil is the same as `PRIMARY',\n\
1658 and t is the same as `SECONDARY'.)")
1660 Lisp_Object selection
;
1662 CHECK_SYMBOL (selection
, 0);
1663 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1664 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1666 if (NILP (Fassq (selection
, Vselection_alist
)))
1671 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1673 "Whether there is an owner for the given X Selection.\n\
1674 The arg should be the name of the selection in question, typically one of\n\
1675 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1676 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1677 For convenience, the symbol nil is the same as `PRIMARY',\n\
1678 and t is the same as `SECONDARY'.)")
1680 Lisp_Object selection
;
1684 Display
*dpy
= x_current_display
;
1685 CHECK_SYMBOL (selection
, 0);
1686 if (!NILP (Fx_selection_owner_p (selection
)))
1688 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1689 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1690 atom
= symbol_to_x_atom (dpy
, selection
);
1694 owner
= XGetSelectionOwner (dpy
, atom
);
1696 return (owner
? Qt
: Qnil
);
1700 #ifdef CUT_BUFFER_SUPPORT
1702 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1704 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1706 initialize_cut_buffers (display
, window
)
1710 unsigned char *data
= (unsigned char *) "";
1712 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1713 PropModeAppend, data, 0)
1714 FROB (XA_CUT_BUFFER0
);
1715 FROB (XA_CUT_BUFFER1
);
1716 FROB (XA_CUT_BUFFER2
);
1717 FROB (XA_CUT_BUFFER3
);
1718 FROB (XA_CUT_BUFFER4
);
1719 FROB (XA_CUT_BUFFER5
);
1720 FROB (XA_CUT_BUFFER6
);
1721 FROB (XA_CUT_BUFFER7
);
1724 cut_buffers_initialized
= 1;
1728 #define CHECK_CUT_BUFFER(symbol,n) \
1729 { CHECK_SYMBOL ((symbol), (n)); \
1730 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1731 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1732 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1733 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1735 Fcons (build_string ("doesn't name a cut buffer"), \
1736 Fcons ((symbol), Qnil))); \
1739 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1740 Sx_get_cut_buffer_internal
, 1, 1, 0,
1741 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1745 Display
*display
= x_current_display
;
1746 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1748 unsigned char *data
;
1755 CHECK_CUT_BUFFER (buffer
, 0);
1756 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1758 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1759 &type
, &format
, &size
, 0);
1760 if (!data
) return Qnil
;
1762 if (format
!= 8 || type
!= XA_STRING
)
1764 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1765 Fcons (x_atom_to_symbol (display
, type
),
1766 Fcons (make_number (format
), Qnil
))));
1768 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1774 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1775 Sx_store_cut_buffer_internal
, 2, 2, 0,
1776 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1778 Lisp_Object buffer
, string
;
1780 Display
*display
= x_current_display
;
1781 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1783 unsigned char *data
;
1785 int bytes_remaining
;
1786 int max_bytes
= SELECTION_QUANTUM (display
);
1787 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1789 CHECK_CUT_BUFFER (buffer
, 0);
1790 CHECK_STRING (string
, 0);
1791 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1792 data
= (unsigned char *) XSTRING (string
)->data
;
1793 bytes
= XSTRING (string
)->size
;
1794 bytes_remaining
= bytes
;
1796 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1800 /* Don't mess up with an empty value. */
1801 if (!bytes_remaining
)
1802 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1803 PropModeReplace
, data
, 0);
1805 while (bytes_remaining
)
1807 int chunk
= (bytes_remaining
< max_bytes
1808 ? bytes_remaining
: max_bytes
);
1809 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1810 (bytes_remaining
== bytes
1815 bytes_remaining
-= chunk
;
1822 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1823 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1824 "Rotate the values of the cut buffers by the given number of steps;\n\
1825 positive means move values forward, negative means backward.")
1829 Display
*display
= x_current_display
;
1830 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1833 CHECK_NUMBER (n
, 0);
1834 if (XINT (n
) == 0) return n
;
1835 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1836 props
[0] = XA_CUT_BUFFER0
;
1837 props
[1] = XA_CUT_BUFFER1
;
1838 props
[2] = XA_CUT_BUFFER2
;
1839 props
[3] = XA_CUT_BUFFER3
;
1840 props
[4] = XA_CUT_BUFFER4
;
1841 props
[5] = XA_CUT_BUFFER5
;
1842 props
[6] = XA_CUT_BUFFER6
;
1843 props
[7] = XA_CUT_BUFFER7
;
1845 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1853 Xatoms_of_xselect ()
1855 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1858 /* Non-predefined atoms that we might end up using a lot */
1859 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1860 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1861 Xatom_TEXT
= ATOM ("TEXT");
1862 Xatom_DELETE
= ATOM ("DELETE");
1863 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1864 Xatom_INCR
= ATOM ("INCR");
1865 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1866 Xatom_TARGETS
= ATOM ("TARGETS");
1867 Xatom_NULL
= ATOM ("NULL");
1868 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1875 defsubr (&Sx_get_selection_internal
);
1876 defsubr (&Sx_own_selection_internal
);
1877 defsubr (&Sx_disown_selection_internal
);
1878 defsubr (&Sx_selection_owner_p
);
1879 defsubr (&Sx_selection_exists_p
);
1881 #ifdef CUT_BUFFER_SUPPORT
1882 defsubr (&Sx_get_cut_buffer_internal
);
1883 defsubr (&Sx_store_cut_buffer_internal
);
1884 defsubr (&Sx_rotate_cut_buffers_internal
);
1885 cut_buffers_initialized
= 0;
1888 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1889 staticpro (&reading_selection_reply
);
1890 reading_selection_window
= 0;
1891 reading_which_selection
= 0;
1893 property_change_wait_list
= 0;
1894 prop_location_tick
= 0;
1895 property_change_reply
= Fcons (Qnil
, Qnil
);
1896 staticpro (&property_change_reply
);
1898 Vselection_alist
= Qnil
;
1899 staticpro (&Vselection_alist
);
1901 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1902 "An alist associating X Windows selection-types with functions.\n\
1903 These functions are called to convert the selection, with three args:\n\
1904 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1905 a desired type to which the selection should be converted;\n\
1906 and the local selection value (whatever was given to `x-own-selection').\n\
1908 The function should return the value to send to the X server\n\
1909 \(typically a string). A return value of nil\n\
1910 means that the conversion could not be done.\n\
1911 A return value which is the symbol `NULL'\n\
1912 means that a side-effect was executed,\n\
1913 and there is no meaningful selection value.");
1914 Vselection_converter_alist
= Qnil
;
1916 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1917 "A list of functions to be called when Emacs loses an X selection.\n\
1918 \(This happens when some other X client makes its own selection\n\
1919 or when a Lisp program explicitly clears the selection.)\n\
1920 The functions are called with one argument, the selection type\n\
1921 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1922 Vx_lost_selection_hooks
= Qnil
;
1924 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1925 "A list of functions to be called when Emacs answers a selection request.\n\
1926 The functions are called with four arguments:\n\
1927 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1928 - the selection-type which Emacs was asked to convert the\n\
1929 selection into before sending (for example, `STRING' or `LENGTH');\n\
1930 - a flag indicating success or failure for responding to the request.\n\
1931 We might have failed (and declined the request) for any number of reasons,\n\
1932 including being asked for a selection that we no longer own, or being asked\n\
1933 to convert into a type that we don't know about or that is inappropriate.\n\
1934 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
1935 it merely informs you that they have happened.");
1936 Vx_sent_selection_hooks
= Qnil
;
1938 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
1939 "Number of milliseconds to wait for a selection reply.\n\
1940 If the selection owner doens't reply in this time, we give up.\n\
1941 A value of 0 means wait as long as necessary. This is initialized from the\n\
1942 \"*selectionTimeout\" resource.");
1943 x_selection_timeout
= 0;
1945 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
1946 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
1947 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
1948 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
1949 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
1950 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1951 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
1952 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1953 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
1954 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
1955 QINCR
= intern ("INCR"); staticpro (&QINCR
);
1956 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
1957 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
1958 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
1959 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
1960 QNULL
= intern ("NULL"); staticpro (&QNULL
);
1962 #ifdef CUT_BUFFER_SUPPORT
1963 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
1964 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
1965 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
1966 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
1967 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
1968 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
1969 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
1970 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);