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