ext/Data-Dumper/t/freezer.t

   1 #!./perl -w
   2 #
   3 # test a few problems with the Freezer option, not a complete Freezer
   4 # test suite yet
   5
   6 BEGIN {
   7     if ($ENV{PERL_CORE}){
   8         chdir 't' if -d 't';
   9         unshift @INC, '../lib';
  10         require Config; import Config;
  11         no warnings 'once';
  12         if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
  13             print "1..0 # Skip: Data::Dumper was not built\n";
  14             exit 0;
  15         }
  16     }
  17 }
  18
  19 use strict;
  20 use Test::More qw(no_plan);
  21 use Data::Dumper;
  22 $Data::Dumper::Freezer = 'freeze';
  23
  24 # test for seg-fault bug when freeze() returns a non-ref
  25 my $foo = Test1->new("foo");
  26 my $dumped_foo = Dumper($foo);
  27 ok($dumped_foo,
  28    "Use of freezer sub which returns non-ref worked.");
  29 like($dumped_foo, qr/frozed/,
  30      "Dumped string has the key added by Freezer.");
  31
  32 # run the same tests with useperl.  this always worked
  33 {
  34     local $Data::Dumper::Useperl = 1;
  35     my $foo = Test1->new("foo");
  36     my $dumped_foo = Dumper($foo);
  37     ok($dumped_foo,
  38        "Use of freezer sub which returns non-ref worked with useperl");
  39     like($dumped_foo, qr/frozed/,
  40          "Dumped string has the key added by Freezer with useperl.");
  41 }
  42
  43 # test for warning when an object doesn't have a freeze()
  44 {
  45     my $warned = 0;
  46     local $SIG{__WARN__} = sub { $warned++ };
  47     my $bar = Test2->new("bar");
  48     my $dumped_bar = Dumper($bar);
  49     is($warned, 0, "A missing freeze() shouldn't warn.");
  50 }
  51
  52
  53 # run the same test with useperl, which always worked
  54 {
  55     local $Data::Dumper::Useperl = 1;
  56     my $warned = 0;
  57     local $SIG{__WARN__} = sub { $warned++ };
  58     my $bar = Test2->new("bar");
  59     my $dumped_bar = Dumper($bar);
  60     is($warned, 0, "A missing freeze() shouldn't warn with useperl");
  61 }
  62
  63 # a freeze() which die()s should still trigger the warning
  64 {
  65     my $warned = 0;
  66     local $SIG{__WARN__} = sub { $warned++; };
  67     my $bar = Test3->new("bar");
  68     my $dumped_bar = Dumper($bar);
  69     is($warned, 1, "A freeze() which die()s should warn.");
  70 }
  71
  72 # the same should work in useperl
  73 {
  74     local $Data::Dumper::Useperl = 1;
  75     my $warned = 0;
  76     local $SIG{__WARN__} = sub { $warned++; };
  77     my $bar = Test3->new("bar");
  78     my $dumped_bar = Dumper($bar);
  79     is($warned, 1, "A freeze() which die()s should warn with useperl.");
  80 }
  81
  82 # a package with a freeze() which returns a non-ref
  83 package Test1;
  84 sub new { bless({name => $_[1]}, $_[0]) }
  85 sub freeze {
  86     my $self = shift;
  87     $self->{frozed} = 1;
  88 }
  89
  90 # a package without a freeze()
  91 package Test2;
  92 sub new { bless({name => $_[1]}, $_[0]) }
  93
  94 # a package with a freeze() which dies
  95 package Test3;
  96 sub new { bless({name => $_[1]}, $_[0]) }
  97 sub freeze { die "freeze() is broked" }