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 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