From: Sam Tregar Date: Sun, 19 Dec 2004 14:40:25 +0000 (-0500) Subject: Data::Dumper Freezer fixes X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c5f7c514bb4668f1a5a19abd36ab87f001002ea4;p=p5sagit%2Fp5-mst-13.2.git Data::Dumper Freezer fixes Message-ID: and bump Data::Dumper's VERSION p4raw-id: //depot/perl@23671 --- diff --git a/MANIFEST b/MANIFEST index 219da18..67e19f0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -152,6 +152,7 @@ ext/Data/Dumper/Dumper.pm Data pretty printer, module ext/Data/Dumper/Dumper.xs Data pretty printer, externals ext/Data/Dumper/Makefile.PL Data pretty printer, makefile writer ext/Data/Dumper/t/dumper.t See if Data::Dumper works +ext/Data/Dumper/t/freezer.t See if $Data::Dumper::Freezer works ext/Data/Dumper/Todo Data pretty printer, futures ext/Data/Dumper/t/overload.t See if Data::Dumper works for overloaded data ext/Data/Dumper/t/pair.t See if Data::Dumper pair separator works diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm index a9acf75..a0611f5 100644 --- a/ext/Data/Dumper/Dumper.pm +++ b/ext/Data/Dumper/Dumper.pm @@ -9,7 +9,7 @@ package Data::Dumper; -$VERSION = '2.121_02'; +$VERSION = '2.121_03'; #$| = 1; @@ -231,9 +231,13 @@ sub _dump { if ($type) { - # prep it, if it looks like an object - if (my $freezer = $s->{freezer}) { - $val->$freezer() if UNIVERSAL::can($val, $freezer); + # Call the freezer method if it's specified and the object has the + # method. Trap errors and warn() instead of die()ing, like the XS + # implementation. + my $freezer = $s->{freezer}; + if ($freezer and UNIVERSAL::can($val, $freezer)) { + eval { $val->$freezer() }; + warn "WARNING(Freezer method call failed): $@" if $@; } ($realpack, $realtype, $id) = @@ -887,6 +891,10 @@ method can be called via the object, and that the object ends up containing only perl data types after the method has been called. Defaults to an empty string. +If an object does not support the method specified (determined using +UNIVERSAL::can()) then the call will be skipped. If the method dies a +warning will be generated. + =item * $Data::Dumper::Toaster I $I->Toaster(I<[NEWVAL]>) diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 44dee9e..5d98365 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -260,20 +260,20 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, mg_get(val); if (SvROK(val)) { + /* If a freeze method is provided and the object has it, call + it. Warn on errors. */ if (SvOBJECT(SvRV(val)) && freezer && - SvPOK(freezer) && SvCUR(freezer)) + SvPOK(freezer) && SvCUR(freezer) && + gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX(freezer), + SvCUR(freezer), -1) != NULL) { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(val); PUTBACK; - i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR); + i = perl_call_method(SvPVX(freezer), G_EVAL|G_VOID); SPAGAIN; if (SvTRUE(ERRSV)) warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); - else if (i) - val = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; - if (i) - (void)sv_2mortal(val); } ival = SvRV(val); diff --git a/ext/Data/Dumper/t/freezer.t b/ext/Data/Dumper/t/freezer.t new file mode 100644 index 0000000..06ff9c9 --- /dev/null +++ b/ext/Data/Dumper/t/freezer.t @@ -0,0 +1,97 @@ +#!./perl -w +# +# test a few problems with the Freezer option, not a complete Freezer +# test suite yet + +BEGIN { + if ($ENV{PERL_CORE}){ + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + no warnings 'once'; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More qw(no_plan); +use Data::Dumper; +$Data::Dumper::Freezer = 'freeze'; + +# test for seg-fault bug when freeze() returns a non-ref +my $foo = Test1->new("foo"); +my $dumped_foo = Dumper($foo); +ok($dumped_foo, + "Use of freezer sub which returns non-ref worked."); +like($dumped_foo, qr/frozed/, + "Dumped string has the key added by Freezer."); + +# run the same tests with useperl. this always worked +{ + local $Data::Dumper::Useperl = 1; + my $foo = Test1->new("foo"); + my $dumped_foo = Dumper($foo); + ok($dumped_foo, + "Use of freezer sub which returns non-ref worked with useperl"); + like($dumped_foo, qr/frozed/, + "Dumped string has the key added by Freezer with useperl."); +} + +# test for warning when an object doesn't have a freeze() +{ + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++ }; + my $bar = Test2->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 0, "A missing freeze() shouldn't warn."); +} + + +# run the same test with useperl, which always worked +{ + local $Data::Dumper::Useperl = 1; + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++ }; + my $bar = Test2->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 0, "A missing freeze() shouldn't warn with useperl"); +} + +# a freeze() which die()s should still trigger the warning +{ + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++; }; + my $bar = Test3->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 1, "A freeze() which die()s should warn."); +} + +# the same should work in useperl +{ + local $Data::Dumper::Useperl = 1; + my $warned = 0; + local $SIG{__WARN__} = sub { $warned++; }; + my $bar = Test3->new("bar"); + my $dumped_bar = Dumper($bar); + is($warned, 1, "A freeze() which die()s should warn with useperl."); +} + +# a package with a freeze() which returns a non-ref +package Test1; +sub new { bless({name => $_[1]}, $_[0]) } +sub freeze { + my $self = shift; + $self->{frozed} = 1; +} + +# a package without a freeze() +package Test2; +sub new { bless({name => $_[1]}, $_[0]) } + +# a package with a freeze() which dies +package Test3; +sub new { bless({name => $_[1]}, $_[0]) } +sub freeze { die "freeze() is broked" }