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
23 x_selection_timeout initial value */
25 /* Rewritten by jwz */
30 #include <stdio.h> /* termhooks.h needs this */
31 #include "termhooks.h"
33 #include "xterm.h" /* for all of the X includes */
34 #include "dispextern.h" /* frame.h seems to want this */
35 #include "frame.h" /* Need this to get the X window of selected_frame */
36 #include "blockinput.h"
40 #define CUT_BUFFER_SUPPORT
42 static Atom Xatom_CLIPBOARD
, Xatom_TIMESTAMP
, Xatom_TEXT
, Xatom_DELETE
,
43 Xatom_MULTIPLE
, Xatom_INCR
, Xatom_EMACS_TMP
, Xatom_TARGETS
, Xatom_NULL
,
46 Lisp_Object QPRIMARY
, QSECONDARY
, QSTRING
, QINTEGER
, QCLIPBOARD
, QTIMESTAMP
,
47 QTEXT
, QDELETE
, QMULTIPLE
, QINCR
, QEMACS_TMP
, QTARGETS
, QATOM
, QNULL
,
50 #ifdef CUT_BUFFER_SUPPORT
51 Lisp_Object QCUT_BUFFER0
, QCUT_BUFFER1
, QCUT_BUFFER2
, QCUT_BUFFER3
,
52 QCUT_BUFFER4
, QCUT_BUFFER5
, QCUT_BUFFER6
, QCUT_BUFFER7
;
55 Lisp_Object Vx_lost_selection_hooks
;
56 Lisp_Object Vx_sent_selection_hooks
;
58 /* If this is a smaller number than the max-request-size of the display,
59 emacs will use INCR selection transfer when the selection is larger
60 than this. The max-request-size is usually around 64k, so if you want
61 emacs to use incremental selection transfers when the selection is
62 smaller than that, set this. I added this mostly for debugging the
63 incremental transfer stuff, but it might improve server performance.
65 #define MAX_SELECTION_QUANTUM 0xFFFFFF
68 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
70 #define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
73 /* The timestamp of the last input event Emacs received from the X server. */
74 unsigned long last_event_timestamp
;
76 /* This is an association list whose elements are of the form
77 ( selection-name selection-value selection-timestamp )
78 selection-name is a lisp symbol, whose name is the name of an X Atom.
79 selection-value is the value that emacs owns for that selection.
80 It may be any kind of Lisp object.
81 selection-timestamp is the time at which emacs began owning this selection,
82 as a cons of two 16-bit numbers (making a 32 bit time.)
83 If there is an entry in this alist, then it can be assumed that emacs owns
85 The only (eq) parts of this list that are visible from Lisp are the
88 Lisp_Object Vselection_alist
;
90 /* This is an alist whose CARs are selection-types (whose names are the same
91 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
92 call to convert the given Emacs selection value to a string representing
93 the given selection type. This is for Lisp-level extension of the emacs
96 Lisp_Object Vselection_converter_alist
;
98 /* If the selection owner takes too long to reply to a selection request,
99 we give up on it. This is in seconds (0 = no timeout.)
101 int x_selection_timeout
;
104 /* Utility functions */
106 static void lisp_data_to_selection_data ();
107 static Lisp_Object
selection_data_to_lisp_data ();
108 static Lisp_Object
x_get_window_property_as_lisp_data ();
110 static int expect_property_change ();
111 static void wait_for_property_change ();
112 static void unexpect_property_change ();
113 static int waiting_for_other_props_on_window ();
115 /* This converts a Lisp symbol to a server Atom, avoiding a server
116 roundtrip whenever possible. */
119 symbol_to_x_atom (display
, sym
)
124 if (NILP (sym
)) return 0;
125 if (EQ (sym
, QPRIMARY
)) return XA_PRIMARY
;
126 if (EQ (sym
, QSECONDARY
)) return XA_SECONDARY
;
127 if (EQ (sym
, QSTRING
)) return XA_STRING
;
128 if (EQ (sym
, QINTEGER
)) return XA_INTEGER
;
129 if (EQ (sym
, QATOM
)) return XA_ATOM
;
130 if (EQ (sym
, QCLIPBOARD
)) return Xatom_CLIPBOARD
;
131 if (EQ (sym
, QTIMESTAMP
)) return Xatom_TIMESTAMP
;
132 if (EQ (sym
, QTEXT
)) return Xatom_TEXT
;
133 if (EQ (sym
, QDELETE
)) return Xatom_DELETE
;
134 if (EQ (sym
, QMULTIPLE
)) return Xatom_MULTIPLE
;
135 if (EQ (sym
, QINCR
)) return Xatom_INCR
;
136 if (EQ (sym
, QEMACS_TMP
)) return Xatom_EMACS_TMP
;
137 if (EQ (sym
, QTARGETS
)) return Xatom_TARGETS
;
138 if (EQ (sym
, QNULL
)) return Xatom_NULL
;
139 #ifdef CUT_BUFFER_SUPPORT
140 if (EQ (sym
, QCUT_BUFFER0
)) return XA_CUT_BUFFER0
;
141 if (EQ (sym
, QCUT_BUFFER1
)) return XA_CUT_BUFFER1
;
142 if (EQ (sym
, QCUT_BUFFER2
)) return XA_CUT_BUFFER2
;
143 if (EQ (sym
, QCUT_BUFFER3
)) return XA_CUT_BUFFER3
;
144 if (EQ (sym
, QCUT_BUFFER4
)) return XA_CUT_BUFFER4
;
145 if (EQ (sym
, QCUT_BUFFER5
)) return XA_CUT_BUFFER5
;
146 if (EQ (sym
, QCUT_BUFFER6
)) return XA_CUT_BUFFER6
;
147 if (EQ (sym
, QCUT_BUFFER7
)) return XA_CUT_BUFFER7
;
149 if (!SYMBOLP (sym
)) abort ();
152 fprintf (stderr
, " XInternAtom %s\n", (char *) XSYMBOL (sym
)->name
->data
);
155 val
= XInternAtom (display
, (char *) XSYMBOL (sym
)->name
->data
, False
);
161 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
162 and calls to intern whenever possible. */
165 x_atom_to_symbol (display
, atom
)
171 if (! atom
) return Qnil
;
184 #ifdef CUT_BUFFER_SUPPORT
204 if (atom
== Xatom_CLIPBOARD
)
206 if (atom
== Xatom_TIMESTAMP
)
208 if (atom
== Xatom_TEXT
)
210 if (atom
== Xatom_DELETE
)
212 if (atom
== Xatom_MULTIPLE
)
214 if (atom
== Xatom_INCR
)
216 if (atom
== Xatom_EMACS_TMP
)
218 if (atom
== Xatom_TARGETS
)
220 if (atom
== Xatom_NULL
)
224 str
= XGetAtomName (display
, atom
);
227 fprintf (stderr
, " XGetAtomName --> %s\n", str
);
229 if (! str
) return Qnil
;
237 /* Do protocol to assert ourself as a selection owner.
238 Update the Vselection_alist so that we can reply to later requests for
242 x_own_selection (selection_name
, selection_value
)
243 Lisp_Object selection_name
, selection_value
;
245 Display
*display
= x_current_display
;
247 Window selecting_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
249 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
251 Time time
= last_event_timestamp
;
254 CHECK_SYMBOL (selection_name
, 0);
255 selection_atom
= symbol_to_x_atom (display
, selection_name
);
258 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
261 /* Now update the local cache */
263 Lisp_Object selection_time
;
264 Lisp_Object selection_data
;
265 Lisp_Object prev_value
;
267 selection_time
= long_to_cons ((unsigned long) time
);
268 selection_data
= Fcons (selection_name
,
269 Fcons (selection_value
,
270 Fcons (selection_time
, Qnil
)));
271 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
273 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
275 /* If we already owned the selection, remove the old selection data.
276 Perhaps we should destructively modify it instead.
277 Don't use Fdelq as that may QUIT. */
278 if (!NILP (prev_value
))
280 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
281 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
282 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
284 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
291 /* Given a selection-name and desired type, look up our local copy of
292 the selection value and convert it to the type.
293 The value is nil or a string.
294 This function is used both for remote requests
295 and for local x-get-selection-internal.
297 This calls random Lisp code, and may signal or gc. */
300 x_get_local_selection (selection_symbol
, target_type
)
301 Lisp_Object selection_symbol
, target_type
;
303 Lisp_Object local_value
;
304 Lisp_Object handler_fn
, value
, type
, check
;
307 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
309 if (NILP (local_value
)) return Qnil
;
311 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
312 if (EQ (target_type
, QTIMESTAMP
))
315 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
318 else if (EQ (target_type
, QDELETE
))
321 Fx_disown_selection_internal
323 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
328 #if 0 /* #### MULTIPLE doesn't work yet */
329 else if (CONSP (target_type
)
330 && XCONS (target_type
)->car
== QMULTIPLE
)
332 Lisp_Object pairs
= XCONS (target_type
)->cdr
;
333 int size
= XVECTOR (pairs
)->size
;
335 /* If the target is MULTIPLE, then target_type looks like
336 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
337 We modify the second element of each pair in the vector and
338 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
340 for (i
= 0; i
< size
; i
++)
342 Lisp_Object pair
= XVECTOR (pairs
)->contents
[i
];
343 XVECTOR (pair
)->contents
[1]
344 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
345 XVECTOR (pair
)->contents
[1]);
352 /* Don't allow a quit within the converter.
353 When the user types C-g, he would be surprised
354 if by luck it came during a converter. */
355 count
= specpdl_ptr
- specpdl
;
356 specbind (Qinhibit_quit
, Qt
);
358 CHECK_SYMBOL (target_type
, 0);
359 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
360 if (!NILP (handler_fn
))
361 value
= call3 (handler_fn
,
362 selection_symbol
, target_type
,
363 XCONS (XCONS (local_value
)->cdr
)->car
);
366 unbind_to (count
, Qnil
);
369 /* Make sure this value is of a type that we could transmit
370 to another X client. */
374 && SYMBOLP (XCONS (value
)->car
))
375 type
= XCONS (value
)->car
,
376 check
= XCONS (value
)->cdr
;
384 /* Check for a value that cons_to_long could handle. */
385 else if (CONSP (check
)
386 && INTEGERP (XCONS (check
)->car
)
387 && (INTEGERP (XCONS (check
)->cdr
)
389 (CONSP (XCONS (check
)->cdr
)
390 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
391 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
396 Fcons (build_string ("invalid data returned by selection-conversion function"),
397 Fcons (handler_fn
, Fcons (value
, Qnil
))));
400 /* Subroutines of x_reply_selection_request. */
402 /* Send a SelectionNotify event to the requestor with property=None,
403 meaning we were unable to do what they wanted. */
406 x_decline_selection_request (event
)
407 struct input_event
*event
;
409 XSelectionEvent reply
;
410 reply
.type
= SelectionNotify
;
411 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
412 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
413 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
414 reply
.time
= SELECTION_EVENT_TIME (event
);
415 reply
.target
= SELECTION_EVENT_TARGET (event
);
416 reply
.property
= None
;
419 (void) XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
424 /* This is the selection request currently being processed.
425 It is set to zero when the request is fully processed. */
426 static struct input_event
*x_selection_current_request
;
428 /* Used as an unwind-protect clause so that, if a selection-converter signals
429 an error, we tell the requestor that we were unable to do what they wanted
430 before we throw to top-level or go into the debugger or whatever. */
433 x_selection_request_lisp_error (ignore
)
436 if (x_selection_current_request
!= 0)
437 x_decline_selection_request (x_selection_current_request
);
441 /* Send the reply to a selection request event EVENT.
442 TYPE is the type of selection data requested.
443 DATA and SIZE describe the data to send, already converted.
444 FORMAT is the unit-size (in bits) of the data to be transmitted. */
447 x_reply_selection_request (event
, format
, data
, size
, type
)
448 struct input_event
*event
;
453 XSelectionEvent reply
;
454 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
455 Window window
= SELECTION_EVENT_REQUESTOR (event
);
457 int format_bytes
= format
/8;
458 int max_bytes
= SELECTION_QUANTUM (display
);
460 if (max_bytes
> MAX_SELECTION_QUANTUM
)
461 max_bytes
= MAX_SELECTION_QUANTUM
;
463 reply
.type
= SelectionNotify
;
464 reply
.display
= display
;
465 reply
.requestor
= window
;
466 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
467 reply
.time
= SELECTION_EVENT_TIME (event
);
468 reply
.target
= SELECTION_EVENT_TARGET (event
);
469 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
470 if (reply
.property
== None
)
471 reply
.property
= reply
.target
;
473 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
476 /* Store the data on the requested property.
477 If the selection is large, only store the first N bytes of it.
479 bytes_remaining
= size
* format_bytes
;
480 if (bytes_remaining
<= max_bytes
)
482 /* Send all the data at once, with minimal handshaking. */
484 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
486 XChangeProperty (display
, window
, reply
.property
, type
, format
,
487 PropModeReplace
, data
, size
);
488 /* At this point, the selection was successfully stored; ack it. */
489 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
493 /* Send an INCR selection. */
496 if (x_window_to_frame (window
)) /* #### debug */
497 error ("attempt to transfer an INCR to ourself!");
499 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
501 prop_id
= expect_property_change (display
, window
, reply
.property
,
504 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
505 32, PropModeReplace
, (unsigned char *)
506 &bytes_remaining
, 1);
507 XSelectInput (display
, window
, PropertyChangeMask
);
508 /* Tell 'em the INCR data is there... */
509 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
511 /* First, wait for the requestor to ack by deleting the property.
512 This can run random lisp code (process handlers) or signal. */
513 wait_for_property_change (prop_id
);
515 while (bytes_remaining
)
517 int i
= ((bytes_remaining
< max_bytes
)
520 prop_id
= expect_property_change (display
, window
, reply
.property
,
523 fprintf (stderr
," INCR adding %d\n", i
);
525 /* Append the next chunk of data to the property. */
526 XChangeProperty (display
, window
, reply
.property
, type
, format
,
527 PropModeAppend
, data
, i
/ format_bytes
);
528 bytes_remaining
-= i
;
531 /* Now wait for the requestor to ack this chunk by deleting the
532 property. This can run random lisp code or signal.
534 wait_for_property_change (prop_id
);
536 /* Now write a zero-length chunk to the property to tell the requestor
539 fprintf (stderr
," INCR done\n");
541 if (! waiting_for_other_props_on_window (display
, window
))
542 XSelectInput (display
, window
, 0L);
544 XChangeProperty (display
, window
, reply
.property
, type
, format
,
545 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
);
961 if (CONSP (target_type
))
962 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
964 type_atom
= symbol_to_x_atom (display
, target_type
);
967 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
968 requestor_window
, requestor_time
);
971 /* Prepare to block until the reply has been read. */
972 reading_selection_window
= requestor_window
;
973 reading_which_selection
= selection_atom
;
974 XCONS (reading_selection_reply
)->car
= Qnil
;
977 /* This allows quits. */
978 wait_reading_process_input (x_selection_timeout
, 0,
979 reading_selection_reply
, 0);
981 if (NILP (XCONS (reading_selection_reply
)->car
))
982 error ("timed out waiting for reply from selection owner");
984 /* Otherwise, the selection is waiting for us on the requested property. */
986 x_get_window_property_as_lisp_data (display
, requestor_window
,
987 target_property
, target_type
,
991 /* Subroutines of x_get_window_property_as_lisp_data */
994 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
995 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1000 unsigned char **data_ret
;
1002 Atom
*actual_type_ret
;
1003 int *actual_format_ret
;
1004 unsigned long *actual_size_ret
;
1008 unsigned long bytes_remaining
;
1010 unsigned char *tmp_data
= 0;
1012 int buffer_size
= SELECTION_QUANTUM (display
);
1013 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1016 /* First probe the thing to find out how big it is. */
1017 result
= XGetWindowProperty (display
, window
, property
,
1018 0, 0, False
, AnyPropertyType
,
1019 actual_type_ret
, actual_format_ret
,
1021 &bytes_remaining
, &tmp_data
);
1023 if (result
!= Success
)
1030 XFree ((char *) tmp_data
);
1033 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1035 if (delete_p
) XDeleteProperty (display
, window
, property
);
1039 total_size
= bytes_remaining
+ 1;
1040 *data_ret
= (unsigned char *) xmalloc (total_size
);
1042 /* Now read, until weve gotten it all. */
1044 while (bytes_remaining
)
1047 int last
= bytes_remaining
;
1050 = XGetWindowProperty (display
, window
, property
,
1051 offset
/4, buffer_size
/4,
1052 (delete_p
? True
: False
),
1054 actual_type_ret
, actual_format_ret
,
1055 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1057 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1059 /* If this doesn't return Success at this point, it means that
1060 some clod deleted the selection while we were in the midst of
1061 reading it. Deal with that, I guess....
1063 if (result
!= Success
) break;
1064 *actual_size_ret
*= *actual_format_ret
/ 8;
1065 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1066 offset
+= *actual_size_ret
;
1067 XFree ((char *) tmp_data
);
1070 *bytes_ret
= offset
;
1074 receive_incremental_selection (display
, window
, property
, target_type
,
1075 min_size_bytes
, data_ret
, size_bytes_ret
,
1076 type_ret
, format_ret
, size_ret
)
1080 Lisp_Object target_type
; /* for error messages only */
1081 unsigned int min_size_bytes
;
1082 unsigned char **data_ret
;
1083 int *size_bytes_ret
;
1085 unsigned long *size_ret
;
1090 *size_bytes_ret
= min_size_bytes
;
1091 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1093 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1095 /* At this point, we have read an INCR property, and deleted it (which
1096 is how we ack its receipt: the sending window will be selecting
1097 PropertyNotify events on our window to notice this.)
1099 Now, we must loop, waiting for the sending window to put a value on
1100 that property, then reading the property, then deleting it to ack.
1101 We are done when the sender places a property of length 0.
1103 prop_id
= expect_property_change (display
, window
, property
,
1107 unsigned char *tmp_data
;
1109 wait_for_property_change (prop_id
);
1110 /* expect it again immediately, because x_get_window_property may
1111 .. no it wont, I dont get it.
1112 .. Ok, I get it now, the Xt code that implements INCR is broken.
1114 prop_id
= expect_property_change (display
, window
, property
,
1116 x_get_window_property (display
, window
, property
,
1117 &tmp_data
, &tmp_size_bytes
,
1118 type_ret
, format_ret
, size_ret
, 1);
1120 if (tmp_size_bytes
== 0) /* we're done */
1123 fprintf (stderr
, " read INCR done\n");
1125 unexpect_property_change (prop_id
);
1126 if (tmp_data
) xfree (tmp_data
);
1130 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1132 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1135 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1136 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1138 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1139 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1141 memcpy ((*data_ret
) + offset
, tmp_data
, tmp_size_bytes
);
1142 offset
+= tmp_size_bytes
;
1147 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1148 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1149 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1152 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1157 Lisp_Object target_type
; /* for error messages only */
1158 Atom selection_atom
; /* for error messages only */
1162 unsigned long actual_size
;
1163 unsigned char *data
= 0;
1167 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1168 &actual_type
, &actual_format
, &actual_size
, 1);
1171 int there_is_a_selection_owner
;
1173 there_is_a_selection_owner
1174 = XGetSelectionOwner (display
, selection_atom
);
1176 while (1) /* Note debugger can no longer return, so this is obsolete */
1178 there_is_a_selection_owner
?
1179 Fcons (build_string ("selection owner couldn't convert"),
1181 ? Fcons (target_type
,
1182 Fcons (x_atom_to_symbol (display
, actual_type
),
1184 : Fcons (target_type
, Qnil
))
1185 : Fcons (build_string ("no selection"),
1186 Fcons (x_atom_to_symbol (display
, selection_atom
),
1190 if (actual_type
== Xatom_INCR
)
1192 /* That wasn't really the data, just the beginning. */
1194 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1196 XFree ((char *) data
);
1198 receive_incremental_selection (display
, window
, property
, target_type
,
1199 min_size_bytes
, &data
, &bytes
,
1200 &actual_type
, &actual_format
,
1204 /* It's been read. Now convert it to a lisp object in some semi-rational
1206 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1207 actual_type
, actual_format
);
1209 xfree ((char *) data
);
1213 /* These functions convert from the selection data read from the server into
1214 something that we can use from Lisp, and vice versa.
1216 Type: Format: Size: Lisp Type:
1217 ----- ------- ----- -----------
1220 ATOM 32 > 1 Vector of Symbols
1222 * 16 > 1 Vector of Integers
1223 * 32 1 if <=16 bits: Integer
1224 if > 16 bits: Cons of top16, bot16
1225 * 32 > 1 Vector of the above
1227 When converting a Lisp number to C, it is assumed to be of format 16 if
1228 it is an integer, and of format 32 if it is a cons of two integers.
1230 When converting a vector of numbers from Lisp to C, it is assumed to be
1231 of format 16 if every element in the vector is an integer, and is assumed
1232 to be of format 32 if any element is a cons of two integers.
1234 When converting an object to C, it may be of the form (SYMBOL . <data>)
1235 where SYMBOL is what we should claim that the type is. Format and
1236 representation are as above. */
1241 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1243 unsigned char *data
;
1248 if (type
== Xatom_NULL
)
1251 /* Convert any 8-bit data to a string, for compactness. */
1252 else if (format
== 8)
1253 return make_string ((char *) data
, size
);
1255 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1256 a vector of symbols.
1258 else if (type
== XA_ATOM
)
1261 if (size
== sizeof (Atom
))
1262 return x_atom_to_symbol (display
, *((Atom
*) data
));
1265 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1266 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1267 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1272 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1273 If the number is > 16 bits, convert it to a cons of integers,
1274 16 bits in each half.
1276 else if (format
== 32 && size
== sizeof (long))
1277 return long_to_cons (((unsigned long *) data
) [0]);
1278 else if (format
== 16 && size
== sizeof (short))
1279 return make_number ((int) (((unsigned short *) data
) [0]));
1281 /* Convert any other kind of data to a vector of numbers, represented
1282 as above (as an integer, or a cons of two 16 bit integers.)
1284 else if (format
== 16)
1287 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1288 for (i
= 0; i
< size
/ 4; i
++)
1290 int j
= (int) ((unsigned short *) data
) [i
];
1291 Faset (v
, i
, make_number (j
));
1298 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1299 for (i
= 0; i
< size
/ 4; i
++)
1301 unsigned long j
= ((unsigned long *) data
) [i
];
1302 Faset (v
, i
, long_to_cons (j
));
1310 lisp_data_to_selection_data (display
, obj
,
1311 data_ret
, type_ret
, size_ret
, format_ret
)
1314 unsigned char **data_ret
;
1316 unsigned int *size_ret
;
1319 Lisp_Object type
= Qnil
;
1320 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1322 type
= XCONS (obj
)->car
;
1323 obj
= XCONS (obj
)->cdr
;
1324 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1325 obj
= XCONS (obj
)->car
;
1328 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1329 { /* This is not the same as declining */
1335 else if (STRINGP (obj
))
1338 *size_ret
= XSTRING (obj
)->size
;
1339 *data_ret
= (unsigned char *) xmalloc (*size_ret
);
1340 memcpy (*data_ret
, (char *) XSTRING (obj
)->data
, *size_ret
);
1341 if (NILP (type
)) type
= QSTRING
;
1343 else if (SYMBOLP (obj
))
1347 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1348 (*data_ret
) [sizeof (Atom
)] = 0;
1349 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1350 if (NILP (type
)) type
= QATOM
;
1352 else if (INTEGERP (obj
)
1353 && XINT (obj
) < 0xFFFF
1354 && XINT (obj
) > -0xFFFF)
1358 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1359 (*data_ret
) [sizeof (short)] = 0;
1360 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1361 if (NILP (type
)) type
= QINTEGER
;
1363 else if (INTEGERP (obj
)
1364 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1365 && (INTEGERP (XCONS (obj
)->cdr
)
1366 || (CONSP (XCONS (obj
)->cdr
)
1367 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1371 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1372 (*data_ret
) [sizeof (long)] = 0;
1373 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1374 if (NILP (type
)) type
= QINTEGER
;
1376 else if (VECTORP (obj
))
1378 /* Lisp_Vectors may represent a set of ATOMs;
1379 a set of 16 or 32 bit INTEGERs;
1380 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1384 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1385 /* This vector is an ATOM set */
1387 if (NILP (type
)) type
= QATOM
;
1388 *size_ret
= XVECTOR (obj
)->size
;
1390 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1391 for (i
= 0; i
< *size_ret
; i
++)
1392 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1393 (*(Atom
**) data_ret
) [i
]
1394 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1396 Fsignal (Qerror
, /* Qselection_error */
1398 ("all elements of selection vector must have same type"),
1399 Fcons (obj
, Qnil
)));
1401 #if 0 /* #### MULTIPLE doesn't work yet */
1402 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1403 /* This vector is an ATOM_PAIR set */
1405 if (NILP (type
)) type
= QATOM_PAIR
;
1406 *size_ret
= XVECTOR (obj
)->size
;
1408 *data_ret
= (unsigned char *)
1409 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1410 for (i
= 0; i
< *size_ret
; i
++)
1411 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1413 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1414 if (XVECTOR (pair
)->size
!= 2)
1417 ("elements of the vector must be vectors of exactly two elements"),
1418 Fcons (pair
, Qnil
)));
1420 (*(Atom
**) data_ret
) [i
* 2]
1421 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1422 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1423 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1428 ("all elements of the vector must be of the same type"),
1429 Fcons (obj
, Qnil
)));
1434 /* This vector is an INTEGER set, or something like it */
1436 *size_ret
= XVECTOR (obj
)->size
;
1437 if (NILP (type
)) type
= QINTEGER
;
1439 for (i
= 0; i
< *size_ret
; i
++)
1440 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1442 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1443 Fsignal (Qerror
, /* Qselection_error */
1445 ("elements of selection vector must be integers or conses of integers"),
1446 Fcons (obj
, Qnil
)));
1448 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1449 for (i
= 0; i
< *size_ret
; i
++)
1450 if (*format_ret
== 32)
1451 (*((unsigned long **) data_ret
)) [i
]
1452 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1454 (*((unsigned short **) data_ret
)) [i
]
1455 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1459 Fsignal (Qerror
, /* Qselection_error */
1460 Fcons (build_string ("unrecognised selection data"),
1461 Fcons (obj
, Qnil
)));
1463 *type_ret
= symbol_to_x_atom (display
, type
);
1467 clean_local_selection_data (obj
)
1471 && INTEGERP (XCONS (obj
)->car
)
1472 && CONSP (XCONS (obj
)->cdr
)
1473 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1474 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1475 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1478 && INTEGERP (XCONS (obj
)->car
)
1479 && INTEGERP (XCONS (obj
)->cdr
))
1481 if (XINT (XCONS (obj
)->car
) == 0)
1482 return XCONS (obj
)->cdr
;
1483 if (XINT (XCONS (obj
)->car
) == -1)
1484 return make_number (- XINT (XCONS (obj
)->cdr
));
1489 int size
= XVECTOR (obj
)->size
;
1492 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1493 copy
= Fmake_vector (size
, Qnil
);
1494 for (i
= 0; i
< size
; i
++)
1495 XVECTOR (copy
)->contents
[i
]
1496 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1502 /* Called from XTread_socket to handle SelectionNotify events.
1503 If it's the selection we are waiting for, stop waiting. */
1506 x_handle_selection_notify (event
)
1507 XSelectionEvent
*event
;
1509 if (event
->requestor
!= reading_selection_window
)
1511 if (event
->selection
!= reading_which_selection
)
1514 XCONS (reading_selection_reply
)->car
= Qt
;
1518 DEFUN ("x-own-selection-internal",
1519 Fx_own_selection_internal
, Sx_own_selection_internal
,
1521 "Assert an X selection of the given TYPE with the given VALUE.\n\
1522 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1523 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1524 VALUE is typically a string, or a cons of two markers, but may be\n\
1525 anything that the functions on `selection-converter-alist' know about.")
1526 (selection_name
, selection_value
)
1527 Lisp_Object selection_name
, selection_value
;
1529 CHECK_SYMBOL (selection_name
, 0);
1530 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1531 x_own_selection (selection_name
, selection_value
);
1532 return selection_value
;
1536 /* Request the selection value from the owner. If we are the owner,
1537 simply return our selection value. If we are not the owner, this
1538 will block until all of the data has arrived. */
1540 DEFUN ("x-get-selection-internal",
1541 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1542 "Return text selected from some X window.\n\
1543 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1544 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1545 TYPE is the type of data desired, typically `STRING'.")
1546 (selection_symbol
, target_type
)
1547 Lisp_Object selection_symbol
, target_type
;
1549 Lisp_Object val
= Qnil
;
1550 struct gcpro gcpro1
, gcpro2
;
1551 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1552 CHECK_SYMBOL (selection_symbol
, 0);
1554 #if 0 /* #### MULTIPLE doesn't work yet */
1555 if (CONSP (target_type
)
1556 && XCONS (target_type
)->car
== QMULTIPLE
)
1558 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1559 /* So we don't destructively modify this... */
1560 target_type
= copy_multiple_data (target_type
);
1564 CHECK_SYMBOL (target_type
, 0);
1566 val
= x_get_local_selection (selection_symbol
, target_type
);
1570 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1575 && SYMBOLP (XCONS (val
)->car
))
1577 val
= XCONS (val
)->cdr
;
1578 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1579 val
= XCONS (val
)->car
;
1581 val
= clean_local_selection_data (val
);
1587 DEFUN ("x-disown-selection-internal",
1588 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1589 "If we own the selection SELECTION, disown it.\n\
1590 Disowning it means there is no such selection.")
1592 Lisp_Object selection
;
1595 Display
*display
= x_current_display
;
1597 Atom selection_atom
;
1598 XSelectionClearEvent event
;
1600 CHECK_SYMBOL (selection
, 0);
1602 timestamp
= last_event_timestamp
;
1604 timestamp
= cons_to_long (time
);
1606 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1607 return Qnil
; /* Don't disown the selection when we're not the owner. */
1609 selection_atom
= symbol_to_x_atom (display
, selection
);
1612 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1615 /* It doesn't seem to be guarenteed that a SelectionClear event will be
1616 generated for a window which owns the selection when that window sets
1617 the selection owner to None. The NCD server does, the MIT Sun4 server
1618 doesn't. So we synthesize one; this means we might get two, but
1619 that's ok, because the second one won't have any effect. */
1620 event
.display
= display
;
1621 event
.selection
= selection_atom
;
1622 event
.time
= timestamp
;
1623 x_handle_selection_clear (&event
);
1628 /* Get rid of all the selections in buffer BUFFER.
1629 This is used when we kill a buffer. */
1632 x_disown_buffer_selections (buffer
)
1636 struct buffer
*buf
= XBUFFER (buffer
);
1638 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1640 Lisp_Object elt
, value
;
1641 elt
= XCONS (tail
)->car
;
1642 value
= XCONS (elt
)->cdr
;
1643 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1644 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1645 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1649 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1651 "Whether the current Emacs process owns the given X Selection.\n\
1652 The arg should be the name of the selection in question, typically one of\n\
1653 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1654 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1655 For convenience, the symbol nil is the same as `PRIMARY',\n\
1656 and t is the same as `SECONDARY'.)")
1658 Lisp_Object selection
;
1660 CHECK_SYMBOL (selection
, 0);
1661 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1662 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1664 if (NILP (Fassq (selection
, Vselection_alist
)))
1669 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1671 "Whether there is an owner for the given X Selection.\n\
1672 The arg should be the name of the selection in question, typically one of\n\
1673 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1674 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1675 For convenience, the symbol nil is the same as `PRIMARY',\n\
1676 and t is the same as `SECONDARY'.)")
1678 Lisp_Object selection
;
1682 Display
*dpy
= x_current_display
;
1683 CHECK_SYMBOL (selection
, 0);
1684 if (!NILP (Fx_selection_owner_p (selection
)))
1686 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1687 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1688 atom
= symbol_to_x_atom (dpy
, selection
);
1692 owner
= XGetSelectionOwner (dpy
, atom
);
1694 return (owner
? Qt
: Qnil
);
1698 #ifdef CUT_BUFFER_SUPPORT
1700 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1702 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1704 initialize_cut_buffers (display
, window
)
1708 unsigned char *data
= (unsigned char *) "";
1710 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1711 PropModeAppend, data, 0)
1712 FROB (XA_CUT_BUFFER0
);
1713 FROB (XA_CUT_BUFFER1
);
1714 FROB (XA_CUT_BUFFER2
);
1715 FROB (XA_CUT_BUFFER3
);
1716 FROB (XA_CUT_BUFFER4
);
1717 FROB (XA_CUT_BUFFER5
);
1718 FROB (XA_CUT_BUFFER6
);
1719 FROB (XA_CUT_BUFFER7
);
1722 cut_buffers_initialized
= 1;
1726 #define CHECK_CUT_BUFFER(symbol,n) \
1727 { CHECK_SYMBOL ((symbol), (n)); \
1728 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1729 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1730 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1731 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1733 Fcons (build_string ("doesn't name a cut buffer"), \
1734 Fcons ((symbol), Qnil))); \
1737 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1738 Sx_get_cut_buffer_internal
, 1, 1, 0,
1739 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1743 Display
*display
= x_current_display
;
1744 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1746 unsigned char *data
;
1753 CHECK_CUT_BUFFER (buffer
, 0);
1754 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1756 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1757 &type
, &format
, &size
, 0);
1758 if (!data
) return Qnil
;
1760 if (format
!= 8 || type
!= XA_STRING
)
1762 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1763 Fcons (x_atom_to_symbol (display
, type
),
1764 Fcons (make_number (format
), Qnil
))));
1766 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1772 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1773 Sx_store_cut_buffer_internal
, 2, 2, 0,
1774 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1776 Lisp_Object buffer
, string
;
1778 Display
*display
= x_current_display
;
1779 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1781 unsigned char *data
;
1783 int bytes_remaining
;
1784 int max_bytes
= SELECTION_QUANTUM (display
);
1785 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1787 CHECK_CUT_BUFFER (buffer
, 0);
1788 CHECK_STRING (string
, 0);
1789 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1790 data
= (unsigned char *) XSTRING (string
)->data
;
1791 bytes
= XSTRING (string
)->size
;
1792 bytes_remaining
= bytes
;
1794 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1797 while (bytes_remaining
)
1799 int chunk
= (bytes_remaining
< max_bytes
1800 ? bytes_remaining
: max_bytes
);
1801 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1802 (bytes_remaining
== bytes
1807 bytes_remaining
-= chunk
;
1814 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1815 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1816 "Rotate the values of the cut buffers by the given number of steps;\n\
1817 positive means move values forward, negative means backward.")
1821 Display
*display
= x_current_display
;
1822 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1825 CHECK_NUMBER (n
, 0);
1826 if (XINT (n
) == 0) return n
;
1827 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1828 props
[0] = XA_CUT_BUFFER0
;
1829 props
[1] = XA_CUT_BUFFER1
;
1830 props
[2] = XA_CUT_BUFFER2
;
1831 props
[3] = XA_CUT_BUFFER3
;
1832 props
[4] = XA_CUT_BUFFER4
;
1833 props
[5] = XA_CUT_BUFFER5
;
1834 props
[6] = XA_CUT_BUFFER6
;
1835 props
[7] = XA_CUT_BUFFER7
;
1837 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1845 Xatoms_of_xselect ()
1847 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1850 /* Non-predefined atoms that we might end up using a lot */
1851 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1852 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1853 Xatom_TEXT
= ATOM ("TEXT");
1854 Xatom_DELETE
= ATOM ("DELETE");
1855 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1856 Xatom_INCR
= ATOM ("INCR");
1857 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1858 Xatom_TARGETS
= ATOM ("TARGETS");
1859 Xatom_NULL
= ATOM ("NULL");
1860 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1867 defsubr (&Sx_get_selection_internal
);
1868 defsubr (&Sx_own_selection_internal
);
1869 defsubr (&Sx_disown_selection_internal
);
1870 defsubr (&Sx_selection_owner_p
);
1871 defsubr (&Sx_selection_exists_p
);
1873 #ifdef CUT_BUFFER_SUPPORT
1874 defsubr (&Sx_get_cut_buffer_internal
);
1875 defsubr (&Sx_store_cut_buffer_internal
);
1876 defsubr (&Sx_rotate_cut_buffers_internal
);
1877 cut_buffers_initialized
= 0;
1880 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1881 staticpro (&reading_selection_reply
);
1882 reading_selection_window
= 0;
1883 reading_which_selection
= 0;
1885 property_change_wait_list
= 0;
1886 prop_location_tick
= 0;
1887 property_change_reply
= Fcons (Qnil
, Qnil
);
1888 staticpro (&property_change_reply
);
1890 Vselection_alist
= Qnil
;
1891 staticpro (&Vselection_alist
);
1893 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1894 "An alist associating X Windows selection-types with functions.\n\
1895 These functions are called to convert the selection, with three args:\n\
1896 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1897 a desired type to which the selection should be converted;\n\
1898 and the local selection value (whatever was given to `x-own-selection').\n\
1900 The function should return the value to send to the X server\n\
1901 \(typically a string). A return value of nil\n\
1902 means that the conversion could not be done.\n\
1903 A return value which is the symbol `NULL'\n\
1904 means that a side-effect was executed,\n\
1905 and there is no meaningful selection value.");
1906 Vselection_converter_alist
= Qnil
;
1908 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1909 "A list of functions to be called when Emacs loses an X selection.\n\
1910 \(This happens when some other X client makes its own selection\n\
1911 or when a Lisp program explicitly clears the selection.)\n\
1912 The functions are called with one argument, the selection type\n\
1913 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1914 Vx_lost_selection_hooks
= Qnil
;
1916 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1917 "A list of functions to be called when Emacs answers a selection request.\n\
1918 The functions are called with four arguments:\n\
1919 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1920 - the selection-type which Emacs was asked to convert the\n\
1921 selection into before sending (for example, `STRING' or `LENGTH');\n\
1922 - a flag indicating success or failure for responding to the request.\n\
1923 We might have failed (and declined the request) for any number of reasons,\n\
1924 including being asked for a selection that we no longer own, or being asked\n\
1925 to convert into a type that we don't know about or that is inappropriate.\n\
1926 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
1927 it merely informs you that they have happened.");
1928 Vx_sent_selection_hooks
= Qnil
;
1930 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
1931 "Number of seconds to wait for a selection reply from another X client.\n\
1932 If the selection owner doens't reply in this many seconds, we give up.\n\
1933 A value of 0 means wait as long as necessary. This is initialized from the\n\
1934 \"*selectionTimeout\" resource (which is expressed in milliseconds).");
1935 x_selection_timeout
= 0;
1937 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
1938 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
1939 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
1940 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
1941 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
1942 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1943 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
1944 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1945 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
1946 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
1947 QINCR
= intern ("INCR"); staticpro (&QINCR
);
1948 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
1949 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
1950 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
1951 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
1952 QNULL
= intern ("NULL"); staticpro (&QNULL
);
1954 #ifdef CUT_BUFFER_SUPPORT
1955 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
1956 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
1957 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
1958 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
1959 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
1960 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
1961 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
1962 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);