1 /* X Selection processing for Emacs.
2 Copyright (C) 1993, 1994 Free Software Foundation.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
20 /* x_handle_selection_notify
21 x_reply_selection_request */
24 /* Rewritten by jwz */
29 #include <stdio.h> /* termhooks.h needs this */
30 #include "termhooks.h"
32 #include "xterm.h" /* for all of the X includes */
33 #include "dispextern.h" /* frame.h seems to want this */
34 #include "frame.h" /* Need this to get the X window of selected_frame */
35 #include "blockinput.h"
39 #define CUT_BUFFER_SUPPORT
41 static Atom Xatom_CLIPBOARD
, Xatom_TIMESTAMP
, Xatom_TEXT
, Xatom_DELETE
,
42 Xatom_MULTIPLE
, Xatom_INCR
, Xatom_EMACS_TMP
, Xatom_TARGETS
, Xatom_NULL
,
45 Lisp_Object QPRIMARY
, QSECONDARY
, QSTRING
, QINTEGER
, QCLIPBOARD
, QTIMESTAMP
,
46 QTEXT
, QDELETE
, QMULTIPLE
, QINCR
, QEMACS_TMP
, QTARGETS
, QATOM
, QNULL
,
49 #ifdef CUT_BUFFER_SUPPORT
50 Lisp_Object QCUT_BUFFER0
, QCUT_BUFFER1
, QCUT_BUFFER2
, QCUT_BUFFER3
,
51 QCUT_BUFFER4
, QCUT_BUFFER5
, QCUT_BUFFER6
, QCUT_BUFFER7
;
54 Lisp_Object Vx_lost_selection_hooks
;
55 Lisp_Object Vx_sent_selection_hooks
;
57 /* If this is a smaller number than the max-request-size of the display,
58 emacs will use INCR selection transfer when the selection is larger
59 than this. The max-request-size is usually around 64k, so if you want
60 emacs to use incremental selection transfers when the selection is
61 smaller than that, set this. I added this mostly for debugging the
62 incremental transfer stuff, but it might improve server performance.
64 #define MAX_SELECTION_QUANTUM 0xFFFFFF
67 #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize(dpy) << 2) - 100)
69 #define SELECTION_QUANTUM(dpy) (((dpy)->max_request_size << 2) - 100)
72 /* The timestamp of the last input event Emacs received from the X server. */
73 unsigned long last_event_timestamp
;
75 /* This is an association list whose elements are of the form
76 ( SELECTION-NAME SELECTION-VALUE SELECTION-TIMESTAMP FRAME)
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 FRAME is the frame for which we made the selection.
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 milliseconds (0 = no timeout.)
101 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 Window selecting_window
= FRAME_X_WINDOW (selected_frame
);
240 Display
*display
= FRAME_X_DISPLAY (selected_frame
);
241 Time time
= last_event_timestamp
;
244 CHECK_SYMBOL (selection_name
, 0);
245 selection_atom
= symbol_to_x_atom (display
, selection_name
);
248 x_catch_errors (selected_frame
);
249 XSetSelectionOwner (display
, selection_atom
, selecting_window
, time
);
250 x_check_errors (selected_frame
, "Can't set selection: %s");
251 x_uncatch_errors (selected_frame
);
254 /* Now update the local cache */
256 Lisp_Object selection_time
;
257 Lisp_Object selection_data
;
258 Lisp_Object prev_value
;
260 selection_time
= long_to_cons ((unsigned long) time
);
261 selection_data
= Fcons (selection_name
,
262 Fcons (selection_value
,
263 Fcons (selection_time
,
264 Fcons (Fselected_frame (), Qnil
))));
265 prev_value
= assq_no_quit (selection_name
, Vselection_alist
);
267 Vselection_alist
= Fcons (selection_data
, Vselection_alist
);
269 /* If we already owned the selection, remove the old selection data.
270 Perhaps we should destructively modify it instead.
271 Don't use Fdelq as that may QUIT. */
272 if (!NILP (prev_value
))
274 Lisp_Object rest
; /* we know it's not the CAR, so it's easy. */
275 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
276 if (EQ (prev_value
, Fcar (XCONS (rest
)->cdr
)))
278 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
285 /* Given a selection-name and desired type, look up our local copy of
286 the selection value and convert it to the type.
287 The value is nil or a string.
288 This function is used both for remote requests
289 and for local x-get-selection-internal.
291 This calls random Lisp code, and may signal or gc. */
294 x_get_local_selection (selection_symbol
, target_type
)
295 Lisp_Object selection_symbol
, target_type
;
297 Lisp_Object local_value
;
298 Lisp_Object handler_fn
, value
, type
, check
;
301 local_value
= assq_no_quit (selection_symbol
, Vselection_alist
);
303 if (NILP (local_value
)) return Qnil
;
305 /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
306 if (EQ (target_type
, QTIMESTAMP
))
309 value
= XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
;
312 else if (EQ (target_type
, QDELETE
))
315 Fx_disown_selection_internal
317 XCONS (XCONS (XCONS (local_value
)->cdr
)->cdr
)->car
);
322 #if 0 /* #### MULTIPLE doesn't work yet */
323 else if (CONSP (target_type
)
324 && XCONS (target_type
)->car
== QMULTIPLE
)
329 pairs
= XCONS (target_type
)->cdr
;
330 size
= XVECTOR (pairs
)->size
;
331 /* If the target is MULTIPLE, then target_type looks like
332 (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
333 We modify the second element of each pair in the vector and
334 return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
336 for (i
= 0; i
< size
; i
++)
339 pair
= XVECTOR (pairs
)->contents
[i
];
340 XVECTOR (pair
)->contents
[1]
341 = x_get_local_selection (XVECTOR (pair
)->contents
[0],
342 XVECTOR (pair
)->contents
[1]);
349 /* Don't allow a quit within the converter.
350 When the user types C-g, he would be surprised
351 if by luck it came during a converter. */
352 count
= specpdl_ptr
- specpdl
;
353 specbind (Qinhibit_quit
, Qt
);
355 CHECK_SYMBOL (target_type
, 0);
356 handler_fn
= Fcdr (Fassq (target_type
, Vselection_converter_alist
));
357 if (!NILP (handler_fn
))
358 value
= call3 (handler_fn
,
359 selection_symbol
, target_type
,
360 XCONS (XCONS (local_value
)->cdr
)->car
);
363 unbind_to (count
, Qnil
);
366 /* Make sure this value is of a type that we could transmit
367 to another X client. */
371 && SYMBOLP (XCONS (value
)->car
))
372 type
= XCONS (value
)->car
,
373 check
= XCONS (value
)->cdr
;
381 /* Check for a value that cons_to_long could handle. */
382 else if (CONSP (check
)
383 && INTEGERP (XCONS (check
)->car
)
384 && (INTEGERP (XCONS (check
)->cdr
)
386 (CONSP (XCONS (check
)->cdr
)
387 && INTEGERP (XCONS (XCONS (check
)->cdr
)->car
)
388 && NILP (XCONS (XCONS (check
)->cdr
)->cdr
))))
393 Fcons (build_string ("invalid data returned by selection-conversion function"),
394 Fcons (handler_fn
, Fcons (value
, Qnil
))));
397 /* Subroutines of x_reply_selection_request. */
399 /* Send a SelectionNotify event to the requestor with property=None,
400 meaning we were unable to do what they wanted. */
403 x_decline_selection_request (event
)
404 struct input_event
*event
;
406 XSelectionEvent reply
;
407 reply
.type
= SelectionNotify
;
408 reply
.display
= SELECTION_EVENT_DISPLAY (event
);
409 reply
.requestor
= SELECTION_EVENT_REQUESTOR (event
);
410 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
411 reply
.time
= SELECTION_EVENT_TIME (event
);
412 reply
.target
= SELECTION_EVENT_TARGET (event
);
413 reply
.property
= None
;
416 XSendEvent (reply
.display
, reply
.requestor
, False
, 0L,
422 /* This is the selection request currently being processed.
423 It is set to zero when the request is fully processed. */
424 static struct input_event
*x_selection_current_request
;
426 /* Used as an unwind-protect clause so that, if a selection-converter signals
427 an error, we tell the requestor that we were unable to do what they wanted
428 before we throw to top-level or go into the debugger or whatever. */
431 x_selection_request_lisp_error (ignore
)
434 if (x_selection_current_request
!= 0)
435 x_decline_selection_request (x_selection_current_request
);
440 /* This stuff is so that INCR selections are reentrant (that is, so we can
441 be servicing multiple INCR selection requests simultaneously.) I haven't
442 actually tested that yet. */
444 /* Keep a list of the property changes that are awaited. */
454 struct prop_location
*next
;
457 static struct prop_location
*expect_property_change ();
458 static void wait_for_property_change ();
459 static void unexpect_property_change ();
460 static int waiting_for_other_props_on_window ();
462 static int prop_location_identifier
;
464 static Lisp_Object property_change_reply
;
466 static struct prop_location
*property_change_reply_object
;
468 static struct prop_location
*property_change_wait_list
;
470 /* Send the reply to a selection request event EVENT.
471 TYPE is the type of selection data requested.
472 DATA and SIZE describe the data to send, already converted.
473 FORMAT is the unit-size (in bits) of the data to be transmitted. */
476 x_reply_selection_request (event
, format
, data
, size
, type
)
477 struct input_event
*event
;
482 XSelectionEvent reply
;
483 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
484 Window window
= SELECTION_EVENT_REQUESTOR (event
);
486 int format_bytes
= format
/8;
487 int max_bytes
= SELECTION_QUANTUM (display
);
489 if (max_bytes
> MAX_SELECTION_QUANTUM
)
490 max_bytes
= MAX_SELECTION_QUANTUM
;
492 reply
.type
= SelectionNotify
;
493 reply
.display
= display
;
494 reply
.requestor
= window
;
495 reply
.selection
= SELECTION_EVENT_SELECTION (event
);
496 reply
.time
= SELECTION_EVENT_TIME (event
);
497 reply
.target
= SELECTION_EVENT_TARGET (event
);
498 reply
.property
= SELECTION_EVENT_PROPERTY (event
);
499 if (reply
.property
== None
)
500 reply
.property
= reply
.target
;
502 /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
504 /* Store the data on the requested property.
505 If the selection is large, only store the first N bytes of it.
507 bytes_remaining
= size
* format_bytes
;
508 if (bytes_remaining
<= max_bytes
)
510 /* Send all the data at once, with minimal handshaking. */
512 fprintf (stderr
,"\nStoring all %d\n", bytes_remaining
);
515 XChangeProperty (display
, window
, reply
.property
, type
, format
,
516 PropModeReplace
, data
, size
);
517 /* At this point, the selection was successfully stored; ack it. */
518 XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
524 /* Send an INCR selection. */
525 struct prop_location
*wait_object
;
529 if (x_window_to_frame (window
)) /* #### debug */
530 error ("attempt to transfer an INCR to ourself!");
532 fprintf (stderr
, "\nINCR %d\n", bytes_remaining
);
534 wait_object
= expect_property_change (display
, window
, reply
.property
,
537 XChangeProperty (display
, window
, reply
.property
, Xatom_INCR
,
538 32, PropModeReplace
, (unsigned char *)
539 &bytes_remaining
, 1);
540 XSelectInput (display
, window
, PropertyChangeMask
);
541 /* Tell 'em the INCR data is there... */
542 (void) XSendEvent (display
, window
, False
, 0L, (XEvent
*) &reply
);
546 /* First, wait for the requestor to ack by deleting the property.
547 This can run random lisp code (process handlers) or signal. */
548 wait_for_property_change (wait_object
);
550 while (bytes_remaining
)
552 int i
= ((bytes_remaining
< max_bytes
)
559 = expect_property_change (display
, window
, reply
.property
,
562 fprintf (stderr
," INCR adding %d\n", i
);
564 /* Append the next chunk of data to the property. */
565 XChangeProperty (display
, window
, reply
.property
, type
, format
,
566 PropModeAppend
, data
, i
/ format_bytes
);
567 bytes_remaining
-= i
;
572 /* Now wait for the requestor to ack this chunk by deleting the
573 property. This can run random lisp code or signal.
575 wait_for_property_change (wait_object
);
577 /* Now write a zero-length chunk to the property to tell the requestor
580 fprintf (stderr
," INCR done\n");
583 if (! waiting_for_other_props_on_window (display
, window
))
584 XSelectInput (display
, window
, 0L);
586 XChangeProperty (display
, window
, reply
.property
, type
, format
,
587 PropModeReplace
, data
, 0);
593 /* Handle a SelectionRequest event EVENT.
594 This is called from keyboard.c when such an event is found in the queue. */
597 x_handle_selection_request (event
)
598 struct input_event
*event
;
600 struct gcpro gcpro1
, gcpro2
, gcpro3
;
601 Lisp_Object local_selection_data
;
602 Lisp_Object selection_symbol
;
603 Lisp_Object target_symbol
;
604 Lisp_Object converted_selection
;
605 Time local_selection_time
;
606 Lisp_Object successful_p
;
609 local_selection_data
= Qnil
;
610 target_symbol
= Qnil
;
611 converted_selection
= Qnil
;
614 GCPRO3 (local_selection_data
, converted_selection
, target_symbol
);
616 selection_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
617 SELECTION_EVENT_SELECTION (event
));
619 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
621 if (NILP (local_selection_data
))
623 /* Someone asked for the selection, but we don't have it any more.
625 x_decline_selection_request (event
);
629 local_selection_time
= (Time
)
630 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
632 if (SELECTION_EVENT_TIME (event
) != CurrentTime
633 && local_selection_time
> SELECTION_EVENT_TIME (event
))
635 /* Someone asked for the selection, and we have one, but not the one
638 x_decline_selection_request (event
);
642 count
= specpdl_ptr
- specpdl
;
643 x_selection_current_request
= event
;
644 record_unwind_protect (x_selection_request_lisp_error
, Qnil
);
646 target_symbol
= x_atom_to_symbol (SELECTION_EVENT_DISPLAY (event
),
647 SELECTION_EVENT_TARGET (event
));
649 #if 0 /* #### MULTIPLE doesn't work yet */
650 if (EQ (target_symbol
, QMULTIPLE
))
651 target_symbol
= fetch_multiple_target (event
);
654 /* Convert lisp objects back into binary data */
657 = x_get_local_selection (selection_symbol
, target_symbol
);
659 if (! NILP (converted_selection
))
667 lisp_data_to_selection_data (SELECTION_EVENT_DISPLAY (event
),
669 &data
, &type
, &size
, &format
, &nofree
);
671 x_reply_selection_request (event
, format
, data
, size
, type
);
674 /* Indicate we have successfully processed this event. */
675 x_selection_current_request
= 0;
680 unbind_to (count
, Qnil
);
686 /* Let random lisp code notice that the selection has been asked for. */
689 rest
= Vx_sent_selection_hooks
;
690 if (!EQ (rest
, Qunbound
))
691 for (; CONSP (rest
); rest
= Fcdr (rest
))
692 call3 (Fcar (rest
), selection_symbol
, target_symbol
, successful_p
);
696 /* Handle a SelectionClear event EVENT, which indicates that some other
697 client cleared out our previously asserted selection.
698 This is called from keyboard.c when such an event is found in the queue. */
701 x_handle_selection_clear (event
)
702 struct input_event
*event
;
704 Display
*display
= SELECTION_EVENT_DISPLAY (event
);
705 Atom selection
= SELECTION_EVENT_SELECTION (event
);
706 Time changed_owner_time
= SELECTION_EVENT_TIME (event
);
708 Lisp_Object selection_symbol
, local_selection_data
;
709 Time local_selection_time
;
711 selection_symbol
= x_atom_to_symbol (display
, selection
);
713 local_selection_data
= assq_no_quit (selection_symbol
, Vselection_alist
);
715 /* Well, we already believe that we don't own it, so that's just fine. */
716 if (NILP (local_selection_data
)) return;
718 local_selection_time
= (Time
)
719 cons_to_long (XCONS (XCONS (XCONS (local_selection_data
)->cdr
)->cdr
)->car
);
721 /* This SelectionClear is for a selection that we no longer own, so we can
722 disregard it. (That is, we have reasserted the selection since this
723 request was generated.) */
725 if (changed_owner_time
!= CurrentTime
726 && local_selection_time
> changed_owner_time
)
729 /* Otherwise, we're really honest and truly being told to drop it.
730 Don't use Fdelq as that may QUIT;. */
732 if (EQ (local_selection_data
, Fcar (Vselection_alist
)))
733 Vselection_alist
= Fcdr (Vselection_alist
);
737 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
738 if (EQ (local_selection_data
, Fcar (XCONS (rest
)->cdr
)))
740 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
745 /* Let random lisp code notice that the selection has been stolen. */
749 rest
= Vx_lost_selection_hooks
;
750 if (!EQ (rest
, Qunbound
))
752 for (; CONSP (rest
); rest
= Fcdr (rest
))
753 call1 (Fcar (rest
), selection_symbol
);
754 prepare_menu_bars ();
755 redisplay_preserve_echo_area ();
760 /* Clear all selections that were made from frame F.
761 We do this when about to delete a frame. */
764 x_clear_frame_selections (f
)
770 XSETFRAME (frame
, f
);
772 /* Otherwise, we're really honest and truly being told to drop it.
773 Don't use Fdelq as that may QUIT;. */
775 while (!NILP (Vselection_alist
)
776 && EQ (frame
, Fcar (Fcdr (Fcdr (Fcdr (Fcar (Vselection_alist
)))))))
778 /* Let random Lisp code notice that the selection has been stolen. */
779 Lisp_Object hooks
, selection_symbol
;
781 hooks
= Vx_lost_selection_hooks
;
782 selection_symbol
= Fcar (Vselection_alist
);
784 if (!EQ (hooks
, Qunbound
))
786 for (; CONSP (hooks
); hooks
= Fcdr (hooks
))
787 call1 (Fcar (hooks
), selection_symbol
);
788 redisplay_preserve_echo_area ();
791 Vselection_alist
= Fcdr (Vselection_alist
);
794 for (rest
= Vselection_alist
; !NILP (rest
); rest
= Fcdr (rest
))
795 if (EQ (frame
, Fcar (Fcdr (Fcdr (Fcdr (Fcar (XCONS (rest
)->cdr
)))))))
797 /* Let random Lisp code notice that the selection has been stolen. */
798 Lisp_Object hooks
, selection_symbol
;
800 hooks
= Vx_lost_selection_hooks
;
801 selection_symbol
= Fcar (XCONS (rest
)->cdr
);
803 if (!EQ (hooks
, Qunbound
))
805 for (; CONSP (hooks
); hooks
= Fcdr (hooks
))
806 call1 (Fcar (hooks
), selection_symbol
);
807 redisplay_preserve_echo_area ();
809 XCONS (rest
)->cdr
= Fcdr (XCONS (rest
)->cdr
);
814 /* Nonzero if any properties for DISPLAY and WINDOW
815 are on the list of what we are waiting for. */
818 waiting_for_other_props_on_window (display
, window
)
822 struct prop_location
*rest
= property_change_wait_list
;
824 if (rest
->display
== display
&& rest
->window
== window
)
831 /* Add an entry to the list of property changes we are waiting for.
832 DISPLAY, WINDOW, PROPERTY, STATE describe what we will wait for.
833 The return value is a number that uniquely identifies
834 this awaited property change. */
836 static struct prop_location
*
837 expect_property_change (display
, window
, property
, state
)
840 Lisp_Object property
;
843 struct prop_location
*pl
844 = (struct prop_location
*) xmalloc (sizeof (struct prop_location
));
845 pl
->identifier
= ++prop_location_identifier
;
846 pl
->display
= display
;
848 pl
->property
= property
;
849 pl
->desired_state
= state
;
850 pl
->next
= property_change_wait_list
;
852 property_change_wait_list
= pl
;
856 /* Delete an entry from the list of property changes we are waiting for.
857 IDENTIFIER is the number that uniquely identifies the entry. */
860 unexpect_property_change (location
)
861 struct prop_location
*location
;
863 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
866 if (rest
== location
)
869 prev
->next
= rest
->next
;
871 property_change_wait_list
= rest
->next
;
880 /* Remove the property change expectation element for IDENTIFIER. */
883 wait_for_property_change_unwind (identifierval
)
884 Lisp_Object identifierval
;
886 unexpect_property_change (XPNTR (identifierval
));
889 /* Actually wait for a property change.
890 IDENTIFIER should be the value that expect_property_change returned. */
893 wait_for_property_change (location
)
894 struct prop_location
*location
;
897 int count
= specpdl_ptr
- specpdl
;
900 XSETCONS (tem
, location
);
902 /* Make sure to do unexpect_property_change if we quit or err. */
903 record_unwind_protect (wait_for_property_change_unwind
, tem
);
905 XCONS (property_change_reply
)->car
= Qnil
;
907 if (! location
->arrived
)
909 property_change_reply_object
= location
;
910 secs
= x_selection_timeout
/ 1000;
911 usecs
= (x_selection_timeout
% 1000) * 1000;
912 wait_reading_process_input (secs
, usecs
, property_change_reply
, 0);
914 if (NILP (XCONS (property_change_reply
)->car
))
915 error ("timed out waiting for property-notify event");
918 unbind_to (count
, Qnil
);
921 /* Called from XTread_socket in response to a PropertyNotify event. */
924 x_handle_property_notify (event
)
925 XPropertyEvent
*event
;
927 struct prop_location
*prev
= 0, *rest
= property_change_wait_list
;
930 if (rest
->property
== event
->atom
931 && rest
->window
== event
->window
932 && rest
->display
== event
->display
933 && rest
->desired_state
== event
->state
)
936 fprintf (stderr
, "Saw expected prop-%s on %s\n",
937 (event
->state
== PropertyDelete
? "delete" : "change"),
938 (char *) XSYMBOL (x_atom_to_symbol (event
->display
,
945 /* If this is the one wait_for_property_change is waiting for,
946 tell it to wake up. */
947 if (rest
== property_change_reply_object
)
948 XCONS (property_change_reply
)->car
= Qt
;
951 prev
->next
= rest
->next
;
953 property_change_wait_list
= rest
->next
;
961 fprintf (stderr
, "Saw UNexpected prop-%s on %s\n",
962 (event
->state
== PropertyDelete
? "delete" : "change"),
963 (char *) XSYMBOL (x_atom_to_symbol (event
->display
, event
->atom
))
970 #if 0 /* #### MULTIPLE doesn't work yet */
973 fetch_multiple_target (event
)
974 XSelectionRequestEvent
*event
;
976 Display
*display
= event
->display
;
977 Window window
= event
->requestor
;
978 Atom target
= event
->target
;
979 Atom selection_atom
= event
->selection
;
984 x_get_window_property_as_lisp_data (display
, window
, target
,
985 QMULTIPLE
, selection_atom
));
989 copy_multiple_data (obj
)
996 return Fcons (XCONS (obj
)->car
, copy_multiple_data (XCONS (obj
)->cdr
));
998 CHECK_VECTOR (obj
, 0);
999 vec
= Fmake_vector (size
= XVECTOR (obj
)->size
, Qnil
);
1000 for (i
= 0; i
< size
; i
++)
1002 Lisp_Object vec2
= XVECTOR (obj
)->contents
[i
];
1003 CHECK_VECTOR (vec2
, 0);
1004 if (XVECTOR (vec2
)->size
!= 2)
1005 /* ??? Confusing error message */
1006 Fsignal (Qerror
, Fcons (build_string ("vectors must be of length 2"),
1007 Fcons (vec2
, Qnil
)));
1008 XVECTOR (vec
)->contents
[i
] = Fmake_vector (2, Qnil
);
1009 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[0]
1010 = XVECTOR (vec2
)->contents
[0];
1011 XVECTOR (XVECTOR (vec
)->contents
[i
])->contents
[1]
1012 = XVECTOR (vec2
)->contents
[1];
1020 /* Variables for communication with x_handle_selection_notify. */
1021 static Atom reading_which_selection
;
1022 static Lisp_Object reading_selection_reply
;
1023 static Window reading_selection_window
;
1025 /* Do protocol to read selection-data from the server.
1026 Converts this to Lisp data and returns it. */
1029 x_get_foreign_selection (selection_symbol
, target_type
)
1030 Lisp_Object selection_symbol
, target_type
;
1032 Window requestor_window
= FRAME_X_WINDOW (selected_frame
);
1033 Display
*display
= FRAME_X_DISPLAY (selected_frame
);
1034 Time requestor_time
= last_event_timestamp
;
1035 Atom target_property
= Xatom_EMACS_TMP
;
1036 Atom selection_atom
= symbol_to_x_atom (display
, selection_symbol
);
1040 if (CONSP (target_type
))
1041 type_atom
= symbol_to_x_atom (display
, XCONS (target_type
)->car
);
1043 type_atom
= symbol_to_x_atom (display
, target_type
);
1046 x_catch_errors (selected_frame
);
1047 XConvertSelection (display
, selection_atom
, type_atom
, target_property
,
1048 requestor_window
, requestor_time
);
1051 /* Prepare to block until the reply has been read. */
1052 reading_selection_window
= requestor_window
;
1053 reading_which_selection
= selection_atom
;
1054 XCONS (reading_selection_reply
)->car
= Qnil
;
1055 x_start_queuing_selection_requests (selected_frame
);
1058 /* This allows quits. Also, don't wait forever. */
1059 secs
= x_selection_timeout
/ 1000;
1060 usecs
= (x_selection_timeout
% 1000) * 1000;
1061 wait_reading_process_input (secs
, usecs
, reading_selection_reply
, 0);
1064 x_check_errors (selected_frame
, "Cannot get selection: %s");
1065 x_uncatch_errors (selected_frame
);
1066 x_stop_queuing_selection_requests (selected_frame
);
1069 if (NILP (XCONS (reading_selection_reply
)->car
))
1070 error ("timed out waiting for reply from selection owner");
1072 /* Otherwise, the selection is waiting for us on the requested property. */
1074 x_get_window_property_as_lisp_data (display
, requestor_window
,
1075 target_property
, target_type
,
1079 /* Subroutines of x_get_window_property_as_lisp_data */
1082 x_get_window_property (display
, window
, property
, data_ret
, bytes_ret
,
1083 actual_type_ret
, actual_format_ret
, actual_size_ret
,
1088 unsigned char **data_ret
;
1090 Atom
*actual_type_ret
;
1091 int *actual_format_ret
;
1092 unsigned long *actual_size_ret
;
1096 unsigned long bytes_remaining
;
1098 unsigned char *tmp_data
= 0;
1100 int buffer_size
= SELECTION_QUANTUM (display
);
1101 if (buffer_size
> MAX_SELECTION_QUANTUM
) buffer_size
= MAX_SELECTION_QUANTUM
;
1104 /* First probe the thing to find out how big it is. */
1105 result
= XGetWindowProperty (display
, window
, property
,
1106 0, 0, False
, AnyPropertyType
,
1107 actual_type_ret
, actual_format_ret
,
1109 &bytes_remaining
, &tmp_data
);
1110 if (result
!= Success
)
1117 xfree ((char *) tmp_data
);
1119 if (*actual_type_ret
== None
|| *actual_format_ret
== 0)
1125 total_size
= bytes_remaining
+ 1;
1126 *data_ret
= (unsigned char *) xmalloc (total_size
);
1128 /* Now read, until weve gotten it all. */
1129 while (bytes_remaining
)
1132 int last
= bytes_remaining
;
1135 = XGetWindowProperty (display
, window
, property
,
1136 offset
/4, buffer_size
/4,
1139 actual_type_ret
, actual_format_ret
,
1140 actual_size_ret
, &bytes_remaining
, &tmp_data
);
1142 fprintf (stderr
, "<< read %d\n", last
-bytes_remaining
);
1144 /* If this doesn't return Success at this point, it means that
1145 some clod deleted the selection while we were in the midst of
1146 reading it. Deal with that, I guess....
1148 if (result
!= Success
) break;
1149 *actual_size_ret
*= *actual_format_ret
/ 8;
1150 bcopy (tmp_data
, (*data_ret
) + offset
, *actual_size_ret
);
1151 offset
+= *actual_size_ret
;
1152 xfree ((char *) tmp_data
);
1157 *bytes_ret
= offset
;
1161 receive_incremental_selection (display
, window
, property
, target_type
,
1162 min_size_bytes
, data_ret
, size_bytes_ret
,
1163 type_ret
, format_ret
, size_ret
)
1167 Lisp_Object target_type
; /* for error messages only */
1168 unsigned int min_size_bytes
;
1169 unsigned char **data_ret
;
1170 int *size_bytes_ret
;
1172 unsigned long *size_ret
;
1176 struct prop_location
*wait_object
;
1177 *size_bytes_ret
= min_size_bytes
;
1178 *data_ret
= (unsigned char *) xmalloc (*size_bytes_ret
);
1180 fprintf (stderr
, "\nread INCR %d\n", min_size_bytes
);
1183 /* At this point, we have read an INCR property.
1184 Delete the property to ack it.
1185 (But first, prepare to receive the next event in this handshake.)
1187 Now, we must loop, waiting for the sending window to put a value on
1188 that property, then reading the property, then deleting it to ack.
1189 We are done when the sender places a property of length 0.
1192 XSelectInput (display
, window
, STANDARD_EVENT_SET
| PropertyChangeMask
);
1193 XDeleteProperty (display
, window
, property
);
1194 wait_object
= expect_property_change (display
, window
, property
,
1201 unsigned char *tmp_data
;
1203 wait_for_property_change (wait_object
);
1204 /* expect it again immediately, because x_get_window_property may
1205 .. no it wont, I dont get it.
1206 .. Ok, I get it now, the Xt code that implements INCR is broken.
1208 x_get_window_property (display
, window
, property
,
1209 &tmp_data
, &tmp_size_bytes
,
1210 type_ret
, format_ret
, size_ret
, 1);
1212 if (tmp_size_bytes
== 0) /* we're done */
1215 fprintf (stderr
, " read INCR done\n");
1217 if (! waiting_for_other_props_on_window (display
, window
))
1218 XSelectInput (display
, window
, STANDARD_EVENT_SET
);
1219 unexpect_property_change (wait_object
);
1220 if (tmp_data
) xfree (tmp_data
);
1225 XDeleteProperty (display
, window
, property
);
1226 wait_object
= expect_property_change (display
, window
, property
,
1232 fprintf (stderr
, " read INCR %d\n", tmp_size_bytes
);
1234 if (*size_bytes_ret
< offset
+ tmp_size_bytes
)
1237 fprintf (stderr
, " read INCR realloc %d -> %d\n",
1238 *size_bytes_ret
, offset
+ tmp_size_bytes
);
1240 *size_bytes_ret
= offset
+ tmp_size_bytes
;
1241 *data_ret
= (unsigned char *) xrealloc (*data_ret
, *size_bytes_ret
);
1243 bcopy (tmp_data
, (*data_ret
) + offset
, tmp_size_bytes
);
1244 offset
+= tmp_size_bytes
;
1249 /* Once a requested selection is "ready" (we got a SelectionNotify event),
1250 fetch value from property PROPERTY of X window WINDOW on display DISPLAY.
1251 TARGET_TYPE and SELECTION_ATOM are used in error message if this fails. */
1254 x_get_window_property_as_lisp_data (display
, window
, property
, target_type
,
1259 Lisp_Object target_type
; /* for error messages only */
1260 Atom selection_atom
; /* for error messages only */
1264 unsigned long actual_size
;
1265 unsigned char *data
= 0;
1269 x_get_window_property (display
, window
, property
, &data
, &bytes
,
1270 &actual_type
, &actual_format
, &actual_size
, 1);
1273 int there_is_a_selection_owner
;
1275 there_is_a_selection_owner
1276 = XGetSelectionOwner (display
, selection_atom
);
1278 while (1) /* Note debugger can no longer return, so this is obsolete */
1280 there_is_a_selection_owner
?
1281 Fcons (build_string ("selection owner couldn't convert"),
1283 ? Fcons (target_type
,
1284 Fcons (x_atom_to_symbol (display
, actual_type
),
1286 : Fcons (target_type
, Qnil
))
1287 : Fcons (build_string ("no selection"),
1288 Fcons (x_atom_to_symbol (display
, selection_atom
),
1292 if (actual_type
== Xatom_INCR
)
1294 /* That wasn't really the data, just the beginning. */
1296 unsigned int min_size_bytes
= * ((unsigned int *) data
);
1298 XFree ((char *) data
);
1300 receive_incremental_selection (display
, window
, property
, target_type
,
1301 min_size_bytes
, &data
, &bytes
,
1302 &actual_type
, &actual_format
,
1307 XDeleteProperty (display
, window
, property
);
1311 /* It's been read. Now convert it to a lisp object in some semi-rational
1313 val
= selection_data_to_lisp_data (display
, data
, bytes
,
1314 actual_type
, actual_format
);
1316 xfree ((char *) data
);
1320 /* These functions convert from the selection data read from the server into
1321 something that we can use from Lisp, and vice versa.
1323 Type: Format: Size: Lisp Type:
1324 ----- ------- ----- -----------
1327 ATOM 32 > 1 Vector of Symbols
1329 * 16 > 1 Vector of Integers
1330 * 32 1 if <=16 bits: Integer
1331 if > 16 bits: Cons of top16, bot16
1332 * 32 > 1 Vector of the above
1334 When converting a Lisp number to C, it is assumed to be of format 16 if
1335 it is an integer, and of format 32 if it is a cons of two integers.
1337 When converting a vector of numbers from Lisp to C, it is assumed to be
1338 of format 16 if every element in the vector is an integer, and is assumed
1339 to be of format 32 if any element is a cons of two integers.
1341 When converting an object to C, it may be of the form (SYMBOL . <data>)
1342 where SYMBOL is what we should claim that the type is. Format and
1343 representation are as above. */
1348 selection_data_to_lisp_data (display
, data
, size
, type
, format
)
1350 unsigned char *data
;
1355 if (type
== Xatom_NULL
)
1358 /* Convert any 8-bit data to a string, for compactness. */
1359 else if (format
== 8)
1360 return make_string ((char *) data
, size
);
1362 /* Convert a single atom to a Lisp_Symbol. Convert a set of atoms to
1363 a vector of symbols.
1365 else if (type
== XA_ATOM
)
1368 if (size
== sizeof (Atom
))
1369 return x_atom_to_symbol (display
, *((Atom
*) data
));
1372 Lisp_Object v
= Fmake_vector (size
/ sizeof (Atom
), 0);
1373 for (i
= 0; i
< size
/ sizeof (Atom
); i
++)
1374 Faset (v
, i
, x_atom_to_symbol (display
, ((Atom
*) data
) [i
]));
1379 /* Convert a single 16 or small 32 bit number to a Lisp_Int.
1380 If the number is > 16 bits, convert it to a cons of integers,
1381 16 bits in each half.
1383 else if (format
== 32 && size
== sizeof (long))
1384 return long_to_cons (((unsigned long *) data
) [0]);
1385 else if (format
== 16 && size
== sizeof (short))
1386 return make_number ((int) (((unsigned short *) data
) [0]));
1388 /* Convert any other kind of data to a vector of numbers, represented
1389 as above (as an integer, or a cons of two 16 bit integers.)
1391 else if (format
== 16)
1394 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1395 for (i
= 0; i
< size
/ 4; i
++)
1397 int j
= (int) ((unsigned short *) data
) [i
];
1398 Faset (v
, i
, make_number (j
));
1405 Lisp_Object v
= Fmake_vector (size
/ 4, 0);
1406 for (i
= 0; i
< size
/ 4; i
++)
1408 unsigned long j
= ((unsigned long *) data
) [i
];
1409 Faset (v
, i
, long_to_cons (j
));
1417 lisp_data_to_selection_data (display
, obj
,
1418 data_ret
, type_ret
, size_ret
,
1419 format_ret
, nofree_ret
)
1422 unsigned char **data_ret
;
1424 unsigned int *size_ret
;
1428 Lisp_Object type
= Qnil
;
1432 if (CONSP (obj
) && SYMBOLP (XCONS (obj
)->car
))
1434 type
= XCONS (obj
)->car
;
1435 obj
= XCONS (obj
)->cdr
;
1436 if (CONSP (obj
) && NILP (XCONS (obj
)->cdr
))
1437 obj
= XCONS (obj
)->car
;
1440 if (EQ (obj
, QNULL
) || (EQ (type
, QNULL
)))
1441 { /* This is not the same as declining */
1447 else if (STRINGP (obj
))
1450 *size_ret
= XSTRING (obj
)->size
;
1451 *data_ret
= XSTRING (obj
)->data
;
1453 if (NILP (type
)) type
= QSTRING
;
1455 else if (SYMBOLP (obj
))
1459 *data_ret
= (unsigned char *) xmalloc (sizeof (Atom
) + 1);
1460 (*data_ret
) [sizeof (Atom
)] = 0;
1461 (*(Atom
**) data_ret
) [0] = symbol_to_x_atom (display
, obj
);
1462 if (NILP (type
)) type
= QATOM
;
1464 else if (INTEGERP (obj
)
1465 && XINT (obj
) < 0xFFFF
1466 && XINT (obj
) > -0xFFFF)
1470 *data_ret
= (unsigned char *) xmalloc (sizeof (short) + 1);
1471 (*data_ret
) [sizeof (short)] = 0;
1472 (*(short **) data_ret
) [0] = (short) XINT (obj
);
1473 if (NILP (type
)) type
= QINTEGER
;
1475 else if (INTEGERP (obj
)
1476 || (CONSP (obj
) && INTEGERP (XCONS (obj
)->car
)
1477 && (INTEGERP (XCONS (obj
)->cdr
)
1478 || (CONSP (XCONS (obj
)->cdr
)
1479 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)))))
1483 *data_ret
= (unsigned char *) xmalloc (sizeof (long) + 1);
1484 (*data_ret
) [sizeof (long)] = 0;
1485 (*(unsigned long **) data_ret
) [0] = cons_to_long (obj
);
1486 if (NILP (type
)) type
= QINTEGER
;
1488 else if (VECTORP (obj
))
1490 /* Lisp_Vectors may represent a set of ATOMs;
1491 a set of 16 or 32 bit INTEGERs;
1492 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
1496 if (SYMBOLP (XVECTOR (obj
)->contents
[0]))
1497 /* This vector is an ATOM set */
1499 if (NILP (type
)) type
= QATOM
;
1500 *size_ret
= XVECTOR (obj
)->size
;
1502 *data_ret
= (unsigned char *) xmalloc ((*size_ret
) * sizeof (Atom
));
1503 for (i
= 0; i
< *size_ret
; i
++)
1504 if (SYMBOLP (XVECTOR (obj
)->contents
[i
]))
1505 (*(Atom
**) data_ret
) [i
]
1506 = symbol_to_x_atom (display
, XVECTOR (obj
)->contents
[i
]);
1508 Fsignal (Qerror
, /* Qselection_error */
1510 ("all elements of selection vector must have same type"),
1511 Fcons (obj
, Qnil
)));
1513 #if 0 /* #### MULTIPLE doesn't work yet */
1514 else if (VECTORP (XVECTOR (obj
)->contents
[0]))
1515 /* This vector is an ATOM_PAIR set */
1517 if (NILP (type
)) type
= QATOM_PAIR
;
1518 *size_ret
= XVECTOR (obj
)->size
;
1520 *data_ret
= (unsigned char *)
1521 xmalloc ((*size_ret
) * sizeof (Atom
) * 2);
1522 for (i
= 0; i
< *size_ret
; i
++)
1523 if (VECTORP (XVECTOR (obj
)->contents
[i
]))
1525 Lisp_Object pair
= XVECTOR (obj
)->contents
[i
];
1526 if (XVECTOR (pair
)->size
!= 2)
1529 ("elements of the vector must be vectors of exactly two elements"),
1530 Fcons (pair
, Qnil
)));
1532 (*(Atom
**) data_ret
) [i
* 2]
1533 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[0]);
1534 (*(Atom
**) data_ret
) [(i
* 2) + 1]
1535 = symbol_to_x_atom (display
, XVECTOR (pair
)->contents
[1]);
1540 ("all elements of the vector must be of the same type"),
1541 Fcons (obj
, Qnil
)));
1546 /* This vector is an INTEGER set, or something like it */
1548 *size_ret
= XVECTOR (obj
)->size
;
1549 if (NILP (type
)) type
= QINTEGER
;
1551 for (i
= 0; i
< *size_ret
; i
++)
1552 if (CONSP (XVECTOR (obj
)->contents
[i
]))
1554 else if (!INTEGERP (XVECTOR (obj
)->contents
[i
]))
1555 Fsignal (Qerror
, /* Qselection_error */
1557 ("elements of selection vector must be integers or conses of integers"),
1558 Fcons (obj
, Qnil
)));
1560 *data_ret
= (unsigned char *) xmalloc (*size_ret
* (*format_ret
/8));
1561 for (i
= 0; i
< *size_ret
; i
++)
1562 if (*format_ret
== 32)
1563 (*((unsigned long **) data_ret
)) [i
]
1564 = cons_to_long (XVECTOR (obj
)->contents
[i
]);
1566 (*((unsigned short **) data_ret
)) [i
]
1567 = (unsigned short) cons_to_long (XVECTOR (obj
)->contents
[i
]);
1571 Fsignal (Qerror
, /* Qselection_error */
1572 Fcons (build_string ("unrecognised selection data"),
1573 Fcons (obj
, Qnil
)));
1575 *type_ret
= symbol_to_x_atom (display
, type
);
1579 clean_local_selection_data (obj
)
1583 && INTEGERP (XCONS (obj
)->car
)
1584 && CONSP (XCONS (obj
)->cdr
)
1585 && INTEGERP (XCONS (XCONS (obj
)->cdr
)->car
)
1586 && NILP (XCONS (XCONS (obj
)->cdr
)->cdr
))
1587 obj
= Fcons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1590 && INTEGERP (XCONS (obj
)->car
)
1591 && INTEGERP (XCONS (obj
)->cdr
))
1593 if (XINT (XCONS (obj
)->car
) == 0)
1594 return XCONS (obj
)->cdr
;
1595 if (XINT (XCONS (obj
)->car
) == -1)
1596 return make_number (- XINT (XCONS (obj
)->cdr
));
1601 int size
= XVECTOR (obj
)->size
;
1604 return clean_local_selection_data (XVECTOR (obj
)->contents
[0]);
1605 copy
= Fmake_vector (size
, Qnil
);
1606 for (i
= 0; i
< size
; i
++)
1607 XVECTOR (copy
)->contents
[i
]
1608 = clean_local_selection_data (XVECTOR (obj
)->contents
[i
]);
1614 /* Called from XTread_socket to handle SelectionNotify events.
1615 If it's the selection we are waiting for, stop waiting. */
1618 x_handle_selection_notify (event
)
1619 XSelectionEvent
*event
;
1621 if (event
->requestor
!= reading_selection_window
)
1623 if (event
->selection
!= reading_which_selection
)
1626 XCONS (reading_selection_reply
)->car
= Qt
;
1630 DEFUN ("x-own-selection-internal",
1631 Fx_own_selection_internal
, Sx_own_selection_internal
,
1633 "Assert an X selection of the given TYPE with the given VALUE.\n\
1634 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1635 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1636 VALUE is typically a string, or a cons of two markers, but may be\n\
1637 anything that the functions on `selection-converter-alist' know about.")
1638 (selection_name
, selection_value
)
1639 Lisp_Object selection_name
, selection_value
;
1642 CHECK_SYMBOL (selection_name
, 0);
1643 if (NILP (selection_value
)) error ("selection-value may not be nil.");
1644 x_own_selection (selection_name
, selection_value
);
1645 return selection_value
;
1649 /* Request the selection value from the owner. If we are the owner,
1650 simply return our selection value. If we are not the owner, this
1651 will block until all of the data has arrived. */
1653 DEFUN ("x-get-selection-internal",
1654 Fx_get_selection_internal
, Sx_get_selection_internal
, 2, 2, 0,
1655 "Return text selected from some X window.\n\
1656 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1657 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1658 TYPE is the type of data desired, typically `STRING'.")
1659 (selection_symbol
, target_type
)
1660 Lisp_Object selection_symbol
, target_type
;
1662 Lisp_Object val
= Qnil
;
1663 struct gcpro gcpro1
, gcpro2
;
1664 GCPRO2 (target_type
, val
); /* we store newly consed data into these */
1666 CHECK_SYMBOL (selection_symbol
, 0);
1668 #if 0 /* #### MULTIPLE doesn't work yet */
1669 if (CONSP (target_type
)
1670 && XCONS (target_type
)->car
== QMULTIPLE
)
1672 CHECK_VECTOR (XCONS (target_type
)->cdr
, 0);
1673 /* So we don't destructively modify this... */
1674 target_type
= copy_multiple_data (target_type
);
1678 CHECK_SYMBOL (target_type
, 0);
1680 val
= x_get_local_selection (selection_symbol
, target_type
);
1684 val
= x_get_foreign_selection (selection_symbol
, target_type
);
1689 && SYMBOLP (XCONS (val
)->car
))
1691 val
= XCONS (val
)->cdr
;
1692 if (CONSP (val
) && NILP (XCONS (val
)->cdr
))
1693 val
= XCONS (val
)->car
;
1695 val
= clean_local_selection_data (val
);
1701 DEFUN ("x-disown-selection-internal",
1702 Fx_disown_selection_internal
, Sx_disown_selection_internal
, 1, 2, 0,
1703 "If we own the selection SELECTION, disown it.\n\
1704 Disowning it means there is no such selection.")
1706 Lisp_Object selection
;
1710 Atom selection_atom
;
1711 XSelectionClearEvent event
;
1715 display
= FRAME_X_DISPLAY (selected_frame
);
1716 CHECK_SYMBOL (selection
, 0);
1718 timestamp
= last_event_timestamp
;
1720 timestamp
= cons_to_long (time
);
1722 if (NILP (assq_no_quit (selection
, Vselection_alist
)))
1723 return Qnil
; /* Don't disown the selection when we're not the owner. */
1725 selection_atom
= symbol_to_x_atom (display
, selection
);
1728 XSetSelectionOwner (display
, selection_atom
, None
, timestamp
);
1731 /* It doesn't seem to be guaranteed that a SelectionClear event will be
1732 generated for a window which owns the selection when that window sets
1733 the selection owner to None. The NCD server does, the MIT Sun4 server
1734 doesn't. So we synthesize one; this means we might get two, but
1735 that's ok, because the second one won't have any effect. */
1736 SELECTION_EVENT_DISPLAY (&event
) = display
;
1737 SELECTION_EVENT_SELECTION (&event
) = selection_atom
;
1738 SELECTION_EVENT_TIME (&event
) = timestamp
;
1739 x_handle_selection_clear (&event
);
1744 /* Get rid of all the selections in buffer BUFFER.
1745 This is used when we kill a buffer. */
1748 x_disown_buffer_selections (buffer
)
1752 struct buffer
*buf
= XBUFFER (buffer
);
1754 for (tail
= Vselection_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1756 Lisp_Object elt
, value
;
1757 elt
= XCONS (tail
)->car
;
1758 value
= XCONS (elt
)->cdr
;
1759 if (CONSP (value
) && MARKERP (XCONS (value
)->car
)
1760 && XMARKER (XCONS (value
)->car
)->buffer
== buf
)
1761 Fx_disown_selection_internal (XCONS (elt
)->car
, Qnil
);
1765 DEFUN ("x-selection-owner-p", Fx_selection_owner_p
, Sx_selection_owner_p
,
1767 "Whether the current Emacs process owns the given X Selection.\n\
1768 The arg should be the name of the selection in question, typically one of\n\
1769 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1770 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1771 For convenience, the symbol nil is the same as `PRIMARY',\n\
1772 and t is the same as `SECONDARY'.)")
1774 Lisp_Object selection
;
1777 CHECK_SYMBOL (selection
, 0);
1778 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1779 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1781 if (NILP (Fassq (selection
, Vselection_alist
)))
1786 DEFUN ("x-selection-exists-p", Fx_selection_exists_p
, Sx_selection_exists_p
,
1788 "Whether there is an owner for the given X Selection.\n\
1789 The arg should be the name of the selection in question, typically one of\n\
1790 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
1791 \(Those are literal upper-case symbol names, since that's what X expects.)\n\
1792 For convenience, the symbol nil is the same as `PRIMARY',\n\
1793 and t is the same as `SECONDARY'.)")
1795 Lisp_Object selection
;
1802 dpy
= FRAME_X_DISPLAY (selected_frame
);
1803 CHECK_SYMBOL (selection
, 0);
1804 if (!NILP (Fx_selection_owner_p (selection
)))
1806 if (EQ (selection
, Qnil
)) selection
= QPRIMARY
;
1807 if (EQ (selection
, Qt
)) selection
= QSECONDARY
;
1808 atom
= symbol_to_x_atom (dpy
, selection
);
1812 owner
= XGetSelectionOwner (dpy
, atom
);
1814 return (owner
? Qt
: Qnil
);
1818 #ifdef CUT_BUFFER_SUPPORT
1820 static int cut_buffers_initialized
; /* Whether we're sure they all exist */
1822 /* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */
1824 initialize_cut_buffers (display
, window
)
1828 unsigned char *data
= (unsigned char *) "";
1830 #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
1831 PropModeAppend, data, 0)
1832 FROB (XA_CUT_BUFFER0
);
1833 FROB (XA_CUT_BUFFER1
);
1834 FROB (XA_CUT_BUFFER2
);
1835 FROB (XA_CUT_BUFFER3
);
1836 FROB (XA_CUT_BUFFER4
);
1837 FROB (XA_CUT_BUFFER5
);
1838 FROB (XA_CUT_BUFFER6
);
1839 FROB (XA_CUT_BUFFER7
);
1842 cut_buffers_initialized
= 1;
1846 #define CHECK_CUT_BUFFER(symbol,n) \
1847 { CHECK_SYMBOL ((symbol), (n)); \
1848 if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \
1849 && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \
1850 && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \
1851 && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \
1853 Fcons (build_string ("doesn't name a cut buffer"), \
1854 Fcons ((symbol), Qnil))); \
1857 DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal
,
1858 Sx_get_cut_buffer_internal
, 1, 1, 0,
1859 "Returns the value of the named cut buffer (typically CUT_BUFFER0).")
1865 unsigned char *data
;
1874 display
= FRAME_X_DISPLAY (selected_frame
);
1875 window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1876 CHECK_CUT_BUFFER (buffer
, 0);
1877 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1879 x_get_window_property (display
, window
, buffer_atom
, &data
, &bytes
,
1880 &type
, &format
, &size
, 0);
1881 if (!data
) return Qnil
;
1883 if (format
!= 8 || type
!= XA_STRING
)
1885 Fcons (build_string ("cut buffer doesn't contain 8-bit data"),
1886 Fcons (x_atom_to_symbol (display
, type
),
1887 Fcons (make_number (format
), Qnil
))));
1889 ret
= (bytes
? make_string ((char *) data
, bytes
) : Qnil
);
1895 DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal
,
1896 Sx_store_cut_buffer_internal
, 2, 2, 0,
1897 "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
1899 Lisp_Object buffer
, string
;
1903 unsigned char *data
;
1905 int bytes_remaining
;
1910 display
= FRAME_X_DISPLAY (selected_frame
);
1911 window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1913 max_bytes
= SELECTION_QUANTUM (display
);
1914 if (max_bytes
> MAX_SELECTION_QUANTUM
)
1915 max_bytes
= MAX_SELECTION_QUANTUM
;
1917 CHECK_CUT_BUFFER (buffer
, 0);
1918 CHECK_STRING (string
, 0);
1919 buffer_atom
= symbol_to_x_atom (display
, buffer
);
1920 data
= (unsigned char *) XSTRING (string
)->data
;
1921 bytes
= XSTRING (string
)->size
;
1922 bytes_remaining
= bytes
;
1924 if (! cut_buffers_initialized
) initialize_cut_buffers (display
, window
);
1928 /* Don't mess up with an empty value. */
1929 if (!bytes_remaining
)
1930 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1931 PropModeReplace
, data
, 0);
1933 while (bytes_remaining
)
1935 int chunk
= (bytes_remaining
< max_bytes
1936 ? bytes_remaining
: max_bytes
);
1937 XChangeProperty (display
, window
, buffer_atom
, XA_STRING
, 8,
1938 (bytes_remaining
== bytes
1943 bytes_remaining
-= chunk
;
1950 DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal
,
1951 Sx_rotate_cut_buffers_internal
, 1, 1, 0,
1952 "Rotate the values of the cut buffers by the given number of steps;\n\
1953 positive means move values forward, negative means backward.")
1962 display
= FRAME_X_DISPLAY (selected_frame
);
1963 window
= RootWindow (display
, 0); /* Cut buffers are on screen 0 */
1964 CHECK_NUMBER (n
, 0);
1967 if (! cut_buffers_initialized
)
1968 initialize_cut_buffers (display
, window
);
1970 props
[0] = XA_CUT_BUFFER0
;
1971 props
[1] = XA_CUT_BUFFER1
;
1972 props
[2] = XA_CUT_BUFFER2
;
1973 props
[3] = XA_CUT_BUFFER3
;
1974 props
[4] = XA_CUT_BUFFER4
;
1975 props
[5] = XA_CUT_BUFFER5
;
1976 props
[6] = XA_CUT_BUFFER6
;
1977 props
[7] = XA_CUT_BUFFER7
;
1979 XRotateWindowProperties (display
, window
, props
, 8, XINT (n
));
1987 Xatoms_of_xselect ()
1989 #define ATOM(x) XInternAtom (x_current_display, (x), False)
1992 /* Non-predefined atoms that we might end up using a lot */
1993 Xatom_CLIPBOARD
= ATOM ("CLIPBOARD");
1994 Xatom_TIMESTAMP
= ATOM ("TIMESTAMP");
1995 Xatom_TEXT
= ATOM ("TEXT");
1996 Xatom_DELETE
= ATOM ("DELETE");
1997 Xatom_MULTIPLE
= ATOM ("MULTIPLE");
1998 Xatom_INCR
= ATOM ("INCR");
1999 Xatom_EMACS_TMP
= ATOM ("_EMACS_TMP_");
2000 Xatom_TARGETS
= ATOM ("TARGETS");
2001 Xatom_NULL
= ATOM ("NULL");
2002 Xatom_ATOM_PAIR
= ATOM ("ATOM_PAIR");
2009 defsubr (&Sx_get_selection_internal
);
2010 defsubr (&Sx_own_selection_internal
);
2011 defsubr (&Sx_disown_selection_internal
);
2012 defsubr (&Sx_selection_owner_p
);
2013 defsubr (&Sx_selection_exists_p
);
2015 #ifdef CUT_BUFFER_SUPPORT
2016 defsubr (&Sx_get_cut_buffer_internal
);
2017 defsubr (&Sx_store_cut_buffer_internal
);
2018 defsubr (&Sx_rotate_cut_buffers_internal
);
2019 cut_buffers_initialized
= 0;
2022 reading_selection_reply
= Fcons (Qnil
, Qnil
);
2023 staticpro (&reading_selection_reply
);
2024 reading_selection_window
= 0;
2025 reading_which_selection
= 0;
2027 property_change_wait_list
= 0;
2028 prop_location_identifier
= 0;
2029 property_change_reply
= Fcons (Qnil
, Qnil
);
2030 staticpro (&property_change_reply
);
2032 Vselection_alist
= Qnil
;
2033 staticpro (&Vselection_alist
);
2035 DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist
,
2036 "An alist associating X Windows selection-types with functions.\n\
2037 These functions are called to convert the selection, with three args:\n\
2038 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
2039 a desired type to which the selection should be converted;\n\
2040 and the local selection value (whatever was given to `x-own-selection').\n\
2042 The function should return the value to send to the X server\n\
2043 \(typically a string). A return value of nil\n\
2044 means that the conversion could not be done.\n\
2045 A return value which is the symbol `NULL'\n\
2046 means that a side-effect was executed,\n\
2047 and there is no meaningful selection value.");
2048 Vselection_converter_alist
= Qnil
;
2050 DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks
,
2051 "A list of functions to be called when Emacs loses an X selection.\n\
2052 \(This happens when some other X client makes its own selection\n\
2053 or when a Lisp program explicitly clears the selection.)\n\
2054 The functions are called with one argument, the selection type\n\
2055 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.)");
2056 Vx_lost_selection_hooks
= Qnil
;
2058 DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks
,
2059 "A list of functions to be called when Emacs answers a selection request.\n\
2060 The functions are called with four arguments:\n\
2061 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
2062 - the selection-type which Emacs was asked to convert the\n\
2063 selection into before sending (for example, `STRING' or `LENGTH');\n\
2064 - a flag indicating success or failure for responding to the request.\n\
2065 We might have failed (and declined the request) for any number of reasons,\n\
2066 including being asked for a selection that we no longer own, or being asked\n\
2067 to convert into a type that we don't know about or that is inappropriate.\n\
2068 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
2069 it merely informs you that they have happened.");
2070 Vx_sent_selection_hooks
= Qnil
;
2072 DEFVAR_INT ("x-selection-timeout", &x_selection_timeout
,
2073 "Number of milliseconds to wait for a selection reply.\n\
2074 If the selection owner doens't reply in this time, we give up.\n\
2075 A value of 0 means wait as long as necessary. This is initialized from the\n\
2076 \"*selectionTimeout\" resource.");
2077 x_selection_timeout
= 0;
2079 QPRIMARY
= intern ("PRIMARY"); staticpro (&QPRIMARY
);
2080 QSECONDARY
= intern ("SECONDARY"); staticpro (&QSECONDARY
);
2081 QSTRING
= intern ("STRING"); staticpro (&QSTRING
);
2082 QINTEGER
= intern ("INTEGER"); staticpro (&QINTEGER
);
2083 QCLIPBOARD
= intern ("CLIPBOARD"); staticpro (&QCLIPBOARD
);
2084 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
2085 QTEXT
= intern ("TEXT"); staticpro (&QTEXT
);
2086 QTIMESTAMP
= intern ("TIMESTAMP"); staticpro (&QTIMESTAMP
);
2087 QDELETE
= intern ("DELETE"); staticpro (&QDELETE
);
2088 QMULTIPLE
= intern ("MULTIPLE"); staticpro (&QMULTIPLE
);
2089 QINCR
= intern ("INCR"); staticpro (&QINCR
);
2090 QEMACS_TMP
= intern ("_EMACS_TMP_"); staticpro (&QEMACS_TMP
);
2091 QTARGETS
= intern ("TARGETS"); staticpro (&QTARGETS
);
2092 QATOM
= intern ("ATOM"); staticpro (&QATOM
);
2093 QATOM_PAIR
= intern ("ATOM_PAIR"); staticpro (&QATOM_PAIR
);
2094 QNULL
= intern ("NULL"); staticpro (&QNULL
);
2096 #ifdef CUT_BUFFER_SUPPORT
2097 QCUT_BUFFER0
= intern ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0
);
2098 QCUT_BUFFER1
= intern ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1
);
2099 QCUT_BUFFER2
= intern ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2
);
2100 QCUT_BUFFER3
= intern ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3
);
2101 QCUT_BUFFER4
= intern ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4
);
2102 QCUT_BUFFER5
= intern ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5
);
2103 QCUT_BUFFER6
= intern ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6
);
2104 QCUT_BUFFER7
= intern ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7
);