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