Change 23671 by [EMAIL PROTECTED] on 2004/12/23 15:21:58
Subject: [PATCH] Data::Dumper Freezer fixes
From: Sam Tregar <[EMAIL PROTECTED]>
Date: Sun, 19 Dec 2004 14:40:25 -0500 (EST)
Message-ID: <[EMAIL PROTECTED]>
and bump Data::Dumper's VERSION
Affected files ...
... //depot/perl/MANIFEST#1203 edit
... //depot/perl/ext/Data/Dumper/Dumper.pm#36 edit
... //depot/perl/ext/Data/Dumper/Dumper.xs#49 edit
... //depot/perl/ext/Data/Dumper/t/freezer.t#1 add
Differences ...
==== //depot/perl/MANIFEST#1203 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1202~23661~ Fri Dec 17 01:08:23 2004
+++ perl/MANIFEST Thu Dec 23 07:21:58 2004
@@ -152,6 +152,7 @@
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
==== //depot/perl/ext/Data/Dumper/Dumper.pm#36 (text) ====
Index: perl/ext/Data/Dumper/Dumper.pm
--- perl/ext/Data/Dumper/Dumper.pm#35~23383~ Tue Oct 19 04:38:37 2004
+++ perl/ext/Data/Dumper/Dumper.pm Thu Dec 23 07:21:58 2004
@@ -9,7 +9,7 @@
package Data::Dumper;
-$VERSION = '2.121_02';
+$VERSION = '2.121_03';
#$| = 1;
@@ -231,9 +231,13 @@
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) =
@@ -886,6 +890,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 *
==== //depot/perl/ext/Data/Dumper/Dumper.xs#49 (text) ====
Index: perl/ext/Data/Dumper/Dumper.xs
--- perl/ext/Data/Dumper/Dumper.xs#48~21036~ Thu Sep 4 12:34:26 2003
+++ perl/ext/Data/Dumper/Dumper.xs Thu Dec 23 07:21:58 2004
@@ -260,20 +260,20 @@
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);
==== //depot/perl/ext/Data/Dumper/t/freezer.t#1 (text) ====
Index: perl/ext/Data/Dumper/t/freezer.t
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/ext/Data/Dumper/t/freezer.t Thu Dec 23 07:21:58 2004
@@ -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" }
End of Patch.
