Mercurial > hg > xemacs-beta

comparison src/select-gtk.c @ 647:b39c14581166

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-08-13 04:45:47 by ben] removal of unsigned, size_t, etc.
author ben
date Mon, 13 Aug 2001 04:46:48 +0000
parents 183866b06e0b
children fdefd0186b75
comparison
equal deleted inserted replaced
646:00c54252fe4f 647:b39c14581166
40 40
41 static Lisp_Object Vretrieved_selection; 41 static Lisp_Object Vretrieved_selection;
42 static gboolean waiting_for_selection; 42 static gboolean waiting_for_selection;
43 Lisp_Object Vgtk_sent_selection_hooks; 43 Lisp_Object Vgtk_sent_selection_hooks;
44 44
45 static Lisp_Object atom_to_symbol (struct device *d, GdkAtom atom); 45 static GdkAtom
46 static GdkAtom symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists); 46 symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists)
47 47 {
48 static void lisp_data_to_selection_data (struct device *, 48 if (NILP (sym)) return GDK_SELECTION_PRIMARY;
49 Lisp_Object obj, 49 if (EQ (sym, Qt)) return GDK_SELECTION_SECONDARY;
50 unsigned char **data_ret, 50 if (EQ (sym, QPRIMARY)) return GDK_SELECTION_PRIMARY;
51 GdkAtom *type_ret, 51 if (EQ (sym, QSECONDARY)) return GDK_SELECTION_SECONDARY;
52 unsigned int *size_ret, 52
53 int *format_ret); 53 {
54 static Lisp_Object selection_data_to_lisp_data (struct device *, 54 const Extbyte *nameext;
55 Extbyte *data, 55 LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), nameext, Qctext);
56 size_t size, 56 return gdk_atom_intern (nameext, only_if_exists ? TRUE : FALSE);
57 GdkAtom type, 57 }
58 int format); 58 }
59 59
60 static Lisp_Object
61 atom_to_symbol (struct device *d, GdkAtom atom)
62 {
63 if (atom == GDK_SELECTION_PRIMARY) return (QPRIMARY);
64 if (atom == GDK_SELECTION_SECONDARY) return (QSECONDARY);
65
66 {
67 CBufbyte *intstr;
68 Extbyte *str = gdk_atom_name (atom);
69
70 if (! str) return Qnil;
71
72 TO_INTERNAL_FORMAT (C_STRING, str,
73 C_STRING_ALLOCA, intstr,
74 Qctext);
75 g_free (str);
76 return intern (intstr);
77 }
78 }
79
80 #define PROCESSING_GTK_CODE
81 #include "select-common.h"
82 #undef PROCESSING_GTK_CODE
83
84
60 /* Set the selection data to GDK_NONE and NULL data, meaning we were 85 /* Set the selection data to GDK_NONE and NULL data, meaning we were
61 ** unable to do what they wanted. 86 ** unable to do what they wanted.
62 */ 87 */
63 static void 88 static void
64 gtk_decline_selection_request (GtkSelectionData *data) 89 gtk_decline_selection_request (GtkSelectionData *data)
168 193
169 record_unwind_protect (gtk_selection_request_lisp_error, 194 record_unwind_protect (gtk_selection_request_lisp_error,
170 make_opaque_ptr (cl)); 195 make_opaque_ptr (cl));
171 196
172 { 197 {
173 unsigned char *data; 198 UChar_Binary *data;
174 unsigned int size; 199 Memory_Count size;
175 int format; 200 int format;
176 GdkAtom type; 201 GdkAtom type;
177 lisp_data_to_selection_data (d, converted_selection, 202 lisp_data_to_selection_data (d, converted_selection,
178 &data, &type, &size, &format); 203 &data, &type, &size, &format);
179 204
180 gtk_selection_data_set (selection_data, type, format, data, size); 205 gtk_selection_data_set (selection_data, type, format, data,
206 /* #### is this right? */
207 (unsigned int) size);
181 successful_p = Qt; 208 successful_p = Qt;
182 /* Tell x_selection_request_lisp_error() it's cool. */ 209 /* Tell x_selection_request_lisp_error() it's cool. */
183 cl->successful = TRUE; 210 cl->successful = TRUE;
184 xfree (data); 211 xfree (data);
185 } 212 }
304 gtk_get_window_property (struct device *d, GtkWidget *window, GdkAtom property, 331 gtk_get_window_property (struct device *d, GtkWidget *window, GdkAtom property,
305 Extbyte **data_ret, int *bytes_ret, 332 Extbyte **data_ret, int *bytes_ret,
306 GdkAtom *actual_type_ret, int *actual_format_ret, 333 GdkAtom *actual_type_ret, int *actual_format_ret,
307 unsigned long *actual_size_ret, int delete_p) 334 unsigned long *actual_size_ret, int delete_p)
308 { 335 {
309 size_t total_size; 336 /* deleted */
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 } 337 }
370 338
371 339
372 static void 340 static void
373 receive_incremental_selection (Display *display, Window window, Atom property, 341 receive_incremental_selection (Display *display, Window window, Atom property,
376 unsigned int min_size_bytes, 344 unsigned int min_size_bytes,
377 Extbyte **data_ret, int *size_bytes_ret, 345 Extbyte **data_ret, int *size_bytes_ret,
378 Atom *type_ret, int *format_ret, 346 Atom *type_ret, int *format_ret,
379 unsigned long *size_ret) 347 unsigned long *size_ret)
380 { 348 {
381 /* This function can GC */ 349 /* deleted */
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 } 350 }
440 351
441 352
442 static Lisp_Object 353 static Lisp_Object
443 gtk_get_window_property_as_lisp_data (struct device *d, 354 gtk_get_window_property_as_lisp_data (struct device *d,
445 GdkAtom property, 356 GdkAtom property,
446 /* next two for error messages only */ 357 /* next two for error messages only */
447 Lisp_Object target_type, 358 Lisp_Object target_type,
448 GdkAtom selection_atom) 359 GdkAtom selection_atom)
449 { 360 {
450 /* This function can GC */ 361 /* deleted */
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 (Qselection_conversion_error,
466 "selection owner couldn't convert",
467 Fcons (Qunbound,
468 Fcons (x_atom_to_symbol (d, selection_atom),
469 actual_type ?
470 list2 (target_type,
471 x_atom_to_symbol (d, actual_type)) :
472 list1 (target_type))));
473 else
474 signal_error (Qselection_conversion_error,
475 "no selection",
476 x_atom_to_symbol (d, selection_atom));
477 }
478
479 if (actual_type == DEVICE_XATOM_INCR (d))
480 {
481 /* Ok, that data wasn't *the* data, it was just the beginning. */
482
483 unsigned int min_size_bytes = * ((unsigned int *) data);
484 xfree (data);
485 receive_incremental_selection (display, window, property, target_type,
486 min_size_bytes, &data, &bytes,
487 &actual_type, &actual_format,
488 &actual_size);
489 }
490
491 /* It's been read. Now convert it to a lisp object in some semi-rational
492 manner. */
493 val = selection_data_to_lisp_data (d, data, bytes,
494 actual_type, actual_format);
495
496 xfree (data);
497 return val;
498 } 362 }
499 #endif 363 #endif
500
501
502 static GdkAtom
503 symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists)
504 {
505 if (NILP (sym)) return GDK_SELECTION_PRIMARY;
506 if (EQ (sym, Qt)) return GDK_SELECTION_SECONDARY;
507 if (EQ (sym, QPRIMARY)) return GDK_SELECTION_PRIMARY;
508 if (EQ (sym, QSECONDARY)) return GDK_SELECTION_SECONDARY;
509
510 {
511 const char *nameext;
512 LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), nameext, Qctext);
513 return gdk_atom_intern (nameext, only_if_exists ? TRUE : FALSE);
514 }
515 }
516
517 static Lisp_Object
518 atom_to_symbol (struct device *d, GdkAtom atom)
519 {
520 if (atom == GDK_SELECTION_PRIMARY) return (QPRIMARY);
521 if (atom == GDK_SELECTION_SECONDARY) return (QSECONDARY);
522
523 {
524 char *intstr;
525 char *str = gdk_atom_name (atom);
526
527 if (! str) return Qnil;
528
529 TO_INTERNAL_FORMAT (C_STRING, str,
530 C_STRING_ALLOCA, intstr,
531 Qctext);
532 g_free (str);
533 return intern (intstr);
534 }
535 }
536
537 /* #### These are going to move into Lisp code(!) with the aid of
538 some new functions I'm working on - ajh */
539
540 /* These functions convert from the selection data read from the server into
541 something that we can use from elisp, and vice versa.
542
543 Type: Format: Size: Elisp Type:
544 ----- ------- ----- -----------
545 * 8 * String
546 ATOM 32 1 Symbol
547 ATOM 32 > 1 Vector of Symbols
548 * 16 1 Integer
549 * 16 > 1 Vector of Integers
550 * 32 1 if <=16 bits: Integer
551 if > 16 bits: Cons of top16, bot16
552 * 32 > 1 Vector of the above
553
554 When converting a Lisp number to C, it is assumed to be of format 16 if
555 it is an integer, and of format 32 if it is a cons of two integers.
556
557 When converting a vector of numbers from Elisp to C, it is assumed to be
558 of format 16 if every element in the vector is an integer, and is assumed
559 to be of format 32 if any element is a cons of two integers.
560
561 When converting an object to C, it may be of the form (SYMBOL . <data>)
562 where SYMBOL is what we should claim that the type is. Format and
563 representation are as above.
564
565 NOTE: Under Mule, when someone shoves us a string without a type, we
566 set the type to 'COMPOUND_TEXT and automatically convert to Compound
567 Text. If the string has a type, we assume that the user wants the
568 data sent as-is so we just do "binary" conversion.
569 */
570
571
572 static Lisp_Object
573 selection_data_to_lisp_data (struct device *d,
574 Extbyte *data,
575 size_t size,
576 GdkAtom type,
577 int format)
578 {
579 if (type == gdk_atom_intern ("NULL", 0))
580 return QNULL;
581
582 /* Convert any 8-bit data to a string, for compactness. */
583 else if (format == 8)
584 return make_ext_string (data, size,
585 ((type == gdk_atom_intern ("TEXT", FALSE)) ||
586 (type == gdk_atom_intern ("COMPOUND_TEXT", FALSE)))
587 ? Qctext : Qbinary);
588
589 /* Convert a single atom to a Lisp Symbol.
590 Convert a set of atoms to a vector of symbols. */
591 else if (type == gdk_atom_intern ("ATOM", FALSE))
592 {
593 if (size == sizeof (GdkAtom))
594 return atom_to_symbol (d, *((GdkAtom *) data));
595 else
596 {
597 int i;
598 int len = size / sizeof (GdkAtom);
599 Lisp_Object v = Fmake_vector (make_int (len), Qzero);
600 for (i = 0; i < len; i++)
601 Faset (v, make_int (i), atom_to_symbol (d, ((GdkAtom *) data) [i]));
602 return v;
603 }
604 }
605
606 /* Convert a single 16 or small 32 bit number to a Lisp Int.
607 If the number is > 16 bits, convert it to a cons of integers,
608 16 bits in each half.
609 */
610 else if (format == 32 && size == sizeof (long))
611 return word_to_lisp (((unsigned long *) data) [0]);
612 else if (format == 16 && size == sizeof (short))
613 return make_int ((int) (((unsigned short *) data) [0]));
614
615 /* Convert any other kind of data to a vector of numbers, represented
616 as above (as an integer, or a cons of two 16 bit integers).
617
618 #### Perhaps we should return the actual type to lisp as well.
619
620 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
621 ==> [4 4]
622
623 and perhaps it should be
624
625 (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
626 ==> (SPAN . [4 4])
627
628 Right now the fact that the return type was SPAN is discarded before
629 lisp code gets to see it.
630 */
631 else if (format == 16)
632 {
633 int i;
634 Lisp_Object v = make_vector (size / 4, Qzero);
635 for (i = 0; i < (int) size / 4; i++)
636 {
637 int j = (int) ((unsigned short *) data) [i];
638 Faset (v, make_int (i), make_int (j));
639 }
640 return v;
641 }
642 else
643 {
644 int i;
645 Lisp_Object v = make_vector (size / 4, Qzero);
646 for (i = 0; i < (int) size / 4; i++)
647 {
648 unsigned long j = ((unsigned long *) data) [i];
649 Faset (v, make_int (i), word_to_lisp (j));
650 }
651 return v;
652 }
653 }
654
655
656 static void
657 lisp_data_to_selection_data (struct device *d,
658 Lisp_Object obj,
659 unsigned char **data_ret,
660 GdkAtom *type_ret,
661 unsigned int *size_ret,
662 int *format_ret)
663 {
664 Lisp_Object type = Qnil;
665
666 if (CONSP (obj) && SYMBOLP (XCAR (obj)))
667 {
668 type = XCAR (obj);
669 obj = XCDR (obj);
670 if (CONSP (obj) && NILP (XCDR (obj)))
671 obj = XCAR (obj);
672 }
673
674 if (EQ (obj, QNULL) || (EQ (type, QNULL)))
675 { /* This is not the same as declining */
676 *format_ret = 32;
677 *size_ret = 0;
678 *data_ret = 0;
679 type = QNULL;
680 }
681 else if (STRINGP (obj))
682 {
683 const Extbyte *extval;
684 Extcount extvallen;
685
686 TO_EXTERNAL_FORMAT (LISP_STRING, obj,
687 ALLOCA, (extval, extvallen),
688 (NILP (type) ? Qctext : Qbinary));
689 *format_ret = 8;
690 *size_ret = extvallen;
691 *data_ret = (unsigned char *) xmalloc (*size_ret);
692 memcpy (*data_ret, extval, *size_ret);
693 #ifdef MULE
694 if (NILP (type)) type = QCOMPOUND_TEXT;
695 #else
696 if (NILP (type)) type = QSTRING;
697 #endif
698 }
699 else if (CHARP (obj))
700 {
701 Bufbyte buf[MAX_EMCHAR_LEN];
702 Bytecount len;
703 const Extbyte *extval;
704 Extcount extvallen;
705
706 *format_ret = 8;
707 len = set_charptr_emchar (buf, XCHAR (obj));
708 TO_EXTERNAL_FORMAT (DATA, (buf, len),
709 ALLOCA, (extval, extvallen),
710 Qctext);
711 *size_ret = extvallen;
712 *data_ret = (unsigned char *) xmalloc (*size_ret);
713 memcpy (*data_ret, extval, *size_ret);
714 #ifdef MULE
715 if (NILP (type)) type = QCOMPOUND_TEXT;
716 #else
717 if (NILP (type)) type = QSTRING;
718 #endif
719 }
720 else if (SYMBOLP (obj))
721 {
722 *format_ret = 32;
723 *size_ret = 1;
724 *data_ret = (unsigned char *) xmalloc (sizeof (GdkAtom) + 1);
725 (*data_ret) [sizeof (GdkAtom)] = 0;
726 (*(GdkAtom **) data_ret) [0] = symbol_to_gtk_atom (d, obj, 0);
727 if (NILP (type)) type = QATOM;
728 }
729 else if (INTP (obj) &&
730 XINT (obj) <= 0x7FFF &&
731 XINT (obj) >= -0x8000)
732 {
733 *format_ret = 16;
734 *size_ret = 1;
735 *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
736 (*data_ret) [sizeof (short)] = 0;
737 (*(short **) data_ret) [0] = (short) XINT (obj);
738 if (NILP (type)) type = QINTEGER;
739 }
740 else if (INTP (obj) || CONSP (obj))
741 {
742 *format_ret = 32;
743 *size_ret = 1;
744 *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
745 (*data_ret) [sizeof (long)] = 0;
746 (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
747 if (NILP (type)) type = QINTEGER;
748 }
749 else if (VECTORP (obj))
750 {
751 /* Lisp Vectors may represent a set of ATOMs;
752 a set of 16 or 32 bit INTEGERs;
753 or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
754 */
755 int i;
756
757 if (SYMBOLP (XVECTOR_DATA (obj) [0]))
758 /* This vector is an ATOM set */
759 {
760 if (NILP (type)) type = QATOM;
761 *size_ret = XVECTOR_LENGTH (obj);
762 *format_ret = 32;
763 *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (GdkAtom));
764 for (i = 0; i < (int) (*size_ret); i++)
765 if (SYMBOLP (XVECTOR_DATA (obj) [i]))
766 (*(GdkAtom **) data_ret) [i] =
767 symbol_to_gtk_atom (d, XVECTOR_DATA (obj) [i], 0);
768 else
769 syntax_error
770 ("all elements of the vector must be of the same type", obj);
771 }
772 #if 0 /* #### MULTIPLE doesn't work yet */
773 else if (VECTORP (XVECTOR_DATA (obj) [0]))
774 /* This vector is an ATOM_PAIR set */
775 {
776 if (NILP (type)) type = QATOM_PAIR;
777 *size_ret = XVECTOR_LENGTH (obj);
778 *format_ret = 32;
779 *data_ret = (unsigned char *)
780 xmalloc ((*size_ret) * sizeof (Atom) * 2);
781 for (i = 0; i < *size_ret; i++)
782 if (VECTORP (XVECTOR_DATA (obj) [i]))
783 {
784 Lisp_Object pair = XVECTOR_DATA (obj) [i];
785 if (XVECTOR_LENGTH (pair) != 2)
786 syntax_error
787 ("elements of the vector must be vectors of exactly two elements", pair);
788
789 (*(GdkAtom **) data_ret) [i * 2] =
790 symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [0], 0);
791 (*(GdkAtom **) data_ret) [(i * 2) + 1] =
792 symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [1], 0);
793 }
794 else
795 syntax_error
796 ("all elements of the vector must be of the same type", obj);
797 }
798 #endif
799 else
800 /* This vector is an INTEGER set, or something like it */
801 {
802 *size_ret = XVECTOR_LENGTH (obj);
803 if (NILP (type)) type = QINTEGER;
804 *format_ret = 16;
805 for (i = 0; i < (int) (*size_ret); i++)
806 if (CONSP (XVECTOR_DATA (obj) [i]))
807 *format_ret = 32;
808 else if (!INTP (XVECTOR_DATA (obj) [i]))
809 syntax_error
810 ("all elements of the vector must be integers or conses of integers", obj);
811
812 *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
813 for (i = 0; i < (int) (*size_ret); i++)
814 if (*format_ret == 32)
815 (*((unsigned long **) data_ret)) [i] =
816 lisp_to_word (XVECTOR_DATA (obj) [i]);
817 else
818 (*((unsigned short **) data_ret)) [i] =
819 (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]);
820 }
821 }
822 else
823 invalid_argument ("unrecognized selection data", obj);
824
825 *type_ret = symbol_to_gtk_atom (d, type, 0);
826 }
827 364
828 365
829 366
830 static Lisp_Object 367 static Lisp_Object
831 gtk_own_selection (Lisp_Object selection_name, Lisp_Object selection_value, 368 gtk_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,