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