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