Commit | Line | Data |
a8b7ef86 |
1 | #!/usr/bin/perl |
2 | |
3 | # This is a test suite to cover all the nasty and horrible data |
4 | # structures that cause bizarre corner cases. |
5 | |
6 | # Everyone's invited! :-D |
7 | |
8 | sub BEGIN { |
48c887dd |
9 | unshift @INC, 't'; |
a8b7ef86 |
10 | require Config; import Config; |
11 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
12 | print "1..0 # Skip: Storable was not built\n"; |
13 | exit 0; |
14 | } |
15 | } |
16 | |
17 | use strict; |
18 | BEGIN { |
19 | if (!eval q{ |
3513da74 |
20 | use Test::More; |
a8b7ef86 |
21 | use B::Deparse 0.61; |
22 | use 5.006; |
23 | 1; |
24 | }) { |
5650719d |
25 | print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n"; |
a8b7ef86 |
26 | exit; |
27 | } |
28 | require File::Spec; |
29 | if ($File::Spec::VERSION < 0.8) { |
30 | print "1..0 # Skip: newer File::Spec needed\n"; |
31 | exit 0; |
32 | } |
33 | } |
34 | |
35 | use Storable qw(freeze thaw); |
36 | |
37 | #$Storable::DEBUGME = 1; |
38 | BEGIN { |
39 | plan tests => 34; |
40 | } |
41 | |
42 | { |
43 | package Banana; |
44 | use overload |
45 | '<=>' => \&compare, |
46 | '==' => \&equal, |
47 | '""' => \&real, |
48 | fallback => 1; |
49 | sub compare { return int(rand(3))-1 }; |
50 | sub equal { return 1 if rand(1) > 0.5 } |
51 | sub real { return "keep it so" } |
52 | } |
53 | |
54 | my (@a); |
55 | |
56 | for my $dbun (1, 0) { # dbun - don't be utterly nasty - being utterly |
57 | # nasty means having a reference to the object |
58 | # directly within itself. otherwise it's in the |
59 | # second array. |
60 | my $nasty = [ |
61 | ($a[0] = bless [ ], "Banana"), |
62 | ($a[1] = [ ]), |
63 | ]; |
64 | |
65 | $a[$dbun]->[0] = $a[0]; |
66 | |
3513da74 |
67 | is(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)"); |
a8b7ef86 |
68 | |
69 | $Storable::Deparse = $Storable::Deparse = 1; |
70 | $Storable::Eval = $Storable::Eval = 1; |
71 | |
72 | headit("circular overload 1 - freeze"); |
73 | my $icicle = freeze $nasty; |
74 | #print $icicle; # cat -ve recommended :) |
75 | headit("circular overload 1 - thaw"); |
76 | my $oh_dear = thaw $icicle; |
3513da74 |
77 | is(ref($oh_dear), "ARRAY", "dclone - circular overload"); |
78 | is($oh_dear->[0], "keep it so", "amagic ok 1"); |
79 | is($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); |
a8b7ef86 |
80 | |
81 | headit("closure dclone - freeze"); |
82 | $icicle = freeze sub { "two" }; |
83 | #print $icicle; |
84 | headit("closure dclone - thaw"); |
85 | my $sub2 = thaw $icicle; |
3513da74 |
86 | is($sub2->(), "two", "closures getting dcloned OK"); |
a8b7ef86 |
87 | |
88 | headit("circular overload, after closure - freeze"); |
89 | #use Data::Dumper; |
90 | #print Dumper $nasty; |
91 | $icicle = freeze $nasty; |
92 | #print $icicle; |
93 | headit("circular overload, after closure - thaw"); |
94 | $oh_dear = thaw $icicle; |
3513da74 |
95 | is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); |
96 | is($oh_dear->[0], "keep it so", "amagic ok 1"); |
97 | is($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); |
a8b7ef86 |
98 | |
99 | push @{$nasty}, sub { print "Goodbye, cruel world.\n" }; |
100 | headit("closure freeze AFTER circular overload"); |
101 | #print Dumper $nasty; |
102 | $icicle = freeze $nasty; |
103 | #print $icicle; |
104 | headit("circular thaw AFTER circular overload"); |
105 | $oh_dear = thaw $icicle; |
3513da74 |
106 | is(ref($oh_dear), "ARRAY", "dclone - before a closure dclone"); |
107 | is($oh_dear->[0], "keep it so", "amagic ok 1"); |
108 | is($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); |
a8b7ef86 |
109 | |
110 | @{$nasty} = @{$nasty}[0, 2, 1]; |
111 | headit("closure freeze BETWEEN circular overload"); |
112 | #print Dumper $nasty; |
113 | $icicle = freeze $nasty; |
114 | #print $icicle; |
115 | headit("circular thaw BETWEEN circular overload"); |
116 | $oh_dear = thaw $icicle; |
3513da74 |
117 | is(ref($oh_dear), "ARRAY", "dclone - between a closure dclone"); |
118 | is($oh_dear->[0], "keep it so", "amagic ok 1"); |
119 | is($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2"); |
a8b7ef86 |
120 | |
121 | @{$nasty} = @{$nasty}[1, 0, 2]; |
122 | headit("closure freeze BEFORE circular overload"); |
123 | #print Dumper $nasty; |
124 | $icicle = freeze $nasty; |
125 | #print $icicle; |
126 | headit("circular thaw BEFORE circular overload"); |
127 | $oh_dear = thaw $icicle; |
3513da74 |
128 | is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); |
129 | is($oh_dear->[1], "keep it so", "amagic ok 1"); |
130 | is($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2"); |
a8b7ef86 |
131 | } |
132 | |
133 | sub headit { |
134 | |
135 | return; # comment out to get headings - useful for scanning |
136 | # output with $Storable::DEBUGME = 1 |
137 | |
138 | my $title = shift; |
139 | |
140 | my $size_left = (66 - length($title)) >> 1; |
141 | my $size_right = (67 - length($title)) >> 1; |
142 | |
143 | print "# ".("-" x $size_left). " $title " |
144 | .("-" x $size_right)."\n"; |
145 | } |
146 | |