ext/Storable/t/just_plain_nasty.t

   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 perl 5.6.0\n";
  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