Data::Dumper Freezer fixes

Message-ID: <Pine.LNX.4.61.0412191434490.7660@hillmont.dreamhost.com>

and bump Data::Dumper's VERSION

p4raw-id: //depot/perl@23671

3 files changed, 115 insertions, 10 deletions

diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm
index a9acf752eb..a0611f5733 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<or>  $I<OBJ>->Toaster(I<[NEWVAL]>)
diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index 44dee9e629..5d983656ea 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 0000000000..06ff9c921c
--- /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" }