3 # This is a test suite to cover all the nasty and horrible data
4 # structures that cause bizarre corner cases.
6 # Everyone's invited! :-D
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";
25 print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
29 if ($File::Spec::VERSION < 0.8) {
30 print "1..0 # Skip: newer File::Spec needed\n";
35 use Storable qw(freeze thaw);
37 #$Storable::DEBUGME = 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" }
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
61 ($a[0] = bless [ ], "Banana"),
65 $a[$dbun]->[0] = $a[0];
67 ok(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)");
69 $Storable::Deparse = $Storable::Deparse = 1;
70 $Storable::Eval = $Storable::Eval = 1;
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;
77 ok(ref($oh_dear), "ARRAY", "dclone - circular overload");
78 ok($oh_dear->[0], "keep it so", "amagic ok 1");
79 ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
81 headit("closure dclone - freeze");
82 $icicle = freeze sub { "two" };
84 headit("closure dclone - thaw");
85 my $sub2 = thaw $icicle;
86 ok($sub2->(), "two", "closures getting dcloned OK");
88 headit("circular overload, after closure - freeze");
91 $icicle = freeze $nasty;
93 headit("circular overload, after closure - thaw");
94 $oh_dear = thaw $icicle;
95 ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
96 ok($oh_dear->[0], "keep it so", "amagic ok 1");
97 ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
99 push @{$nasty}, sub { print "Goodbye, cruel world.\n" };
100 headit("closure freeze AFTER circular overload");
101 #print Dumper $nasty;
102 $icicle = freeze $nasty;
104 headit("circular thaw AFTER circular overload");
105 $oh_dear = thaw $icicle;
106 ok(ref($oh_dear), "ARRAY", "dclone - before a closure dclone");
107 ok($oh_dear->[0], "keep it so", "amagic ok 1");
108 ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
110 @{$nasty} = @{$nasty}[0, 2, 1];
111 headit("closure freeze BETWEEN circular overload");
112 #print Dumper $nasty;
113 $icicle = freeze $nasty;
115 headit("circular thaw BETWEEN circular overload");
116 $oh_dear = thaw $icicle;
117 ok(ref($oh_dear), "ARRAY", "dclone - between a closure dclone");
118 ok($oh_dear->[0], "keep it so", "amagic ok 1");
119 ok($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2");
121 @{$nasty} = @{$nasty}[1, 0, 2];
122 headit("closure freeze BEFORE circular overload");
123 #print Dumper $nasty;
124 $icicle = freeze $nasty;
126 headit("circular thaw BEFORE circular overload");
127 $oh_dear = thaw $icicle;
128 ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
129 ok($oh_dear->[1], "keep it so", "amagic ok 1");
130 ok($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2");
135 return; # comment out to get headings - useful for scanning
136 # output with $Storable::DEBUGME = 1
140 my $size_left = (66 - length($title)) >> 1;
141 my $size_right = (67 - length($title)) >> 1;
143 print "# ".("-" x $size_left). " $title "
144 .("-" x $size_right)."\n";