1 /* X Selection processing for emacs
2 Copyright (C) 1993 Free Software Foundation.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
20 /* x_handle_selection_notify
21 x_reply_selection_request */
24 /* Rewritten by jwz */
29 #include <stdio.h> /* termhooks.h needs this */
30 #include "termhooks.h"
32 #include "xterm.h" /* for all of the X includes */
33 #include "dispextern.h" /* frame.h seems to want this */
34 #include "frame.h" /* Need this to get the X window of selected_frame */
35 #include "blockinput.h"
39 #define CUT_BUFFER_SUPPORT
41 static Atom Xatom_CLIPBOARD
, Xatom_TIMESTAMP
, Xatom_TEXT
, Xatom_DELETE
,
42 Xatom_MULTIPLE
, Xatom_INCR
, Xatom_EMACS_TMP
, Xatom_TARGETS
, Xatom_NULL
,
45 Lisp_Object QPRIMARY
, QSECONDARY
, QSTRING
, QINTEGER
, QCLIPBOARD
, QTIMESTAMP
,
46 QTEXT
, QDELETE
, QMULTIPLE
, QINCR
, QEMACS_TMP
, QTARGETS
, QATOM
, QNULL
,
49 #ifdef CUT_BUFFER_SUPPORT
50 Lisp_Object QCUT_BUFFER0
, QCUT_BUFFER1
, QCUT_BUFFER2
, QCUT_BUFFER3
,
51 QCUT_BUFFER4
, QCUT_BUFFER5
, QCUT_BUFFER6
, QCUT_BUFFER7
;
54 Lisp_Object Vx_lost_selection_hooks
;
55 Lisp_Object Vx_sent_selection_hooks
;
57 /* If this is a smaller number than the max-request-size of the display,
58 emacs will use INCR selection transfer when the selection is larger
59 than this. The max-request-size is usually around 64k, so if you want
60 emacs to use incremental selection transfers when the selection is
61 smaller than that, set this. I added this mostly for debugging the
62 incremental transfer stuff, but it might improve server performance.
64 #define MAX_SELECTION_QUANTUM 0xFFFFFF
67 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
69 #define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
72 /* The timestamp of the last input event Emacs received from the X server. */
73 unsigned long last_event_timestamp
;
75 /* This is an association list whose elements are of the form
76 ( selection-name selection-value selection-timestamp )
77 selection-name is a lisp symbol, whose name is the name of an X Atom.
78 selection-value is the value that emacs owns for that selection.
79 It may be any kind of Lisp object.
80 selection-timestamp is the time at which emacs began owning this selection,
81 as a cons of two 16-bit numbers (making a 32 bit time.)
82 If there is an entry in this alist, then it can be assumed that emacs owns
84 The only (eq) parts of this list that are visible from Lisp are the
87 Lisp_Object Vselection_alist
;
89 /* This is an alist whose CARs are selection-types (whose names are the same
90 as the names of X Atoms) and whose CDRs are the names of Lisp functions to
91 call to convert the given Emacs selection value to a string representing
92 the given selection type. This is for Lisp-level extension of the emacs
95 Lisp_Object Vselection_converter_alist
;
97 /* If the selection owner takes too long to reply to a selection request,
98 we give up on it. This is in milliseconds (0 = no timeout.)
100 int x_selection_timeout
;
103 /* Utility functions */
105 static void lisp_data_to_selection_data ();
106 static Lisp_Object
selection_data_to_lisp_data ();
107 static Lisp_Object
x_get_window_property_as_lisp_data ();
109 /* This converts a Lisp symbol to a server Atom, avoiding a server
110 roundtrip whenever possible. */
113 symbol_to_x_atom (display
, sym
)
118 if (NILP (sym
)) return 0;
119 if (EQ (sym
, QPRIMARY
)) return XA_PRIMARY
;
120 if (EQ (sym
, QSECONDARY
)) return XA_SECONDARY
;
121 if (EQ (sym
, QSTRING
)) return XA_STRING
;
122 if (EQ (sym
, QINTEGER
)) return XA_INTEGER
;
123 if (EQ (sym
, QATOM
)) return XA_ATOM
;
124 if (EQ (sym
, QCLIPBOARD
)) return Xatom_CLIPBOARD
;
125 if (EQ (sym
, QTIMESTAMP
)) return Xatom_TIMESTAMP
;
126 if (EQ (sym
, QTEXT
)) return Xatom_TEXT
;
127 if (EQ (sym
, QDELETE
)) return Xatom_DELETE
;
128 if (EQ (sym
, QMULTIPLE
)) return Xatom_MULTIPLE
;
129 if (EQ (sym
, QINCR
)) return Xatom_INCR
;
130 if (EQ (sym
, QEMACS_TMP
)) return Xatom_EMACS_TMP
;
131 if (EQ (sym
, QTARGETS
)) return Xatom_TARGETS
;
132 if (EQ (sym
, QNULL
)) return Xatom_NULL
;
133 #ifdef CUT_BUFFER_SUPPORT
134 if (EQ (sym
, QCUT_BUFFER0
)) return XA_CUT_BUFFER0
;
135 if (EQ (sym
, QCUT_BUFFER1
)) return XA_CUT_BUFFER1
;
136 if (EQ (sym
, QCUT_BUFFER2
)) return XA_CUT_BUFFER2
;
137 if (EQ (sym
, QCUT_BUFFER3
)) return XA_CUT_BUFFER3
;
138 if (EQ (sym
, QCUT_BUFFER4
)) return XA_CUT_BUFFER4
;
139 if (EQ (sym
, QCUT_BUFFER5
)) return XA_CUT_BUFFER5
;
140 if (EQ (sym
, QCUT_BUFFER6
)) return XA_CUT_BUFFER6
;
141 if (EQ (sym
, QCUT_BUFFER7
)) return XA_CUT_BUFFER7
;
143 if (!SYMBOLP (sym
)) abort ();
146 fprintf (stderr
, " XInternAtom %s\n", (char *) XSYMBOL (sym
)->name
->data
);
149 val
= XInternAtom (display
, (char *) XSYMBOL (sym
)->name
->data
, False
);
155 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
156 and calls to intern whenever possible. */
159 x_atom_to_symbol (display
, atom
)
165 if (! atom
) return Qnil
;
178 #ifdef CUT_BUFFER_SUPPORT
198 if (atom
== Xatom_CLIPBOARD
)
200 if (atom
== Xatom_TIMESTAMP
)
202 if (atom
== Xatom_TEXT
)
204 if (atom
== Xatom_DELETE
)
206 if (atom
== Xatom_MULTIPLE
)
208 if (atom
== Xatom_INCR
)
210 if (atom
== Xatom_EMACS_TMP
)
212 if (atom
== Xatom_TARGETS
)
214 if (atom
== Xatom_NULL
)
218 str
= XGetAtomName (display
, atom
);
221 fprintf (stderr
, " XGetAtomName --> %s\n", str
);
223 if (! str
) return Qnil
;
231 /* Do protocol to assert ourself as a selection owner.
232 Update the Vselection_alist so that we can reply to later requests for
236 x_own_selection (selection_name
, selection_value
)
237 Lisp_Object selection_name
, selection_value
;
239 Display
*display
= x_current_display
;
241 Window selecting_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
243 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
245 Time time
= last_event_timestamp
;
248 CHECK_SYMBOL (selection_name
, 0);
249 selection_atom
= symbol_to_x_atom (display
, selection_name
);
252 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
255 /* Now update the local cache */
257 Lisp_Object selection_time
;
258 Lisp_Object selection_data
;
259 Lisp_Object prev_value
;
261 selection_time
= long_to_cons ((unsigned long) time
);
262 selection_data
= Fcons (selection_name
,
263 Fcons (selection_value
,
264 Fcons (selection_time
, Qnil
)));
265 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
267 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
269 /* If we already owned the selection, remove the old selection data.
270 Perhaps we should destructively modify it instead.
271 Don't use Fdelq as that may QUIT. */
272 if (!NILP (prev_value
))
274 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
275 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
276 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
278 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
285 /* Given a selection-name and desired type, look up our local copy of
286 the selection value and convert it to the type.
287 The value is nil or a string.
288 This function is used both for remote requests
289 and for local x-get-selection-internal.
291 This calls random Lisp code, and may signal or gc. */
294 x_get_local_selection (selection_symbol
, target_type
)
295 Lisp_Object selection_symbol
, target_type
;
297 Lisp_Object local_value
;
298 Lisp_Object handler_fn
, value
, type
, check
;
301 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
303 if (NILP (local_value
)) return Qnil
;
305 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
306 if (EQ (target_type
, QTIMESTAMP
))
309 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
312 else if (EQ (target_type
, QDELETE
))
315 Fx_disown_selection_internal
317 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
322 #if 0 /* #### MULTIPLE doesn't work yet */
323 else if (CONSP (target_type
)
324 && XCONS (target_type
)->car
== QMULTIPLE
)
326 Lisp_Object pairs
= XCONS (target_type
)->cdr
;
327 int size
= XVECTOR (pairs
)->size
;
329 /* If the target is MULTIPLE, then target_type looks like
330 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
331 We modify the second element of each pair in the vector and
332 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
334 for (i
= 0; i
< size
; i
++)
336 Lisp_Object pair
= XVECTOR (pairs
)->contents
[i
];
337 XVECTOR (pair
)->contents
[1]
338 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
339 XVECTOR (pair
)->contents
[1]);
346 /* Don't allow a quit within the converter.
347 When the user types C-g, he would be surprised
348 if by luck it came during a converter. */
349 count
= specpdl_ptr
- specpdl
;
350 specbind (Qinhibit_quit
, Qt
);
352 CHECK_SYMBOL (target_type
, 0);
353 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
354 if (!NILP (handler_fn
))
355 value
= call3 (handler_fn
,
356 selection_symbol
, target_type
,
357 XCONS (XCONS (local_value
)->cdr
)->car
);
360 unbind_to (count
, Qnil
);
363 /* Make sure this value is of a type that we could transmit
364 to another X client. */
368 && SYMBOLP (XCONS (value
)->car
))
369 type
= XCONS (value
)->car
,
370 check
= XCONS (value
)->cdr
;
378 /* Check for a value that cons_to_long could handle. */
379 else if (CONSP (check
)
380 && INTEGERP (XCONS (check
)->car
)
381 && (INTEGERP (XCONS (check
)->cdr
)
383 (CONSP (XCONS (check
)->cdr
)
384 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
385 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
390 Fcons (build_string ("invalid data returned by selection-conversion function"),
391 Fcons (handler_fn
, Fcons (value
, Qnil
))));
394 /* Subroutines of x_reply_selection_request. */
396 /* Send a SelectionNotify event to the requestor with property=None,
397 meaning we were unable to do what they wanted. */
400 x_decline_selection_request (event
)
401 struct input_event
*event
;
403 XSelectionEvent reply
;
404 reply
.type
= SelectionNotify
;
405 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
406 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
407 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
408 reply
.time
= SELECTION_EVENT_TIME (event
);
409 reply
.target
= SELECTION_EVENT_TARGET (event
);
410 reply
.property
= None
;
413 (void) XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
418 /* This is the selection request currently being processed.
419 It is set to zero when the request is fully processed. */
420 static struct input_event
*x_selection_current_request
;
422 /* Used as an unwind-protect clause so that, if a selection-converter signals
423 an error, we tell the requestor that we were unable to do what they wanted
424 before we throw to top-level or go into the debugger or whatever. */
427 x_selection_request_lisp_error (ignore
)
430 if (x_selection_current_request
!= 0)
431 x_decline_selection_request (x_selection_current_request
);
436 /* This stuff is so that INCR selections are reentrant (that is, so we can
437 be servicing multiple INCR selection requests simultaneously.) I haven't
438 actually tested that yet. */
440 /* Keep a list of the property changes that are awaited. */
450 struct prop_location
*next
;
453 static struct prop_location
*expect_property_change ();
454 static void wait_for_property_change ();
455 static void unexpect_property_change ();
456 static int waiting_for_other_props_on_window ();
458 static int prop_location_identifier
;
460 static Lisp_Object property_change_reply
;
462 static struct prop_location
*property_change_reply_object
;
464 static struct prop_location
*property_change_wait_list
;
466 /* Send the reply to a selection request event EVENT.
467 TYPE is the type of selection data requested.
468 DATA and SIZE describe the data to send, already converted.
469 FORMAT is the unit-size (in bits) of the data to be transmitted. */
472 x_reply_selection_request (event
, format
, data
, size
, type
)
473 struct input_event
*event
;
478 XSelectionEvent reply
;
479 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
480 Window window
= SELECTION_EVENT_REQUESTOR (event
);
482 int format_bytes
= format
/8;
483 int max_bytes
= SELECTION_QUANTUM (display
);
485 if (max_bytes
> MAX_SELECTION_QUANTUM
)
486 max_bytes
= MAX_SELECTION_QUANTUM
;
488 reply
.type
= SelectionNotify
;
489 reply
.display
= display
;
490 reply
.requestor
= window
;
491 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
492 reply
.time
= SELECTION_EVENT_TIME (event
);
493 reply
.target
= SELECTION_EVENT_TARGET (event
);
494 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
495 if (reply
.property
== None
)
496 reply
.property
= reply
.target
;
498 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
500 /* Store the data on the requested property.
501 If the selection is large, only store the first N bytes of it.
503 bytes_remaining
= size
* format_bytes
;
504 if (bytes_remaining
<= max_bytes
)
506 /* Send all the data at once, with minimal handshaking. */
508 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
511 XChangeProperty (display
, window
, reply
.property
, type
, format
,
512 PropModeReplace
, data
, size
);
513 /* At this point, the selection was successfully stored; ack it. */
514 XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
520 /* Send an INCR selection. */
521 struct prop_location
*wait_object
;
525 if (x_window_to_frame (window
)) /* #### debug */
526 error ("attempt to transfer an INCR to ourself!");
528 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
530 wait_object
= expect_property_change (display
, window
, reply
.property
,
533 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
534 32, PropModeReplace
, (unsigned char *)
535 &bytes_remaining
, 1);
536 XSelectInput (display
, window
, PropertyChangeMask
);
537 /* Tell 'em the INCR data is there... */
538 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
542 /* First, wait for the requestor to ack by deleting the property.
543 This can run random lisp code (process handlers) or signal. */
544 wait_for_property_change (wait_object
);
546 while (bytes_remaining
)
548 int i
= ((bytes_remaining
< max_bytes
)
555 = expect_property_change (display
, window
, reply
.property
,
558 fprintf (stderr
," INCR adding %d\n", i
);
560 /* Append the next chunk of data to the property. */
561 XChangeProperty (display
, window
, reply
.property
, type
, format
,
562 PropModeAppend
, data
, i
/ format_bytes
);
563 bytes_remaining
-= i
;
568 /* Now wait for the requestor to ack this chunk by deleting the
569 property. This can run random lisp code or signal.
571 wait_for_property_change (wait_object
);
573 /* Now write a zero-length chunk to the property to tell the requestor
576 fprintf (stderr
," INCR done\n");
579 if (! waiting_for_other_props_on_window (display
, window
))
580 XSelectInput (display
, window
, 0L);
582 XChangeProperty (display
, window
, reply
.property
, type
, format
,
583 PropModeReplace
, data
, 0);
589 /* Handle a SelectionRequest event EVENT.
590 This is called from keyboard.c when such an event is found in the queue. */
593 x_handle_selection_request (event
)
594 struct input_event
*event
;
596 struct gcpro gcpro1
, gcpro2
, gcpro3
;
597 Lisp_Object local_selection_data
= Qnil
;
598 Lisp_Object selection_symbol
;
599 Lisp_Object target_symbol
= Qnil
;
600 Lisp_Object converted_selection
= Qnil
;
601 Time local_selection_time
;
602 Lisp_Object successful_p
= Qnil
;
605 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
607 selection_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
608 SELECTION_EVENT_SELECTION (event
));
610 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
612 if (NILP (local_selection_data
))
614 /* Someone asked for the selection, but we don't have it any more.
616 x_decline_selection_request (event
);
620 local_selection_time
= (Time
)
621 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
623 if (SELECTION_EVENT_TIME (event
) != CurrentTime
624 && local_selection_time
> SELECTION_EVENT_TIME (event
))
626 /* Someone asked for the selection, and we have one, but not the one
629 x_decline_selection_request (event
);
633 count
= specpdl_ptr
- specpdl
;
634 x_selection_current_request
= event
;
635 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
637 target_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
638 SELECTION_EVENT_TARGET (event
));
640 #if 0 /* #### MULTIPLE doesn't work yet */
641 if (EQ (target_symbol
, QMULTIPLE
))
642 target_symbol
= fetch_multiple_target (event
);
645 /* Convert lisp objects back into binary data */
648 = x_get_local_selection (selection_symbol
, target_symbol
);
650 if (! NILP (converted_selection
))
658 lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event
),
660 &data
, &type
, &size
, &format
, &nofree
);
662 x_reply_selection_request (event
, format
, data
, size
, type
);
665 /* Indicate we have successfully processed this event. */
666 x_selection_current_request
= 0;
671 unbind_to (count
, Qnil
);
677 /* Let random lisp code notice that the selection has been asked for. */
679 Lisp_Object rest
= Vx_sent_selection_hooks
;
680 if (!EQ (rest
, Qunbound
))
681 for (; CONSP (rest
); rest
= Fcdr (rest
))
682 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
686 /* Handle a SelectionClear event EVENT, which indicates that some other
687 client cleared out our previously asserted selection.
688 This is called from keyboard.c when such an event is found in the queue. */
691 x_handle_selection_clear (event
)
692 struct input_event
*event
;
694 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
695 Atom selection
= SELECTION_EVENT_SELECTION (event
);
696 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
698 Lisp_Object selection_symbol
, local_selection_data
;
699 Time local_selection_time
;
701 selection_symbol
= x_atom_to_symbol (display
, selection
);
703 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
705 /* Well, we already believe that we don't own it, so that's just fine. */
706 if (NILP (local_selection_data
)) return;
708 local_selection_time
= (Time
)
709 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
711 /* This SelectionClear is for a selection that we no longer own, so we can
712 disregard it. (That is, we have reasserted the selection since this
713 request was generated.) */
715 if (changed_owner_time
!= CurrentTime
716 && local_selection_time
> changed_owner_time
)
719 /* Otherwise, we're really honest and truly being told to drop it.
720 Don't use Fdelq as that may QUIT;. */
722 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
723 Vselection_alist
= Fcdr (Vselection_alist
);
727 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
728 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
730 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
735 /* Let random lisp code notice that the selection has been stolen. */
739 rest
= Vx_lost_selection_hooks
;
740 if (!EQ (rest
, Qunbound
))
742 for (; CONSP (rest
); rest
= Fcdr (rest
))
743 call1 (Fcar (rest
), selection_symbol
);
744 redisplay_preserve_echo_area ();
750 /* Nonzero if any properties for DISPLAY and WINDOW
751 are on the list of what we are waiting for. */
754 waiting_for_other_props_on_window (display
, window
)
758 struct prop_location
*rest
= property_change_wait_list
;
760 if (rest
->display
== display
&& rest
->window
== window
)
767 /* Add an entry to the list of property changes we are waiting for.
768 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
769 The return value is a number that uniquely identifies
770 this awaited property change. */
772 static struct prop_location
*
773 expect_property_change (display
, window
, property
, state
)
776 Lisp_Object property
;
779 struct prop_location
*pl
780 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
781 pl
->identifier
= ++prop_location_identifier
;
782 pl
->display
= display
;
784 pl
->property
= property
;
785 pl
->desired_state
= state
;
786 pl
->next
= property_change_wait_list
;
788 property_change_wait_list
= pl
;
792 /* Delete an entry from the list of property changes we are waiting for.
793 IDENTIFIER is the number that uniquely identifies the entry. */
796 unexpect_property_change (location
)
797 struct prop_location
*location
;
799 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
802 if (rest
== location
)
805 prev
->next
= rest
->next
;
807 property_change_wait_list
= rest
->next
;
816 /* Remove the property change expectation element for IDENTIFIER. */
819 wait_for_property_change_unwind (identifierval
)
820 Lisp_Object identifierval
;
822 unexpect_property_change (XPNTR (identifierval
));
825 /* Actually wait for a property change.
826 IDENTIFIER should be the value that expect_property_change returned. */
829 wait_for_property_change (location
)
830 struct prop_location
*location
;
833 int count
= specpdl_ptr
- specpdl
;
836 XSET (tem
, Lisp_Cons
, location
);
838 /* Make sure to do unexpect_property_change if we quit or err. */
839 record_unwind_protect (wait_for_property_change_unwind
, tem
);
841 XCONS (property_change_reply
)->car
= Qnil
;
843 if (! location
->arrived
)
845 property_change_reply_object
= location
;
846 secs
= x_selection_timeout
/ 1000;
847 usecs
= (x_selection_timeout
% 1000) * 1000;
848 wait_reading_process_input (secs
, usecs
, property_change_reply
, 0);
850 if (NILP (XCONS (property_change_reply
)->car
))
851 error ("timed out waiting for property-notify event");
854 unbind_to (count
, Qnil
);
857 /* Called from XTread_socket in response to a PropertyNotify event. */
860 x_handle_property_notify (event
)
861 XPropertyEvent
*event
;
863 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
866 if (rest
->property
== event
->atom
867 && rest
->window
== event
->window
868 && rest
->display
== event
->display
869 && rest
->desired_state
== event
->state
)
872 fprintf (stderr
, "Saw expected prop-%s on %s\n",
873 (event
->state
== PropertyDelete
? "delete" : "change"),
874 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
881 /* If this is the one wait_for_property_change is waiting for,
882 tell it to wake up. */
883 if (rest
== property_change_reply_object
)
884 XCONS (property_change_reply
)->car
= Qt
;
887 prev
->next
= rest
->next
;
889 property_change_wait_list
= rest
->next
;
897 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
898 (event
->state
== PropertyDelete
? "delete" : "change"),
899 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
906 #if 0 /* #### MULTIPLE doesn't work yet */
909 fetch_multiple_target (event
)
910 XSelectionRequestEvent
*event
;
912 Display
*display
= event
->display
;
913 Window window
= event
->requestor
;
914 Atom target
= event
->target
;
915 Atom selection_atom
= event
->selection
;
920 x_get_window_property_as_lisp_data (display
, window
, target
,
921 QMULTIPLE
, selection_atom
));
925 copy_multiple_data (obj
)
932 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
934 CHECK_VECTOR (obj
, 0);
935 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
936 for (i
= 0; i
< size
; i
++)
938 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
939 CHECK_VECTOR (vec2
, 0);
940 if (XVECTOR (vec2
)->size
!= 2)
941 /* ??? Confusing error message */
942 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
943 Fcons (vec2
, Qnil
)));
944 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
945 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
946 = XVECTOR (vec2
)->contents
[0];
947 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
948 = XVECTOR (vec2
)->contents
[1];
956 /* Variables for communication with x_handle_selection_notify. */
957 static Atom reading_which_selection
;
958 static Lisp_Object reading_selection_reply
;
959 static Window reading_selection_window
;
961 /* Do protocol to read selection-data from the server.
962 Converts this to Lisp data and returns it. */
965 x_get_foreign_selection (selection_symbol
, target_type
)
966 Lisp_Object selection_symbol
, target_type
;
968 Display
*display
= x_current_display
;
970 Window requestor_window
= XtWindow (selected_screen
->display
.x
->edit_widget
);
972 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
974 Time requestor_time
= last_event_timestamp
;
975 Atom target_property
= Xatom_EMACS_TMP
;
976 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
980 if (CONSP (target_type
))
981 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
983 type_atom
= symbol_to_x_atom (display
, target_type
);
986 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
987 requestor_window
, requestor_time
);
990 /* Prepare to block until the reply has been read. */
991 reading_selection_window
= requestor_window
;
992 reading_which_selection
= selection_atom
;
993 XCONS (reading_selection_reply
)->car
= Qnil
;
996 /* This allows quits. Also, don't wait forever. */
997 secs
= x_selection_timeout
/ 1000;
998 usecs
= (x_selection_timeout
% 1000) * 1000;
999 wait_reading_process_input (secs
, usecs
, reading_selection_reply
, 0);
1001 if (NILP (XCONS (reading_selection_reply
)->car
))
1002 error ("timed out waiting for reply from selection owner");
1004 /* Otherwise, the selection is waiting for us on the requested property. */
1006 x_get_window_property_as_lisp_data (display
, requestor_window
,
1007 target_property
, target_type
,
1011 /* Subroutines of x_get_window_property_as_lisp_data */
1014 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
1015 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1020 unsigned char **data_ret
;
1022 Atom
*actual_type_ret
;
1023 int *actual_format_ret
;
1024 unsigned long *actual_size_ret
;
1028 unsigned long bytes_remaining
;
1030 unsigned char *tmp_data
= 0;
1032 int buffer_size
= SELECTION_QUANTUM (display
);
1033 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1036 /* First probe the thing to find out how big it is. */
1037 result
= XGetWindowProperty (display
, window
, property
,
1038 0, 0, False
, AnyPropertyType
,
1039 actual_type_ret
, actual_format_ret
,
1041 &bytes_remaining
, &tmp_data
);
1042 if (result
!= Success
)
1049 xfree ((char *) tmp_data
);
1051 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1057 total_size
= bytes_remaining
+ 1;
1058 *data_ret
= (unsigned char *) xmalloc (total_size
);
1060 /* Now read, until weve gotten it all. */
1061 while (bytes_remaining
)
1064 int last
= bytes_remaining
;
1067 = XGetWindowProperty (display
, window
, property
,
1068 offset
/4, buffer_size
/4,
1071 actual_type_ret
, actual_format_ret
,
1072 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1074 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1076 /* If this doesn't return Success at this point, it means that
1077 some clod deleted the selection while we were in the midst of
1078 reading it. Deal with that, I guess....
1080 if (result
!= Success
) break;
1081 *actual_size_ret
*= *actual_format_ret
/ 8;
1082 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1083 offset
+= *actual_size_ret
;
1084 xfree ((char *) tmp_data
);
1089 *bytes_ret
= offset
;
1093 receive_incremental_selection (display
, window
, property
, target_type
,
1094 min_size_bytes
, data_ret
, size_bytes_ret
,
1095 type_ret
, format_ret
, size_ret
)
1099 Lisp_Object target_type
; /* for error messages only */
1100 unsigned int min_size_bytes
;
1101 unsigned char **data_ret
;
1102 int *size_bytes_ret
;
1104 unsigned long *size_ret
;
1108 struct prop_location
*wait_object
;
1109 *size_bytes_ret
= min_size_bytes
;
1110 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1112 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1115 /* At this point, we have read an INCR property.
1116 Delete the property to ack it.
1117 (But first, prepare to receive the next event in this handshake.)
1119 Now, we must loop, waiting for the sending window to put a value on
1120 that property, then reading the property, then deleting it to ack.
1121 We are done when the sender places a property of length 0.
1124 XSelectInput (display
, window
, STANDARD_EVENT_SET
| PropertyChangeMask
);
1125 XDeleteProperty (display
, window
, property
);
1126 wait_object
= expect_property_change (display
, window
, property
,
1133 unsigned char *tmp_data
;
1135 wait_for_property_change (wait_object
);
1136 /* expect it again immediately, because x_get_window_property may
1137 .. no it wont, I dont get it.
1138 .. Ok, I get it now, the Xt code that implements INCR is broken.
1140 x_get_window_property (display
, window
, property
,
1141 &tmp_data
, &tmp_size_bytes
,
1142 type_ret
, format_ret
, size_ret
, 1);
1144 if (tmp_size_bytes
== 0) /* we're done */
1147 fprintf (stderr
, " read INCR done\n");
1149 if (! waiting_for_other_props_on_window (display
, window
))
1150 XSelectInput (display
, window
, STANDARD_EVENT_SET
);
1151 unexpect_property_change (wait_object
);
1152 if (tmp_data
) xfree (tmp_data
);
1157 XDeleteProperty (display
, window
, property
);
1158 wait_object
= expect_property_change (display
, window
, property
,
1164 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1166 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1169 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1170 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1172 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1173 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1175 bcopy (tmp_data
, (*data_ret
) + offset
, tmp_size_bytes
);
1176 offset
+= tmp_size_bytes
;
1181 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1182 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1183 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1186 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1191 Lisp_Object target_type
; /* for error messages only */
1192 Atom selection_atom
; /* for error messages only */
1196 unsigned long actual_size
;
1197 unsigned char *data
= 0;
1201 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1202 &actual_type
, &actual_format
, &actual_size
, 1);
1205 int there_is_a_selection_owner
;
1207 there_is_a_selection_owner
1208 = XGetSelectionOwner (display
, selection_atom
);
1210 while (1) /* Note debugger can no longer return, so this is obsolete */
1212 there_is_a_selection_owner
?
1213 Fcons (build_string ("selection owner couldn't convert"),
1215 ? Fcons (target_type
,
1216 Fcons (x_atom_to_symbol (display
, actual_type
),
1218 : Fcons (target_type
, Qnil
))
1219 : Fcons (build_string ("no selection"),
1220 Fcons (x_atom_to_symbol (display
, selection_atom
),
1224 if (actual_type
== Xatom_INCR
)
1226 /* That wasn't really the data, just the beginning. */
1228 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1230 XFree ((char *) data
);
1232 receive_incremental_selection (display
, window
, property
, target_type
,
1233 min_size_bytes
, &data
, &bytes
,
1234 &actual_type
, &actual_format
,
1239 XDeleteProperty (display
, window
, property
);
1243 /* It's been read. Now convert it to a lisp object in some semi-rational
1245 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1246 actual_type
, actual_format
);
1248 xfree ((char *) data
);
1252 /* These functions convert from the selection data read from the server into
1253 something that we can use from Lisp, and vice versa.
1255 Type: Format: Size: Lisp Type:
1256 ----- ------- ----- -----------
1259 ATOM 32 > 1 Vector of Symbols
1261 * 16 > 1 Vector of Integers
1262 * 32 1 if <=16 bits: Integer
1263 if > 16 bits: Cons of top16, bot16
1264 * 32 > 1 Vector of the above
1266 When converting a Lisp number to C, it is assumed to be of format 16 if
1267 it is an integer, and of format 32 if it is a cons of two integers.
1269 When converting a vector of numbers from Lisp to C, it is assumed to be
1270 of format 16 if every element in the vector is an integer, and is assumed
1271 to be of format 32 if any element is a cons of two integers.
1273 When converting an object to C, it may be of the form (SYMBOL . <data>)
1274 where SYMBOL is what we should claim that the type is. Format and
1275 representation are as above. */
1280 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1282 unsigned char *data
;
1287 if (type
== Xatom_NULL
)
1290 /* Convert any 8-bit data to a string, for compactness. */
1291 else if (format
== 8)
1292 return make_string ((char *) data
, size
);
1294 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1295 a vector of symbols.
1297 else if (type
== XA_ATOM
)
1300 if (size
== sizeof (Atom
))
1301 return x_atom_to_symbol (display
, *((Atom
*) data
));
1304 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1305 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1306 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1311 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1312 If the number is > 16 bits, convert it to a cons of integers,
1313 16 bits in each half.
1315 else if (format
== 32 && size
== sizeof (long))
1316 return long_to_cons (((unsigned long *) data
) [0]);
1317 else if (format
== 16 && size
== sizeof (short))
1318 return make_number ((int) (((unsigned short *) data
) [0]));
1320 /* Convert any other kind of data to a vector of numbers, represented
1321 as above (as an integer, or a cons of two 16 bit integers.)
1323 else if (format
== 16)
1326 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1327 for (i
= 0; i
< size
/ 4; i
++)
1329 int j
= (int) ((unsigned short *) data
) [i
];
1330 Faset (v
, i
, make_number (j
));
1337 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1338 for (i
= 0; i
< size
/ 4; i
++)
1340 unsigned long j
= ((unsigned long *) data
) [i
];
1341 Faset (v
, i
, long_to_cons (j
));
1349 lisp_data_to_selection_data (display
, obj
,
1350 data_ret
, type_ret
, size_ret
,
1351 format_ret
, nofree_ret
)
1354 unsigned char **data_ret
;
1356 unsigned int *size_ret
;
1360 Lisp_Object type
= Qnil
;
1364 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1366 type
= XCONS (obj
)->car
;
1367 obj
= XCONS (obj
)->cdr
;
1368 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1369 obj
= XCONS (obj
)->car
;
1372 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1373 { /* This is not the same as declining */
1379 else if (STRINGP (obj
))
1382 *size_ret
= XSTRING (obj
)->size
;
1383 *data_ret
= XSTRING (obj
)->data
;
1385 if (NILP (type
)) type
= QSTRING
;
1387 else if (SYMBOLP (obj
))
1391 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1392 (*data_ret
) [sizeof (Atom
)] = 0;
1393 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1394 if (NILP (type
)) type
= QATOM
;
1396 else if (INTEGERP (obj
)
1397 && XINT (obj
) < 0xFFFF
1398 && XINT (obj
) > -0xFFFF)
1402 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1403 (*data_ret
) [sizeof (short)] = 0;
1404 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1405 if (NILP (type
)) type
= QINTEGER
;
1407 else if (INTEGERP (obj
)
1408 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1409 && (INTEGERP (XCONS (obj
)->cdr
)
1410 || (CONSP (XCONS (obj
)->cdr
)
1411 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1415 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1416 (*data_ret
) [sizeof (long)] = 0;
1417 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1418 if (NILP (type
)) type
= QINTEGER
;
1420 else if (VECTORP (obj
))
1422 /* Lisp_Vectors may represent a set of ATOMs;
1423 a set of 16 or 32 bit INTEGERs;
1424 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1428 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1429 /* This vector is an ATOM set */
1431 if (NILP (type
)) type
= QATOM
;
1432 *size_ret
= XVECTOR (obj
)->size
;
1434 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1435 for (i
= 0; i
< *size_ret
; i
++)
1436 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1437 (*(Atom
**) data_ret
) [i
]
1438 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1440 Fsignal (Qerror
, /* Qselection_error */
1442 ("all elements of selection vector must have same type"),
1443 Fcons (obj
, Qnil
)));
1445 #if 0 /* #### MULTIPLE doesn't work yet */
1446 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1447 /* This vector is an ATOM_PAIR set */
1449 if (NILP (type
)) type
= QATOM_PAIR
;
1450 *size_ret
= XVECTOR (obj
)->size
;
1452 *data_ret
= (unsigned char *)
1453 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1454 for (i
= 0; i
< *size_ret
; i
++)
1455 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1457 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1458 if (XVECTOR (pair
)->size
!= 2)
1461 ("elements of the vector must be vectors of exactly two elements"),
1462 Fcons (pair
, Qnil
)));
1464 (*(Atom
**) data_ret
) [i
* 2]
1465 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1466 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1467 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1472 ("all elements of the vector must be of the same type"),
1473 Fcons (obj
, Qnil
)));
1478 /* This vector is an INTEGER set, or something like it */
1480 *size_ret
= XVECTOR (obj
)->size
;
1481 if (NILP (type
)) type
= QINTEGER
;
1483 for (i
= 0; i
< *size_ret
; i
++)
1484 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1486 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1487 Fsignal (Qerror
, /* Qselection_error */
1489 ("elements of selection vector must be integers or conses of integers"),
1490 Fcons (obj
, Qnil
)));
1492 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1493 for (i
= 0; i
< *size_ret
; i
++)
1494 if (*format_ret
== 32)
1495 (*((unsigned long **) data_ret
)) [i
]
1496 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1498 (*((unsigned short **) data_ret
)) [i
]
1499 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1503 Fsignal (Qerror
, /* Qselection_error */
1504 Fcons (build_string ("unrecognised selection data"),
1505 Fcons (obj
, Qnil
)));
1507 *type_ret
= symbol_to_x_atom (display
, type
);
1511 clean_local_selection_data (obj
)
1515 && INTEGERP (XCONS (obj
)->car
)
1516 && CONSP (XCONS (obj
)->cdr
)
1517 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1518 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1519 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1522 && INTEGERP (XCONS (obj
)->car
)
1523 && INTEGERP (XCONS (obj
)->cdr
))
1525 if (XINT (XCONS (obj
)->car
) == 0)
1526 return XCONS (obj
)->cdr
;
1527 if (XINT (XCONS (obj
)->car
) == -1)
1528 return make_number (- XINT (XCONS (obj
)->cdr
));
1533 int size
= XVECTOR (obj
)->size
;
1536 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1537 copy
= Fmake_vector (size
, Qnil
);
1538 for (i
= 0; i
< size
; i
++)
1539 XVECTOR (copy
)->contents
[i
]
1540 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1546 /* Called from XTread_socket to handle SelectionNotify events.
1547 If it's the selection we are waiting for, stop waiting. */
1550 x_handle_selection_notify (event
)
1551 XSelectionEvent
*event
;
1553 if (event
->requestor
!= reading_selection_window
)
1555 if (event
->selection
!= reading_which_selection
)
1558 XCONS (reading_selection_reply
)->car
= Qt
;
1562 DEFUN ("x-own-selection-internal",
1563 Fx_own_selection_internal
, Sx_own_selection_internal
,
1565 "Assert an X selection of the given TYPE with the given VALUE.\n\
1566 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1567 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1568 VALUE is typically a string, or a cons of two markers, but may be\n\
1569 anything that the functions on `selection-converter-alist' know about.")
1570 (selection_name
, selection_value
)
1571 Lisp_Object selection_name
, selection_value
;
1573 CHECK_SYMBOL (selection_name
, 0);
1574 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1575 x_own_selection (selection_name
, selection_value
);
1576 return selection_value
;
1580 /* Request the selection value from the owner. If we are the owner,
1581 simply return our selection value. If we are not the owner, this
1582 will block until all of the data has arrived. */
1584 DEFUN ("x-get-selection-internal",
1585 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1586 "Return text selected from some X window.\n\
1587 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1588 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1589 TYPE is the type of data desired, typically `STRING'.")
1590 (selection_symbol
, target_type
)
1591 Lisp_Object selection_symbol
, target_type
;
1593 Lisp_Object val
= Qnil
;
1594 struct gcpro gcpro1
, gcpro2
;
1595 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1596 CHECK_SYMBOL (selection_symbol
, 0);
1598 #if 0 /* #### MULTIPLE doesn't work yet */
1599 if (CONSP (target_type
)
1600 && XCONS (target_type
)->car
== QMULTIPLE
)
1602 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1603 /* So we don't destructively modify this... */
1604 target_type
= copy_multiple_data (target_type
);
1608 CHECK_SYMBOL (target_type
, 0);
1610 val
= x_get_local_selection (selection_symbol
, target_type
);
1614 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1619 && SYMBOLP (XCONS (val
)->car
))
1621 val
= XCONS (val
)->cdr
;
1622 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1623 val
= XCONS (val
)->car
;
1625 val
= clean_local_selection_data (val
);
1631 DEFUN ("x-disown-selection-internal",
1632 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1633 "If we own the selection SELECTION, disown it.\n\
1634 Disowning it means there is no such selection.")
1636 Lisp_Object selection
;
1639 Display
*display
= x_current_display
;
1641 Atom selection_atom
;
1642 XSelectionClearEvent event
;
1644 CHECK_SYMBOL (selection
, 0);
1646 timestamp
= last_event_timestamp
;
1648 timestamp
= cons_to_long (time
);
1650 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1651 return Qnil
; /* Don't disown the selection when we're not the owner. */
1653 selection_atom
= symbol_to_x_atom (display
, selection
);
1656 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1659 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1660 generated for a window which owns the selection when that window sets
1661 the selection owner to None. The NCD server does, the MIT Sun4 server
1662 doesn't. So we synthesize one; this means we might get two, but
1663 that's ok, because the second one won't have any effect. */
1664 SELECTION_EVENT_DISPLAY (&event
) = display
;
1665 SELECTION_EVENT_SELECTION (&event
) = selection_atom
;
1666 SELECTION_EVENT_TIME (&event
) = timestamp
;
1667 x_handle_selection_clear (&event
);
1672 /* Get rid of all the selections in buffer BUFFER.
1673 This is used when we kill a buffer. */
1676 x_disown_buffer_selections (buffer
)
1680 struct buffer
*buf
= XBUFFER (buffer
);
1682 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1684 Lisp_Object elt
, value
;
1685 elt
= XCONS (tail
)->car
;
1686 value
= XCONS (elt
)->cdr
;
1687 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1688 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1689 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1693 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1695 "Whether the current Emacs process owns the given X Selection.\n\
1696 The arg should be the name of the selection in question, typically one of\n\
1697 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1698 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1699 For convenience, the symbol nil is the same as `PRIMARY',\n\
1700 and t is the same as `SECONDARY'.)")
1702 Lisp_Object selection
;
1704 CHECK_SYMBOL (selection
, 0);
1705 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1706 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1708 if (NILP (Fassq (selection
, Vselection_alist
)))
1713 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1715 "Whether there is an owner for the given X Selection.\n\
1716 The arg should be the name of the selection in question, typically one of\n\
1717 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1718 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1719 For convenience, the symbol nil is the same as `PRIMARY',\n\
1720 and t is the same as `SECONDARY'.)")
1722 Lisp_Object selection
;
1726 Display
*dpy
= x_current_display
;
1727 CHECK_SYMBOL (selection
, 0);
1728 if (!NILP (Fx_selection_owner_p (selection
)))
1730 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1731 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1732 atom
= symbol_to_x_atom (dpy
, selection
);
1736 owner
= XGetSelectionOwner (dpy
, atom
);
1738 return (owner
? Qt
: Qnil
);
1742 #ifdef CUT_BUFFER_SUPPORT
1744 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1746 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1748 initialize_cut_buffers (display
, window
)
1752 unsigned char *data
= (unsigned char *) "";
1754 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1755 PropModeAppend, data, 0)
1756 FROB (XA_CUT_BUFFER0
);
1757 FROB (XA_CUT_BUFFER1
);
1758 FROB (XA_CUT_BUFFER2
);
1759 FROB (XA_CUT_BUFFER3
);
1760 FROB (XA_CUT_BUFFER4
);
1761 FROB (XA_CUT_BUFFER5
);
1762 FROB (XA_CUT_BUFFER6
);
1763 FROB (XA_CUT_BUFFER7
);
1766 cut_buffers_initialized
= 1;
1770 #define CHECK_CUT_BUFFER(symbol,n) \
1771 { CHECK_SYMBOL ((symbol), (n)); \
1772 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1773 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1774 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1775 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1777 Fcons (build_string ("doesn't name a cut buffer"), \
1778 Fcons ((symbol), Qnil))); \
1781 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1782 Sx_get_cut_buffer_internal
, 1, 1, 0,
1783 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1787 Display
*display
= x_current_display
;
1788 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1790 unsigned char *data
;
1797 CHECK_CUT_BUFFER (buffer
, 0);
1798 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1800 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1801 &type
, &format
, &size
, 0);
1802 if (!data
) return Qnil
;
1804 if (format
!= 8 || type
!= XA_STRING
)
1806 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1807 Fcons (x_atom_to_symbol (display
, type
),
1808 Fcons (make_number (format
), Qnil
))));
1810 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1816 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1817 Sx_store_cut_buffer_internal
, 2, 2, 0,
1818 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1820 Lisp_Object buffer
, string
;
1822 Display
*display
= x_current_display
;
1823 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1825 unsigned char *data
;
1827 int bytes_remaining
;
1828 int max_bytes
= SELECTION_QUANTUM (display
);
1829 if (max_bytes
> MAX_SELECTION_QUANTUM
) max_bytes
= MAX_SELECTION_QUANTUM
;
1831 CHECK_CUT_BUFFER (buffer
, 0);
1832 CHECK_STRING (string
, 0);
1833 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1834 data
= (unsigned char *) XSTRING (string
)->data
;
1835 bytes
= XSTRING (string
)->size
;
1836 bytes_remaining
= bytes
;
1838 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1842 /* Don't mess up with an empty value. */
1843 if (!bytes_remaining
)
1844 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1845 PropModeReplace
, data
, 0);
1847 while (bytes_remaining
)
1849 int chunk
= (bytes_remaining
< max_bytes
1850 ? bytes_remaining
: max_bytes
);
1851 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1852 (bytes_remaining
== bytes
1857 bytes_remaining
-= chunk
;
1864 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1865 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1866 "Rotate the values of the cut buffers by the given number of steps;\n\
1867 positive means move values forward, negative means backward.")
1871 Display
*display
= x_current_display
;
1872 Window window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1875 CHECK_NUMBER (n
, 0);
1876 if (XINT (n
) == 0) return n
;
1877 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1878 props
[0] = XA_CUT_BUFFER0
;
1879 props
[1] = XA_CUT_BUFFER1
;
1880 props
[2] = XA_CUT_BUFFER2
;
1881 props
[3] = XA_CUT_BUFFER3
;
1882 props
[4] = XA_CUT_BUFFER4
;
1883 props
[5] = XA_CUT_BUFFER5
;
1884 props
[6] = XA_CUT_BUFFER6
;
1885 props
[7] = XA_CUT_BUFFER7
;
1887 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1895 Xatoms_of_xselect ()
1897 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1900 /* Non-predefined atoms that we might end up using a lot */
1901 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1902 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1903 Xatom_TEXT
= ATOM ("TEXT");
1904 Xatom_DELETE
= ATOM ("DELETE");
1905 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1906 Xatom_INCR
= ATOM ("INCR");
1907 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
1908 Xatom_TARGETS
= ATOM ("TARGETS");
1909 Xatom_NULL
= ATOM ("NULL");
1910 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
1917 defsubr (&Sx_get_selection_internal
);
1918 defsubr (&Sx_own_selection_internal
);
1919 defsubr (&Sx_disown_selection_internal
);
1920 defsubr (&Sx_selection_owner_p
);
1921 defsubr (&Sx_selection_exists_p
);
1923 #ifdef CUT_BUFFER_SUPPORT
1924 defsubr (&Sx_get_cut_buffer_internal
);
1925 defsubr (&Sx_store_cut_buffer_internal
);
1926 defsubr (&Sx_rotate_cut_buffers_internal
);
1927 cut_buffers_initialized
= 0;
1930 reading_selection_reply
= Fcons (Qnil
, Qnil
);
1931 staticpro (&reading_selection_reply
);
1932 reading_selection_window
= 0;
1933 reading_which_selection
= 0;
1935 property_change_wait_list
= 0;
1936 prop_location_identifier
= 0;
1937 property_change_reply
= Fcons (Qnil
, Qnil
);
1938 staticpro (&property_change_reply
);
1940 Vselection_alist
= Qnil
;
1941 staticpro (&Vselection_alist
);
1943 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
1944 "An alist associating X Windows selection-types with functions.\n\
1945 These functions are called to convert the selection, with three args:\n\
1946 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1947 a desired type to which the selection should be converted;\n\
1948 and the local selection value (whatever was given to `x-own-selection').\n\
1950 The function should return the value to send to the X server\n\
1951 \(typically a string). A return value of nil\n\
1952 means that the conversion could not be done.\n\
1953 A return value which is the symbol `NULL'\n\
1954 means that a side-effect was executed,\n\
1955 and there is no meaningful selection value.");
1956 Vselection_converter_alist
= Qnil
;
1958 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
1959 "A list of functions to be called when Emacs loses an X selection.\n\
1960 \(This happens when some other X client makes its own selection\n\
1961 or when a Lisp program explicitly clears the selection.)\n\
1962 The functions are called with one argument, the selection type\n\
1963 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
1964 Vx_lost_selection_hooks
= Qnil
;
1966 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
1967 "A list of functions to be called when Emacs answers a selection request.\n\
1968 The functions are called with four arguments:\n\
1969 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
1970 - the selection-type which Emacs was asked to convert the\n\
1971 selection into before sending (for example, `STRING' or `LENGTH');\n\
1972 - a flag indicating success or failure for responding to the request.\n\
1973 We might have failed (and declined the request) for any number of reasons,\n\
1974 including being asked for a selection that we no longer own, or being asked\n\
1975 to convert into a type that we don't know about or that is inappropriate.\n\
1976 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
1977 it merely informs you that they have happened.");
1978 Vx_sent_selection_hooks
= Qnil
;
1980 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
1981 "Number of milliseconds to wait for a selection reply.\n\
1982 If the selection owner doens't reply in this time, we give up.\n\
1983 A value of 0 means wait as long as necessary. This is initialized from the\n\
1984 \"*selectionTimeout\" resource.");
1985 x_selection_timeout
= 0;
1987 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
1988 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
1989 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
1990 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
1991 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
1992 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1993 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
1994 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
1995 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
1996 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
1997 QINCR
= intern ("INCR"); staticpro (&QINCR
);
1998 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
1999 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
2000 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
2001 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
2002 QNULL
= intern ("NULL"); staticpro (&QNULL
);
2004 #ifdef CUT_BUFFER_SUPPORT
2005 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
2006 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
2007 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
2008 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
2009 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
2010 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
2011 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
2012 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);