Mercurial > hg > xemacs-beta

comparison src/select-gtk.c @ 462:0784d089fdc9 r21-2-46

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-46
author cvs
date Mon, 13 Aug 2007 11:44:37 +0200
parents
children 183866b06e0b
comparison
equal deleted inserted replaced
461:120ed4009e51 462:0784d089fdc9
1 /* GTK selection processing for XEmacs
2 Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
3
4 This file is part of XEmacs.
5
6 XEmacs is free software; you can redistribute it and/or modify it
7 under the terms of the GNU General Public License as published by the
8 Free Software Foundation; either version 2, or (at your option) any
9 later version.
10
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with XEmacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
20
21 /* Synched up with: Not synched with FSF. */
22
23 /* Authorship:
24
25 Written by Kevin Gallo for FSF Emacs.
26 Rewritten for mswindows by Jonathan Harris, December 1997 for 21.0.
27 Rewritten for GTK by William Perry, April 2000 for 21.1
28 */
29
30
31 #include <config.h>
32 #include "lisp.h"
33 #include "events.h"
34 #include "buffer.h"
35 #include "device.h"
36 #include "console-gtk.h"
37 #include "select.h"
38 #include "opaque.h"
39 #include "frame.h"
40
41 static Lisp_Object Vretrieved_selection;
42 static gboolean waiting_for_selection;
43 Lisp_Object Vgtk_sent_selection_hooks;
44
45 static Lisp_Object atom_to_symbol (struct device *d, GdkAtom atom);
46 static GdkAtom symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists);
47
48 static void lisp_data_to_selection_data (struct device *,
49 Lisp_Object obj,
50 unsigned char **data_ret,
51 GdkAtom *type_ret,
52 unsigned int *size_ret,
53 int *format_ret);
54 static Lisp_Object selection_data_to_lisp_data (struct device *,
55 Extbyte *data,
56 size_t size,
57 GdkAtom type,
58 int format);
59
60 /* Set the selection data to GDK_NONE and NULL data, meaning we were
61 ** unable to do what they wanted.
62 */
63 static void
64 gtk_decline_selection_request (GtkSelectionData *data)
65 {
66 gtk_selection_data_set (data, GDK_NONE, 0, NULL, 0);
67 }
68
69 /* Used as an unwind-protect clause so that, if a selection-converter signals
70 an error, we tell the requestor that we were unable to do what they wanted
71 before we throw to top-level or go into the debugger or whatever.
72 */
73 struct _selection_closure
74 {
75 GtkSelectionData *data;
76 gboolean successful;
77 };
78
79 static Lisp_Object
80 gtk_selection_request_lisp_error (Lisp_Object closure)
81 {
82 struct _selection_closure *cl = (struct _selection_closure *)
83 get_opaque_ptr (closure);
84
85 free_opaque_ptr (closure);
86 if (cl->successful == TRUE)
87 return Qnil;
88 gtk_decline_selection_request (cl->data);
89 return Qnil;
90 }
91
92 /* This provides the current selection to a requester.
93 **
94 ** This is connected to the selection_get() signal of the application
95 ** shell in device-gtk.c:gtk_init_device().
96 **
97 ** This is radically different than the old selection code (21.1.x),
98 ** but has been modeled after the X code, and appears to work.
99 **
100 ** WMP Feb 12 2001
101 */
102 void
103 emacs_gtk_selection_handle (GtkWidget *widget,
104 GtkSelectionData *selection_data,
105 guint info,
106 guint time_stamp,
107 gpointer data)
108 {
109 /* This function can GC */
110 struct gcpro gcpro1, gcpro2;
111 Lisp_Object temp_obj;
112 Lisp_Object selection_symbol;
113 Lisp_Object target_symbol = Qnil;
114 Lisp_Object converted_selection = Qnil;
115 guint32 local_selection_time;
116 Lisp_Object successful_p = Qnil;
117 int count;
118 struct device *d = decode_gtk_device (Qnil);
119 struct _selection_closure *cl = NULL;
120
121 GCPRO2 (converted_selection, target_symbol);
122
123 selection_symbol = atom_to_symbol (d, selection_data->selection);
124 target_symbol = atom_to_symbol (d, selection_data->target);
125
126 #if 0 /* #### MULTIPLE doesn't work yet */
127 if (EQ (target_symbol, QMULTIPLE))
128 target_symbol = fetch_multiple_target (selection_data);
129 #endif
130
131 temp_obj = Fget_selection_timestamp (selection_symbol);
132
133 if (NILP (temp_obj))
134 {
135 /* We don't appear to have the selection. */
136 gtk_decline_selection_request (selection_data);
137
138 goto DONE_LABEL;
139 }
140
141 local_selection_time = * (guint32 *) XOPAQUE_DATA (temp_obj);
142
143 if (time_stamp != GDK_CURRENT_TIME &&
144 local_selection_time > time_stamp)
145 {
146 /* Someone asked for the selection, and we have one, but not the one
147 they're looking for. */
148 gtk_decline_selection_request (selection_data);
149 goto DONE_LABEL;
150 }
151
152 converted_selection = select_convert_out (selection_symbol,
153 target_symbol, Qnil);
154
155 /* #### Is this the right thing to do? I'm no X expert. -- ajh */
156 if (NILP (converted_selection))
157 {
158 /* We don't appear to have a selection in that data type. */
159 gtk_decline_selection_request (selection_data);
160 goto DONE_LABEL;
161 }
162
163 count = specpdl_depth ();
164
165 cl = (struct _selection_closure *) xmalloc (sizeof (*cl));
166 cl->data = selection_data;
167 cl->successful = FALSE;
168
169 record_unwind_protect (gtk_selection_request_lisp_error,
170 make_opaque_ptr (cl));
171
172 {
173 unsigned char *data;
174 unsigned int size;
175 int format;
176 GdkAtom type;
177 lisp_data_to_selection_data (d, converted_selection,
178 &data, &type, &size, &format);
179
180 gtk_selection_data_set (selection_data, type, format, data, size);
181 successful_p = Qt;
182 /* Tell x_selection_request_lisp_error() it's cool. */
183 cl->successful = TRUE;
184 xfree (data);
185 }
186
187 unbind_to (count, Qnil);
188
189 DONE_LABEL:
190
191 if (cl) xfree (cl);
192
193 UNGCPRO;
194
195 /* Let random lisp code notice that the selection has been asked for. */
196 {
197 Lisp_Object val = Vgtk_sent_selection_hooks;
198 if (!UNBOUNDP (val) && !NILP (val))
199 {
200 Lisp_Object rest;
201 if (CONSP (val) && !EQ (XCAR (val), Qlambda))
202 for (rest = val; !NILP (rest); rest = Fcdr (rest))
203 call3 (Fcar (rest), selection_symbol, target_symbol, successful_p);
204 else
205 call3 (val, selection_symbol, target_symbol, successful_p);
206 }
207 }
208 }
209
210
211
212 static GtkWidget *reading_selection_reply;
213 static GdkAtom reading_which_selection;
214 static int selection_reply_timed_out;
215
216 /* Gets the current selection owned by another application */
217 void
218 emacs_gtk_selection_received (GtkWidget *widget,
219 GtkSelectionData *selection_data,
220 gpointer user_data)
221 {
222 waiting_for_selection = FALSE;
223 Vretrieved_selection = Qnil;
224
225 reading_selection_reply = NULL;
226
227 signal_fake_event ();
228
229 if (selection_data->length < 0)
230 {
231 return;
232 }
233
234 Vretrieved_selection =
235 selection_data_to_lisp_data (NULL,
236 selection_data->data,
237 selection_data->length,
238 selection_data->type,
239 selection_data->format);
240 }
241
242 static int
243 selection_reply_done (void *ignore)
244 {
245 return !reading_selection_reply;
246 }
247
248 /* Do protocol to read selection-data from the server.
249 Converts this to lisp data and returns it.
250 */
251 static Lisp_Object
252 gtk_get_foreign_selection (Lisp_Object selection_symbol,
253 Lisp_Object target_type)
254 {
255 /* This function can GC */
256 struct device *d = decode_gtk_device (Qnil);
257 GtkWidget *requestor = DEVICE_GTK_APP_SHELL (d);
258 guint32 requestor_time = DEVICE_GTK_MOUSE_TIMESTAMP (d);
259 GdkAtom selection_atom = symbol_to_gtk_atom (d, selection_symbol, 0);
260 int speccount;
261 GdkAtom type_atom = symbol_to_gtk_atom (d, (CONSP (target_type) ?
262 XCAR (target_type) : target_type), 0);
263
264 gtk_selection_convert (requestor, selection_atom, type_atom,
265 requestor_time);
266
267 signal_fake_event ();
268
269 /* Block until the reply has been read. */
270 reading_selection_reply = requestor;
271 reading_which_selection = selection_atom;
272 selection_reply_timed_out = 0;
273
274 speccount = specpdl_depth ();
275
276 #if 0
277 /* add a timeout handler */
278 if (gtk_selection_timeout > 0)
279 {
280 Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout),
281 Qx_selection_reply_timeout_internal,
282 Qnil, Qnil);
283 record_unwind_protect (Fdisable_timeout, id);
284 }
285 #endif
286
287 /* This is ^Gable */
288 wait_delaying_user_input (selection_reply_done, 0);
289
290 if (selection_reply_timed_out)
291 error ("timed out waiting for reply from selection owner");
292
293 unbind_to (speccount, Qnil);
294
295 /* otherwise, the selection is waiting for us on the requested property. */
296 return select_convert_in (selection_symbol,
297 target_type,
298 Vretrieved_selection);
299 }
300
301
302 #if 0
303 static void
304 gtk_get_window_property (struct device *d, GtkWidget *window, GdkAtom property,
305 Extbyte **data_ret, int *bytes_ret,
306 GdkAtom *actual_type_ret, int *actual_format_ret,
307 unsigned long *actual_size_ret, int delete_p)
308 {
309 size_t total_size;
310 unsigned long bytes_remaining;
311 int offset = 0;
312 unsigned char *tmp_data = 0;
313 int result;
314 int buffer_size = SELECTION_QUANTUM (display);
315 if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
316
317 /* First probe the thing to find out how big it is. */
318 result = XGetWindowProperty (display, window, property,
319 0, 0, False, AnyPropertyType,
320 actual_type_ret, actual_format_ret,
321 actual_size_ret,
322 &bytes_remaining, &tmp_data);
323 if (result != Success)
324 {
325 *data_ret = 0;
326 *bytes_ret = 0;
327 return;
328 }
329 XFree ((char *) tmp_data);
330
331 if (*actual_type_ret == None || *actual_format_ret == 0)
332 {
333 if (delete_p) XDeleteProperty (display, window, property);
334 *data_ret = 0;
335 *bytes_ret = 0;
336 return;
337 }
338
339 total_size = bytes_remaining + 1;
340 *data_ret = (Extbyte *) xmalloc (total_size);
341
342 /* Now read, until we've gotten it all. */
343 while (bytes_remaining)
344 {
345 #if 0
346 int last = bytes_remaining;
347 #endif
348 result =
349 XGetWindowProperty (display, window, property,
350 offset/4, buffer_size/4,
351 (delete_p ? True : False),
352 AnyPropertyType,
353 actual_type_ret, actual_format_ret,
354 actual_size_ret, &bytes_remaining, &tmp_data);
355 #if 0
356 stderr_out ("<< read %d\n", last-bytes_remaining);
357 #endif
358 /* If this doesn't return Success at this point, it means that
359 some clod deleted the selection while we were in the midst of
360 reading it. Deal with that, I guess....
361 */
362 if (result != Success) break;
363 *actual_size_ret *= *actual_format_ret / 8;
364 memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
365 offset += *actual_size_ret;
366 XFree ((char *) tmp_data);
367 }
368 *bytes_ret = offset;
369 }
370
371
372 static void
373 receive_incremental_selection (Display *display, Window window, Atom property,
374 /* this one is for error messages only */
375 Lisp_Object target_type,
376 unsigned int min_size_bytes,
377 Extbyte **data_ret, int *size_bytes_ret,
378 Atom *type_ret, int *format_ret,
379 unsigned long *size_ret)
380 {
381 /* This function can GC */
382 int offset = 0;
383 int prop_id;
384 *size_bytes_ret = min_size_bytes;
385 *data_ret = (Extbyte *) xmalloc (*size_bytes_ret);
386 #if 0
387 stderr_out ("\nread INCR %d\n", min_size_bytes);
388 #endif
389 /* At this point, we have read an INCR property, and deleted it (which
390 is how we ack its receipt: the sending window will be selecting
391 PropertyNotify events on our window to notice this).
392
393 Now, we must loop, waiting for the sending window to put a value on
394 that property, then reading the property, then deleting it to ack.
395 We are done when the sender places a property of length 0.
396 */
397 prop_id = expect_property_change (display, window, property,
398 PropertyNewValue);
399 while (1)
400 {
401 Extbyte *tmp_data;
402 int tmp_size_bytes;
403 wait_for_property_change (prop_id);
404 /* expect it again immediately, because x_get_window_property may
405 .. no it won't, I don't get it.
406 .. Ok, I get it now, the Xt code that implements INCR is broken.
407 */
408 prop_id = expect_property_change (display, window, property,
409 PropertyNewValue);
410 x_get_window_property (display, window, property,
411 &tmp_data, &tmp_size_bytes,
412 type_ret, format_ret, size_ret, 1);
413
414 if (tmp_size_bytes == 0) /* we're done */
415 {
416 #if 0
417 stderr_out (" read INCR done\n");
418 #endif
419 unexpect_property_change (prop_id);
420 if (tmp_data) xfree (tmp_data);
421 break;
422 }
423 #if 0
424 stderr_out (" read INCR %d\n", tmp_size_bytes);
425 #endif
426 if (*size_bytes_ret < offset + tmp_size_bytes)
427 {
428 #if 0
429 stderr_out (" read INCR realloc %d -> %d\n",
430 *size_bytes_ret, offset + tmp_size_bytes);
431 #endif
432 *size_bytes_ret = offset + tmp_size_bytes;
433 *data_ret = (Extbyte *) xrealloc (*data_ret, *size_bytes_ret);
434 }
435 memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
436 offset += tmp_size_bytes;
437 xfree (tmp_data);
438 }
439 }
440
441
442 static Lisp_Object
443 gtk_get_window_property_as_lisp_data (struct device *d,
444 GtkWidget *window,
445 GdkAtom property,
446 /* next two for error messages only */
447 Lisp_Object target_type,
448 GdkAtom selection_atom)
449 {
450 /* This function can GC */
451 Atom actual_type;
452 int actual_format;
453 unsigned long actual_size;
454 Extbyte *data = NULL;
455 int bytes = 0;
456 Lisp_Object val;
457 struct device *d = get_device_from_display (display);
458
459 x_get_window_property (display, window, property, &data, &bytes,
460 &actual_type, &actual_format, &actual_size, 1);
461 if (! data)
462 {
463 if (XGetSelectionOwner (display, selection_atom))
464 /* there is a selection owner */
465 signal_error
466 (Qselection_conversion_error,
467 Fcons (build_string ("selection owner couldn't convert"),
468 Fcons (x_atom_to_symbol (d, selection_atom),
469 actual_type ?
470 list2 (target_type, x_atom_to_symbol (d, actual_type)) :
471 list1 (target_type))));
472 else
473 signal_error (Qerror,
474 list2 (build_string ("no selection"),
475 x_atom_to_symbol (d, selection_atom)));
476 }
477
478 if (actual_type == DEVICE_XATOM_INCR (d))
479 {
480 /* Ok, that data wasn't *the* data, it was just the beginning. */
481
482 unsigned int min_size_bytes = * ((unsigned int *) data);
483 xfree (data);
484 receive_incremental_selection (display, window, property, target_type,
485 min_size_bytes, &data, &bytes,
486 &actual_type, &actual_format,
487 &actual_size);
488 }
489
490 /* It's been read. Now convert it to a lisp object in some semi-rational
491 manner. */
492 val = selection_data_to_lisp_data (d, data, bytes,
493 actual_type, actual_format);
494
495 xfree (data);
496 return val;
497 }
498 #endif
499
500
501 static GdkAtom
502 symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists)
503 {
504 if (NILP (sym)) return GDK_SELECTION_PRIMARY;
505 if (EQ (sym, Qt)) return GDK_SELECTION_SECONDARY;
506 if (EQ (sym, QPRIMARY)) return GDK_SELECTION_PRIMARY;
507 if (EQ (sym, QSECONDARY)) return GDK_SELECTION_SECONDARY;
508
509 {
510 const char *nameext;
511 LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), nameext, Qctext);
512 return gdk_atom_intern (nameext, only_if_exists ? TRUE : FALSE);
513 }
514 }
515
516 static Lisp_Object
517 atom_to_symbol (struct device *d, GdkAtom atom)
518 {
519 if (atom == GDK_SELECTION_PRIMARY) return (QPRIMARY);
520 if (atom == GDK_SELECTION_SECONDARY) return (QSECONDARY);
521
522 {
523 char *intstr;
524 char *str = gdk_atom_name (atom);
525
526 if (! str) return Qnil;
527
528 TO_INTERNAL_FORMAT (C_STRING, str,
529 C_STRING_ALLOCA, intstr,
530 Qctext);
531 g_free (str);
532 return intern (intstr);
533 }
534 }
535
536 /* #### These are going to move into Lisp code(!) with the aid of
537 some new functions I'm working on - ajh */
538
539 /* These functions convert from the selection data read from the server into
540 something that we can use from elisp, and vice versa.
541
542 Type: Format: Size: Elisp Type:
543 ----- ------- ----- -----------
544 * 8 * String
545 ATOM 32 1 Symbol
546 ATOM 32 > 1 Vector of Symbols
547 * 16 1 Integer
548 * 16 > 1 Vector of Integers
549 * 32 1 if <=16 bits: Integer
550 if > 16 bits: Cons of top16, bot16
551 * 32 > 1 Vector of the above
552
553 When converting a Lisp number to C, it is assumed to be of format 16 if
554 it is an integer, and of format 32 if it is a cons of two integers.
555
556 When converting a vector of numbers from Elisp to C, it is assumed to be
557 of format 16 if every element in the vector is an integer, and is assumed
558 to be of format 32 if any element is a cons of two integers.
559
560 When converting an object to C, it may be of the form (SYMBOL . <data>)
561 where SYMBOL is what we should claim that the type is. Format and
562 representation are as above.
563
564 NOTE: Under Mule, when someone shoves us a string without a type, we
565 set the type to 'COMPOUND_TEXT and automatically convert to Compound
566 Text. If the string has a type, we assume that the user wants the
567 data sent as-is so we just do "binary" conversion.
568 */
569
570
571 static Lisp_Object
572 selection_data_to_lisp_data (struct device *d,
573 Extbyte *data,
574 size_t size,
575 GdkAtom type,
576 int format)
577 {
578 if (type == gdk_atom_intern ("NULL", 0))
579 return QNULL;
580
581 /* Convert any 8-bit data to a string, for compactness. */
582 else if (format == 8)
583 return make_ext_string (data, size,
584 ((type == gdk_atom_intern ("TEXT", FALSE)) ||
585 (type == gdk_atom_intern ("COMPOUND_TEXT", FALSE)))
586 ? Qctext : Qbinary);
587
588 /* Convert a single atom to a Lisp Symbol.
589 Convert a set of atoms to a vector of symbols. */
590 else if (type == gdk_atom_intern ("ATOM", FALSE))
591 {
592 if (size == sizeof (GdkAtom))
593 return atom_to_symbol (d, *((GdkAtom *) data));
594 else
595 {
596 int i;
597 int len = size / sizeof (GdkAtom);
598 Lisp_Object v = Fmake_vector (make_int (len), Qzero);
599 for (i = 0; i < len; i++)
600 Faset (v, make_int (i), atom_to_symbol (d, ((GdkAtom *) data) [i]));
601 return v;
602 }
603 }
604
605 /* Convert a single 16 or small 32 bit number to a Lisp Int.
606 If the number is > 16 bits, convert it to a cons of integers,
607 16 bits in each half.
608 */
609 else if (format == 32 && size == sizeof (long))
610 return word_to_lisp (((unsigned long *) data) [0]);
611 else if (format == 16 && size == sizeof (short))
612 return make_int ((int) (((unsigned short *) data) [0]));
613
614 /* Convert any other kind of data to a vector of numbers, represented
615 as above (as an integer, or a cons of two 16 bit integers).
616
617 #### Perhaps we should return the actual type to lisp as well.
618
619 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
620 ==> [4 4]
621
622 and perhaps it should be
623
624 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
625 ==> (SPAN . [4 4])
626
627 Right now the fact that the return type was SPAN is discarded before
628 lisp code gets to see it.
629 */
630 else if (format == 16)
631 {
632 int i;
633 Lisp_Object v = make_vector (size / 4, Qzero);
634 for (i = 0; i < (int) size / 4; i++)
635 {
636 int j = (int) ((unsigned short *) data) [i];
637 Faset (v, make_int (i), make_int (j));
638 }
639 return v;
640 }
641 else
642 {
643 int i;
644 Lisp_Object v = make_vector (size / 4, Qzero);
645 for (i = 0; i < (int) size / 4; i++)
646 {
647 unsigned long j = ((unsigned long *) data) [i];
648 Faset (v, make_int (i), word_to_lisp (j));
649 }
650 return v;
651 }
652 }
653
654
655 static void
656 lisp_data_to_selection_data (struct device *d,
657 Lisp_Object obj,
658 unsigned char **data_ret,
659 GdkAtom *type_ret,
660 unsigned int *size_ret,
661 int *format_ret)
662 {
663 Lisp_Object type = Qnil;
664
665 if (CONSP (obj) && SYMBOLP (XCAR (obj)))
666 {
667 type = XCAR (obj);
668 obj = XCDR (obj);
669 if (CONSP (obj) && NILP (XCDR (obj)))
670 obj = XCAR (obj);
671 }
672
673 if (EQ (obj, QNULL) || (EQ (type, QNULL)))
674 { /* This is not the same as declining */
675 *format_ret = 32;
676 *size_ret = 0;
677 *data_ret = 0;
678 type = QNULL;
679 }
680 else if (STRINGP (obj))
681 {
682 const Extbyte *extval;
683 Extcount extvallen;
684
685 TO_EXTERNAL_FORMAT (LISP_STRING, obj,
686 ALLOCA, (extval, extvallen),
687 (NILP (type) ? Qctext : Qbinary));
688 *format_ret = 8;
689 *size_ret = extvallen;
690 *data_ret = (unsigned char *) xmalloc (*size_ret);
691 memcpy (*data_ret, extval, *size_ret);
692 #ifdef MULE
693 if (NILP (type)) type = QCOMPOUND_TEXT;
694 #else
695 if (NILP (type)) type = QSTRING;
696 #endif
697 }
698 else if (CHARP (obj))
699 {
700 Bufbyte buf[MAX_EMCHAR_LEN];
701 Bytecount len;
702 const Extbyte *extval;
703 Extcount extvallen;
704
705 *format_ret = 8;
706 len = set_charptr_emchar (buf, XCHAR (obj));
707 TO_EXTERNAL_FORMAT (DATA, (buf, len),
708 ALLOCA, (extval, extvallen),
709 Qctext);
710 *size_ret = extvallen;
711 *data_ret = (unsigned char *) xmalloc (*size_ret);
712 memcpy (*data_ret, extval, *size_ret);
713 #ifdef MULE
714 if (NILP (type)) type = QCOMPOUND_TEXT;
715 #else
716 if (NILP (type)) type = QSTRING;
717 #endif
718 }
719 else if (SYMBOLP (obj))
720 {
721 *format_ret = 32;
722 *size_ret = 1;
723 *data_ret = (unsigned char *) xmalloc (sizeof (GdkAtom) + 1);
724 (*data_ret) [sizeof (GdkAtom)] = 0;
725 (*(GdkAtom **) data_ret) [0] = symbol_to_gtk_atom (d, obj, 0);
726 if (NILP (type)) type = QATOM;
727 }
728 else if (INTP (obj) &&
729 XINT (obj) <= 0x7FFF &&
730 XINT (obj) >= -0x8000)
731 {
732 *format_ret = 16;
733 *size_ret = 1;
734 *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
735 (*data_ret) [sizeof (short)] = 0;
736 (*(short **) data_ret) [0] = (short) XINT (obj);
737 if (NILP (type)) type = QINTEGER;
738 }
739 else if (INTP (obj) || CONSP (obj))
740 {
741 *format_ret = 32;
742 *size_ret = 1;
743 *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
744 (*data_ret) [sizeof (long)] = 0;
745 (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
746 if (NILP (type)) type = QINTEGER;
747 }
748 else if (VECTORP (obj))
749 {
750 /* Lisp Vectors may represent a set of ATOMs;
751 a set of 16 or 32 bit INTEGERs;
752 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
753 */
754 int i;
755
756 if (SYMBOLP (XVECTOR_DATA (obj) [0]))
757 /* This vector is an ATOM set */
758 {
759 if (NILP (type)) type = QATOM;
760 *size_ret = XVECTOR_LENGTH (obj);
761 *format_ret = 32;
762 *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (GdkAtom));
763 for (i = 0; i < (int) (*size_ret); i++)
764 if (SYMBOLP (XVECTOR_DATA (obj) [i]))
765 (*(GdkAtom **) data_ret) [i] =
766 symbol_to_gtk_atom (d, XVECTOR_DATA (obj) [i], 0);
767 else
768 signal_error (Qerror, /* Qselection_error */
769 list2 (build_string
770 ("all elements of the vector must be of the same type"),
771 obj));
772 }
773 #if 0 /* #### MULTIPLE doesn't work yet */
774 else if (VECTORP (XVECTOR_DATA (obj) [0]))
775 /* This vector is an ATOM_PAIR set */
776 {
777 if (NILP (type)) type = QATOM_PAIR;
778 *size_ret = XVECTOR_LENGTH (obj);
779 *format_ret = 32;
780 *data_ret = (unsigned char *)
781 xmalloc ((*size_ret) * sizeof (Atom) * 2);
782 for (i = 0; i < *size_ret; i++)
783 if (VECTORP (XVECTOR_DATA (obj) [i]))
784 {
785 Lisp_Object pair = XVECTOR_DATA (obj) [i];
786 if (XVECTOR_LENGTH (pair) != 2)
787 signal_error (Qerror,
788 list2 (build_string
789 ("elements of the vector must be vectors of exactly two elements"),
790 pair));
791
792 (*(GdkAtom **) data_ret) [i * 2] =
793 symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [0], 0);
794 (*(GdkAtom **) data_ret) [(i * 2) + 1] =
795 symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [1], 0);
796 }
797 else
798 signal_error (Qerror,
799 list2 (build_string
800 ("all elements of the vector must be of the same type"),
801 obj));
802 }
803 #endif
804 else
805 /* This vector is an INTEGER set, or something like it */
806 {
807 *size_ret = XVECTOR_LENGTH (obj);
808 if (NILP (type)) type = QINTEGER;
809 *format_ret = 16;
810 for (i = 0; i < (int) (*size_ret); i++)
811 if (CONSP (XVECTOR_DATA (obj) [i]))
812 *format_ret = 32;
813 else if (!INTP (XVECTOR_DATA (obj) [i]))
814 signal_error (Qerror, /* Qselection_error */
815 list2 (build_string
816 ("all elements of the vector must be integers or conses of integers"),
817 obj));
818
819 *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
820 for (i = 0; i < (int) (*size_ret); i++)
821 if (*format_ret == 32)
822 (*((unsigned long **) data_ret)) [i] =
823 lisp_to_word (XVECTOR_DATA (obj) [i]);
824 else
825 (*((unsigned short **) data_ret)) [i] =
826 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
827 }
828 }
829 else
830 signal_error (Qerror, /* Qselection_error */
831 list2 (build_string ("unrecognized selection data"),
832 obj));
833
834 *type_ret = symbol_to_gtk_atom (d, type, 0);
835 }
836
837
838
839 static Lisp_Object
840 gtk_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
841 Lisp_Object how_to_add, Lisp_Object selection_type)
842 {
843 struct device *d = decode_gtk_device (Qnil);
844 GtkWidget *selecting_window = GTK_WIDGET (DEVICE_GTK_APP_SHELL (d));
845 Lisp_Object selection_time;
846 /* Use the time of the last-read mouse or keyboard event.
847 For selection purposes, we use this as a sleazy way of knowing what the
848 current time is in server-time. This assumes that the most recently read
849 mouse or keyboard event has something to do with the assertion of the
850 selection, which is probably true.
851 */
852 guint32 thyme = DEVICE_GTK_MOUSE_TIMESTAMP (d);
853 GdkAtom selection_atom;
854
855 CHECK_SYMBOL (selection_name);
856 selection_atom = symbol_to_gtk_atom (d, selection_name, 0);
857
858 gtk_selection_owner_set (selecting_window,
859 selection_atom,
860 thyme);
861
862 /* We do NOT use time_to_lisp() here any more, like we used to.
863 That assumed equivalence of time_t and Time, which is not
864 necessarily the case (e.g. under OSF on the Alphas, where
865 Time is a 64-bit quantity and time_t is a 32-bit quantity).
866
867 Opaque pointers are the clean way to go here.
868 */
869 selection_time = make_opaque (&thyme, sizeof (thyme));
870
871 return selection_time;
872 }
873
874 static void
875 gtk_disown_selection (Lisp_Object selection, Lisp_Object timeval)
876 {
877 struct device *d = decode_gtk_device (Qnil);
878 GdkAtom selection_atom;
879 guint32 timestamp;
880
881 CHECK_SYMBOL (selection);
882 selection_atom = symbol_to_gtk_atom (d, selection, 0);
883
884 if (NILP (timeval))
885 timestamp = DEVICE_GTK_MOUSE_TIMESTAMP (d);
886 else
887 {
888 time_t the_time;
889 lisp_to_time (timeval, &the_time);
890 timestamp = (guint32) the_time;
891 }
892
893 gtk_selection_owner_set (NULL, selection_atom, timestamp);
894 }
895
896 static Lisp_Object
897 gtk_selection_exists_p (Lisp_Object selection,
898 Lisp_Object selection_type)
899 {
900 struct device *d = decode_gtk_device (Qnil);
901
902 return (gdk_selection_owner_get (symbol_to_gtk_atom (d, selection, 0)) ? Qt : Qnil);
903 }
904
905
906
907 /************************************************************************/
908 /* initialization */
909 /************************************************************************/
910
911 void
912 syms_of_select_gtk (void)
913 {
914 }
915
916 void
917 console_type_create_select_gtk (void)
918 {
919 CONSOLE_HAS_METHOD (gtk, own_selection);
920 CONSOLE_HAS_METHOD (gtk, disown_selection);
921 CONSOLE_HAS_METHOD (gtk, selection_exists_p);
922 CONSOLE_HAS_METHOD (gtk, get_foreign_selection);
923 }
924
925 void
926 vars_of_select_gtk (void)
927 {
928 staticpro (&Vretrieved_selection);
929 Vretrieved_selection = Qnil;
930
931 DEFVAR_LISP ("gtk-sent-selection-hooks", &Vgtk_sent_selection_hooks /*
932 A function or functions to be called after we have responded to some
933 other client's request for the value of a selection that we own. The
934 function(s) will be called with four arguments:
935 - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);
936 - the name of the selection-type which we were requested to convert the
937 selection into before sending (for example, STRING or LENGTH);
938 - and whether we successfully transmitted the selection.
939 We might have failed (and declined the request) for any number of reasons,
940 including being asked for a selection that we no longer own, or being asked
941 to convert into a type that we don't know about or that is inappropriate.
942 This hook doesn't let you change the behavior of emacs's selection replies,
943 it merely informs you that they have happened.
944 */ );
945 Vgtk_sent_selection_hooks = Qunbound;
946 }