On Thu, 2007-11-15 at 18:21 +0100, Torsten Schoenfeld wrote: > Maybe we need a new macro that mimics defined() and use it instead of > "sv && SvOK (sv)"? Here's a patch that adds the new function gperl_sv_defined, derived from perl's pp_defined, and uses it in place of SvOK everywhere in Glib. It contains a test derived from Giuliano's program. I also ran a benchmark and found no measurable time differences between Glib with and without the patch applied. Odot's start-up timed wasn't affected either. So, does this make sense? Is the benchmark sound, or are there cases which are slowed down measurably by this patch? Is the name gperl_sv_defined good, or are there better alternatives? -- Bye, -Torsten
Index: GBoxed.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GBoxed.xs,v
retrieving revision 1.24
diff -u -d -p -r1.24 GBoxed.xs
--- GBoxed.xs 13 Sep 2006 14:53:27 -0000 1.24
+++ GBoxed.xs 18 Nov 2007 19:54:51 -0000
@@ -462,7 +462,7 @@ gperl_get_boxed_check (SV * sv, GType gt
BoxedInfo * boxed_info;
GPerlBoxedUnwrapFunc unwrap;
- if (!sv || !SvOK (sv))
+ if (!gperl_sv_defined (sv))
croak ("variable not allowed to be undef where %s is wanted",
g_type_name (gtype));
@@ -556,7 +556,7 @@ strv_unwrap (GType gtype,
gchar ** strv = NULL;
/* pass undef */
- if (!sv || !SvOK (sv))
+ if (!gperl_sv_defined (sv))
return NULL;
if (SvROK (sv)) {
@@ -674,7 +674,7 @@ DESTROY (sv)
char * class;
GPerlBoxedDestroyFunc destroy;
CODE:
- if (!sv || !SvOK (sv) || !SvROK (sv) || !SvRV (sv))
+ if (!gperl_sv_defined (sv) || !SvROK (sv) || !SvRV (sv))
croak ("DESTROY called on a bad value");
/* we need to find the wrapper class associated with whatever type
Index: GError.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GError.xs,v
retrieving revision 1.11
diff -u -d -p -r1.11 GError.xs
--- GError.xs 23 Jul 2006 10:20:59 -0000 1.11
+++ GError.xs 18 Nov 2007 19:54:51 -0000
@@ -219,8 +219,9 @@ gperl_gerror_from_sv (SV * sv, GError **
* side effect, 0 is also allowed. we just won't advertise that.
* the logic here is a bit ugly to avoid running the overloaded
* stringification operator via SvTRUE(). */
- if (!sv || !SvOK (sv) || /* not defined */
- (!SvROK (sv) && !SvTRUE (sv))) { /* not a ref, but still false */
+ if (!gperl_sv_defined (sv) || /* not defined */
+ (!SvROK (sv) && !SvTRUE (sv))) /* not a ref, but still false */
+ {
*error = NULL;
return;
}
@@ -243,7 +244,7 @@ gperl_gerror_from_sv (SV * sv, GError **
const char * domain;
GQuark qdomain;
svp = hv_fetch (hv, "domain", 6, FALSE);
- if (!svp || !SvOK (sv))
+ if (!svp || !gperl_sv_defined (*svp))
g_error ("key 'domain' not found in plain hash for GError");
domain = SvPV_nolen (*svp);
qdomain = g_quark_try_string (domain);
@@ -262,11 +263,11 @@ gperl_gerror_from_sv (SV * sv, GError **
* error code. prefer the 'value' key, fall back to 'code'.
*/
svp = hv_fetch (hv, "value", 5, FALSE);
- if (svp && SvOK (*svp))
+ if (svp && gperl_sv_defined (*svp))
scratch.code = gperl_convert_enum (info->error_enum, *svp);
else {
svp = hv_fetch (hv, "code", 4, FALSE);
- if (!svp || !SvOK (*svp))
+ if (!svp || !gperl_sv_defined (*svp))
croak ("error hash contains neither a 'value' nor 'code' key; no error valid error code found");
scratch.code = SvIV (*svp);
}
@@ -275,7 +276,7 @@ gperl_gerror_from_sv (SV * sv, GError **
* the message is the easy part.
*/
svp = hv_fetch (hv, "message", 7, FALSE);
- if (!svp || !SvOK (*svp))
+ if (!svp || !gperl_sv_defined (*svp))
croak ("error has contains no error message");
scratch.message = SvGChar (*svp);
Index: GObject.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GObject.xs,v
retrieving revision 1.70
diff -u -d -p -r1.70 GObject.xs
--- GObject.xs 8 Oct 2007 19:38:44 -0000 1.70
+++ GObject.xs 18 Nov 2007 19:54:52 -0000
@@ -772,7 +772,7 @@ gperl_get_object (SV * sv)
{
MAGIC *mg;
- if (!sv || !SvOK (sv) || !SvROK (sv) || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext)))
+ if (!gperl_sv_defined (sv) || !SvROK (sv) || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext)))
return NULL;
return (GObject *) mg->mg_ptr;
}
@@ -1283,8 +1283,7 @@ g_object_find_property (object_or_class_
GType type = G_TYPE_INVALID;
gchar *name = NULL;
PPCODE:
- if (object_or_class_name &&
- SvOK (object_or_class_name) &&
+ if (gperl_sv_defined (object_or_class_name) &&
SvROK (object_or_class_name)) {
GObject * object = SvGObject (object_or_class_name);
if (!object)
Index: GSignal.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GSignal.xs,v
retrieving revision 1.28
diff -u -d -p -r1.28 GSignal.xs
--- GSignal.xs 7 Aug 2006 18:17:19 -0000 1.28
+++ GSignal.xs 18 Nov 2007 19:54:52 -0000
@@ -390,8 +390,7 @@ get_gtype_or_croak (SV * object_or_class
{
GType gtype;
- if (object_or_class_name &&
- SvOK (object_or_class_name) &&
+ if (gperl_sv_defined (object_or_class_name) &&
SvROK (object_or_class_name)) {
GObject * object = SvGObject (object_or_class_name);
if (!object)
Index: GType.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GType.xs,v
retrieving revision 1.79
diff -u -d -p -r1.79 GType.xs
--- GType.xs 28 Oct 2007 22:06:36 -0000 1.79
+++ GType.xs 18 Nov 2007 19:54:53 -0000
@@ -1103,7 +1103,7 @@ parse_signal_hash (GType instance_type,
PERL_UNUSED_VAR (signal_name);
svp = hv_fetch (hv, "flags", 5, FALSE);
- if (svp && (*svp) && SvOK (*svp))
+ if (svp && gperl_sv_defined (*svp))
s->flags = SvGSignalFlags (*svp);
svp = hv_fetch (hv, "param_types", 11, FALSE);
@@ -1126,7 +1126,7 @@ parse_signal_hash (GType instance_type,
svp = hv_fetch (hv, "class_closure", 13, FALSE);
if (svp && *svp) {
- if (SvOK (*svp))
+ if (gperl_sv_defined (*svp))
s->class_closure =
gperl_closure_new (*svp, NULL, FALSE);
/* else the class closure is NULL */
@@ -1135,7 +1135,7 @@ parse_signal_hash (GType instance_type,
}
svp = hv_fetch (hv, "return_type", 11, FALSE);
- if (svp && (*svp) && SvOK (*svp)) {
+ if (svp && gperl_sv_defined (*svp)) {
s->return_type = gperl_type_from_package (SvPV_nolen (*svp));
if (!s->return_type)
croak ("unknown or unregistered return type %s",
@@ -1430,9 +1430,8 @@ add_interfaces (GType instance_type, AV
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));
+ if (!svp || !gperl_sv_defined (*svp))
+ croak ("encountered invalid interface name");
/* call the interface's setup function on this class. */
{
@@ -2287,16 +2286,16 @@ g_type_register_enum (class, name, ...)
AV * av = (AV*)SvRV(sv);
/* value_name */
av2sv = av_fetch (av, 0, 0);
- if (av2sv && *av2sv && SvOK(*av2sv))
+ if (av2sv && gperl_sv_defined (*av2sv))
values[i].value_name = SvPV_nolen (*av2sv);
else
croak ("invalid enum name and value pair, no name provided");
/* custom value */
av2sv = av_fetch (av, 1, 0);
- if (av2sv && *av2sv && SvOK(*av2sv))
+ if (av2sv && gperl_sv_defined (*av2sv))
values[i].value = SvIV (*av2sv);
}
- else if (SvOK (sv))
+ else if (gperl_sv_defined (sv))
{
/* name syntax */
values[i].value_name = SvPV_nolen (sv);
@@ -2373,16 +2372,16 @@ g_type_register_flags (class, name, ...)
AV * av = (AV*)SvRV(sv);
/* value_name */
av2sv = av_fetch (av, 0, 0);
- if (av2sv && *av2sv && SvOK(*av2sv))
+ if (av2sv && gperl_sv_defined (*av2sv))
values[i].value_name = SvPV_nolen (*av2sv);
else
croak ("invalid flag name and value pair, no name provided");
/* custom value */
av2sv = av_fetch (av, 1, 0);
- if (av2sv && *av2sv && SvOK(*av2sv))
+ if (av2sv && gperl_sv_defined (*av2sv))
values[i].value = SvIV (*av2sv);
}
- else if (SvOK (sv))
+ else if (gperl_sv_defined (sv))
{
/* name syntax */
values[i].value_name = SvPV_nolen (sv);
Index: GValue.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GValue.xs,v
retrieving revision 1.20
diff -u -d -p -r1.20 GValue.xs
--- GValue.xs 13 Nov 2005 16:43:43 -0000 1.20
+++ GValue.xs 18 Nov 2007 19:54:53 -0000
@@ -66,7 +66,7 @@ gperl_value_from_sv (GValue * value,
{
char* tmp;
GType type;
- if (!sv || !SvOK (sv))
+ if (!gperl_sv_defined (sv))
return TRUE; /* use the GValue type's default */
type = G_TYPE_FUNDAMENTAL (G_VALUE_TYPE (value));
/*printf ("TYPE: %d, S: %s\n", type, SvPV_nolen(sv));*/
@@ -125,7 +125,7 @@ gperl_value_from_sv (GValue * value,
/* SVs need special treatment! */
if (G_VALUE_HOLDS (value, GPERL_TYPE_SV))
g_value_set_boxed (value,
- sv && SvOK (sv)
+ gperl_sv_defined (sv)
? sv : NULL);
else
g_value_set_boxed (value, gperl_get_boxed_check (sv, G_VALUE_TYPE(value)));
Index: Glib.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/Glib.xs,v
retrieving revision 1.49
diff -u -d -p -r1.49 Glib.xs
--- Glib.xs 30 Dec 2006 15:37:17 -0000 1.49
+++ Glib.xs 18 Nov 2007 19:54:53 -0000
@@ -230,10 +230,10 @@ gperl_argv_new ()
pargv->argv[0] = SvPV_nolen (ARGV0);
for (i = 0 ; i < len ; i++) {
- SV ** sv = av_fetch (ARGV, i, 0);
- if (sv && SvOK (*sv))
+ SV ** svp = av_fetch (ARGV, i, 0);
+ if (svp && gperl_sv_defined (*svp))
pargv->shadow[i] = pargv->argv[i+1]
- = g_strdup (SvPV_nolen (*sv));
+ = g_strdup (SvPV_nolen (*svp));
}
return pargv;
@@ -283,7 +283,7 @@ gperl_format_variable_for_output (SV * s
{
if (sv) {
/* disambiguate undef */
- if (!SvOK (sv))
+ if (!gperl_sv_defined (sv))
return SvPV_nolen (sv_2mortal (newSVpv ("undef", 5)));
/* don't truncate references... */
if (SvROK (sv))
@@ -297,6 +297,39 @@ gperl_format_variable_for_output (SV * s
return NULL;
}
+gboolean
+gperl_sv_defined (SV *sv)
+{
+ /* This is adapted from PP(pp_defined) in perl's pp.c */
+
+ if (!sv || !SvANY(sv))
+ return FALSE;
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
+ || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+ return TRUE;
+ break;
+ case SVt_PVHV:
+ if (HvARRAY(sv) || SvGMAGICAL(sv)
+ || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+ return TRUE;
+ break;
+ case SVt_PVCV:
+ if (CvROOT(sv) || CvXSUB(sv))
+ return TRUE;
+ break;
+ default:
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvOK(sv))
+ return TRUE;
+ }
+
+ return FALSE;
+}
+
=back
=cut
@@ -430,10 +463,10 @@ filename_to_uri (...)
CODE:
if (items == 2) {
filename = SvPV_nolen (ST (0));
- hostname = SvOK (ST (1)) ? SvPV_nolen (ST (1)) : NULL;
+ hostname = gperl_sv_defined (ST (1)) ? SvPV_nolen (ST (1)) : NULL;
} else if (items == 3) {
filename = SvPV_nolen (ST (1));
- hostname = SvOK (ST (2)) ? SvPV_nolen (ST (2)) : NULL;
+ hostname = gperl_sv_defined (ST (2)) ? SvPV_nolen (ST (2)) : NULL;
} else {
croak ("Usage: Glib::filename_to_uri (filename, hostname)\n"
" -or- Glib->filename_to_uri (filename, hostname)\n"
Index: gperl.h
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/gperl.h,v
retrieving revision 1.49
diff -u -d -p -r1.49 gperl.h
--- gperl.h 15 Sep 2007 14:10:12 -0000 1.49
+++ gperl.h 18 Nov 2007 19:54:53 -0000
@@ -76,6 +76,8 @@ void gperl_argv_free (GPerlArgv *pargv);
char * gperl_format_variable_for_output (SV * sv);
+gboolean gperl_sv_defined (SV *sv);
+
/* internal trickery */
gpointer gperl_type_class (GType type);
/*
Index: t/tied_properties.t
===================================================================
RCS file: t/tied_properties.t
diff -N t/tied_properties.t
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ t/tied_properties.t 18 Nov 2007 19:54:53 -0000
@@ -0,0 +1,57 @@
+#!/usr/bin/perl
+
+package ClassFoo;
+use strict;
+use warnings;
+use Glib;
+
+use Glib::Object::Subclass
+ Glib::Object::,
+ properties => [
+ Glib::ParamSpec->boxed('title',
+ 'title',
+ 'The title',
+ 'Glib::Scalar',
+ [qw/writable readable/]),
+ ];
+
+sub INIT_INSTANCE {
+ my $self = shift;
+ $self->{prop_title} = undef;
+}
+
+sub SET_PROPERTY {
+ my ($self, $pspec, $val) = @_;
+ my $propname = $pspec->get_name;
+ if ($propname eq 'title') {
+ $self->{prop_title} = $val;
+ } else {
+ die "unknown property ``$propname''";
+ }
+}
+
+sub GET_PROPERTY {
+ my ($self, $pspec) = @_;
+ my $propname = $pspec->get_name;
+ if ($propname eq 'title') {
+ return $self->{prop_title};
+ } else {
+ die "unknown property ``$propname''";
+ }
+}
+
+# --------------------------------------------------------------------------- #
+
+package main;
+use strict;
+use warnings;
+use Tie::Hash;
+use Test::More tests => 1;
+
+my $hashref = {};
+tie %$hashref, 'Tie::StdHash';
+$hashref->{Title} = 'foo';
+
+my $w = ClassFoo->new;
+$w->set_property ('title', $hashref->{Title});
+is ($w->get_property ('title'), $hashref->{Title});
Attachment:
defined-benchmark.pl
Description: Perl program