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