? diff ? .diff.swp ? GType.i ? param_test.pl ? newprops.pl ? .GType.xs.swp ? .GParamSpec.xs.swp ? .param_test.pl.swp ? .GObject.xs.swp Index: GObject.xs =================================================================== RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GObject.xs,v retrieving revision 1.45 diff -u -r1.45 GObject.xs --- GObject.xs 9 Jun 2004 01:58:44 -0000 1.45 +++ GObject.xs 12 Jun 2004 03:31:37 -0000 @@ -732,6 +732,43 @@ =cut +/* + * $sv = $object->{name} + * + * if the key doesn't exist with name, convert - to _ and try again. + * that is, support both "funny-name" and "funny_name". + * + * if create is true, autovivify the key (and always return a value). + * if create is false, returns NULL is there is no such key. + */ +SV * +_gperl_fetch_wrapper_key (GObject * object, + const char * name, + gboolean create) +{ + SV ** svp; + SV * svname; + HV * wrapper_hash; + wrapper_hash = g_object_get_qdata (object, wrapper_quark); + svname = newSVpv (name, strlen (name)); + svp = hv_fetch (wrapper_hash, SvPV_nolen (svname), SvLEN (svname)-1, + create); + if (!svp) { + /* the key doesn't exist with that name. do s/-/_/g and + * try again. */ + register char * c; + for (c = SvPV_nolen (svname); c <= SvEND (svname) ; c++) + if (*c == '-') + *c = '_'; + svp = hv_fetch (wrapper_hash, + SvPV_nolen (svname), SvLEN (svname)-1, + FALSE); + } + SvREFCNT_dec (svname); + + return (svp ? *svp : NULL); +} + #if GPERL_THREAD_SAFE static void _inc_ref_and_count (GObject * key, gint value, gpointer user_data) @@ -1014,7 +1051,6 @@ g_value_unset (&value); } - =for apidoc Emits a "notify" signal for the property I<$property> on I<$object>. Index: GType.xs =================================================================== RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GType.xs,v retrieving revision 1.62 diff -u -r1.62 GType.xs --- GType.xs 9 Jun 2004 01:58:44 -0000 1.62 +++ GType.xs 12 Jun 2004 03:31:39 -0000 @@ -28,6 +28,11 @@ #include "gperl.h" #include "gperl_marshal.h" +/* private helper, defined in GObject.xs, not exported */ +extern SV * _gperl_fetch_wrapper_key (GObject * object, + const char * name, + gboolean create); + /* for fundamental types */ static GHashTable * types_by_package = NULL; static GHashTable * packages_by_type = NULL; @@ -1112,11 +1117,73 @@ SvREFCNT_dec (class_name); } + +/* set value to the default value of the given pspec, if the pspec supports + * default values. + */ +static void +get_default_property_value (GValue * value, + GParamSpec * pspec) +{ + /* + * not all pspec types support a default value, and user code can + * add pspec types; thus, glib does not provide a unified way to + * get a default value for a param. also, the default value member + * may be at different offsets in the various param spec structs, + * so to do this in pure C we'd have to create a whole slew of + * helper functions to set the default values and put them in a + * hash table (or an if-else tree -- since the type codes are dynamic, + * we can't use them in a switch). however, that would leave us with + * code bloat and a maintenance problem, since we'd have to add code + * for each new param type, and we'd never handle custom params. + * + * instead, let's use the existing infrastructure in the bindings, + * and let perl's oo system do the hard work for us. this will catch + * any custom params as well (provided their default_value accessors + * have been bound), at a slight cost in performance. + */ + const char * package; + GV * method = NULL; + HV * stash; + package = gperl_param_spec_package_from_type (G_PARAM_SPEC_TYPE (pspec)); + if (!package) + croak ("Param spec type %s is not registered with GPerl", + g_type_name (G_PARAM_SPEC_TYPE (pspec))); + stash = gv_stashpv (package, FALSE); + assert (stash) + method = gv_fetchmethod (stash, "get_default_value"); + + if (method) { + SV * sv; + + dSP; + ENTER; + SAVETMPS; + PUSHMARK (SP); + PUSHs (sv_2mortal (newSVGParamSpec (pspec))); + PUTBACK; + + call_sv ((SV *)GvCV (method), G_SCALAR); + SPAGAIN; + + sv = POPs; + gperl_value_from_sv (value, sv); + + PUTBACK; + FREETMPS; + LEAVE; + + } else { + /* no method, so no way to fetch a default value. + * do nothing. */ + } +} + static void gperl_type_get_property (GObject * object, - guint property_id, - GValue * value, - GParamSpec * pspec) + guint property_id, + GValue * value, + GParamSpec * pspec) { HV *stash = gperl_object_stash_from_type (pspec->owner_type); SV **slot; @@ -1130,6 +1197,8 @@ if (slot && GvCV (*slot)) { dSP; + warn (G_STRLOC ": calling GET_PROPERTY on %s\n", SvPV_nolen ((SV*)g_object_get_data (object, "Perl-wrapper-object"))); + ENTER; SAVETMPS; @@ -1148,7 +1217,19 @@ PUTBACK; FREETMPS; LEAVE; - } + + } else { + /* no GET_PROPERTY; look in the wrapper hash. */ + SV * val = _gperl_fetch_wrapper_key + (object, g_param_spec_get_name (pspec), FALSE); + if (val) + gperl_value_from_sv (value, val); + else { + /* no value in the wrapper hash. get the pspec's + * default, if it has one. */ + get_default_property_value (value, pspec); + } + } } static void @@ -1168,6 +1249,7 @@ /* does the function exist? then call it. */ if (slot && GvCV (*slot)) { dSP; + warn (G_STRLOC ": calling SET_PROPERTY on %p\n", object); ENTER; SAVETMPS; @@ -1182,7 +1264,20 @@ FREETMPS; LEAVE; - } + + } else { + /* no SET_PROPERTY. fall back to setting the value into + * a key with the pspec's name in the wrapper hash. */ + SV * val = _gperl_fetch_wrapper_key + (object, g_param_spec_get_name (pspec), TRUE); + warn (G_STRLOC ": wrapper key %p (%s)\n", val, val ? SvPV_nolen (val) : "NULL"); + if (val) { + SV * newval = sv_2mortal (gperl_sv_from_value (value)); + SvSetSV (val, newval); + } else { + /* XXX couldn't create the key. what to do? */ + } + } } static void