? GInterface.xs ? GObject.xs-interfaces-hack ? autoprops.pl ? diff ? memtest.pl Index: ChangeLog =================================================================== RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/ChangeLog,v retrieving revision 1.171 diff -u -r1.171 ChangeLog --- ChangeLog 10 Dec 2003 20:19:05 -0000 1.171 +++ ChangeLog 15 Dec 2003 05:19:57 -0000 @@ -1,3 +1,15 @@ +2003/12/15 00:09 (-0500) muppetman + + * GType.xs: add the ability to add GInterfaces to new GObject types + with register_object. new key interfaces => \ list, where @list is a + list of package names. effectively does foreach (@list) { + $_->add_interface ($newtype); }, where the add_interface method is + supposed to do the actual work of adding and initializing the interface + implementation. + + * Subclass.pm: pass all unknown import parameters through to + Glib::Type->register_object. + 2003/12/10 15:18 (-0500) rwmcfa1 * t/c.t: now that the register_enum|flags stuff is fixed, test it out Index: GType.xs =================================================================== RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GType.xs,v retrieving revision 1.45 diff -u -r1.45 GType.xs --- GType.xs 10 Dec 2003 19:51:03 -0000 1.45 +++ GType.xs 15 Dec 2003 05:19:58 -0000 @@ -795,9 +795,6 @@ PUTBACK; -/* warn ("return_accum is '%s'\n", SvPV_nolen (sv_2mortal (gperl_sv_from_value (return_accu)))); - * warn ("handler_return was '%s'\n", SvPV_nolen (sv_2mortal (gperl_sv_from_value (handler_return)))); */ - n = call_sv (callback->func, G_EVAL|G_ARRAY); if (SvTRUE (ERRSV)) { @@ -950,7 +947,6 @@ /* the key is the signal name */ signal_name = hv_iterkey (he, &keylen); -/* warn ("\n#####\nsignal name: %s\n", signal_name); */ /* if the signal is defined at this point, we're going to * override the installed closure. */ signal_id = g_signal_lookup (signal_name, instance_type); @@ -973,9 +969,6 @@ s = parse_signal_hash (instance_type, signal_name, (HV*) SvRV (value)); -/* warn ("\ncreating signal %s with accumulator %p and accu_data %p\n", signal_name, s->accumulator, s->accu_data); - * sv_setsv (DEFSV, newSVGSignalFlags (s->flags)); - * eval_pv ("warn (' flags ['.join (', ', @$_).\"]\n\")", 0); */ signal_id = g_signal_newv (signal_name, instance_type, s->flags, @@ -1034,6 +1027,37 @@ } static void +add_interfaces (GType instance_type, AV * interfaces) +{ + int i; + SV * class_name = + newSVpv (gperl_object_package_from_type (instance_type), 0); + + for (i = 0; i <= av_len (interfaces); i++) { + SV ** svp = av_fetch (interfaces, i, FALSE); + if (!svp && !SvOK (*svp)) + croak ("%s is not a valid interface name", + SvPV_nolen (*svp)); + + /* call the interface's setup function on this class. */ + { + dSP; + ENTER; + PUSHMARK (SP); + EXTEND (SP, 2); + PUSHs (*svp); /* interface type */ + PUSHs (class_name); /* target type */ + PUTBACK; + call_method ("add_interface", G_VOID|G_DISCARD); + LEAVE; + } + gperl_prepend_isa (SvPV_nolen (class_name), SvPV_nolen (*svp)); + } + + SvREFCNT_dec (class_name); +} + +static void gperl_type_get_property (GObject * object, guint property_id, GValue * value, @@ -1045,9 +1069,6 @@ PERL_UNUSED_VAR (property_id); -#ifdef NOISY - warn ("%s:%d: gperl_type_get_property - stub", G_STRLOC); -#endif slot = hv_fetch (stash, "GET_PROPERTY", sizeof ("GET_PROPERTY") - 1, 0); /* does the function exist? then call it. */ @@ -1087,10 +1108,6 @@ PERL_UNUSED_VAR (property_id); -#ifdef NOISY - warn ("%s:%d: gperl_type_set_property - stub", G_STRLOC); -#endif - slot = hv_fetch (stash, "SET_PROPERTY", sizeof ("SET_PROPERTY") - 1, 0); /* does the function exist? then call it. */ @@ -1602,13 +1619,17 @@ add_signals (new_type, (HV*)SvRV (ST (i+1))); else croak ("signals must be a hash of signalname => signalspec pairs"); - } - if (strEQ (key, "properties")) { + } else if (strEQ (key, "properties")) { if (SvROK (ST (i+1)) && SvTYPE (SvRV (ST (i+1))) == SVt_PVAV) add_properties (new_type, (AV*)SvRV (ST (i+1))); else croak ("properties must be an array of GParamSpecs"); - } + } else if (strEQ (key, "interfaces")) { + if (SvROK (ST (i+1)) && SvTYPE (SvRV (ST (i+1))) == SVt_PVAV) + add_interfaces (new_type, (AV*)SvRV (ST (i+1))); + else + croak ("interfaces must be an array of package names"); + } } @@ -1948,17 +1969,6 @@ oclass = g_type_class_ref (package_type); if (!oclass) XSRETURN_EMPTY; - } else { -#if 0 - /* we need to ensure that the interface's prerequisite types - * have been created, in case any signals in this type depend - * on the prerequisite. however, this only works on 2.2.x... - * what can we do about that? */ - int i, n; - GType * prereqs = g_type_interface_prerequisites (package_type, &n); - for (i = 0 ; i < n ; i++) - warn (" prereq %d : %s\n", i, g_type_name (prereqs[i])); -#endif } sigids = g_signal_list_ids (package_type, &num); if (!num) Index: Subclass.pm =================================================================== RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/Subclass.pm,v retrieving revision 1.6 diff -u -r1.6 Subclass.pm --- Subclass.pm 10 Dec 2003 19:51:09 -0000 1.6 +++ Subclass.pm 15 Dec 2003 05:19:58 -0000 @@ -202,8 +202,8 @@ my ($self, $superclass, %arg) = @_; my $class = caller; - my $signals = $arg{signals} || {}; - my $properties = $arg{properties} || []; +# my $signals = $arg{signals} || {}; +# my $properties = $arg{properties} || []; # the CHECK callback will be executed after the module is compiled my $check = sub { @@ -217,8 +217,9 @@ Glib::Type->register( $superclass, $class, - signals => $signals, - properties => $properties, + #signals => $signals, + #properties => $properties, + %arg, ); }