just_plain_nasty.t

source of perl for linux application,

#!/usr/bin/perl

# This is a test suite to cover all the nasty and horrible data
# structures that cause bizarre corner cases.

#  Everyone's invited! :-D

sub BEGIN {
    if ($ENV{PERL_CORE}){
        chdir('t') if -d 't';
        @INC = ('.', '../lib');
    } else {
        unshift @INC, 't';
    }
    require Config; import Config;
    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
        print "1..0 # Skip: Storable was not built\n";
        exit 0;
    }
}

use strict;
BEGIN {
    if (!eval q{
        use Test;
        use B::Deparse 0.61;
        use 5.006;
        1;
    }) {
        print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
        exit;
    }
    require File::Spec;
    if ($File::Spec::VERSION < 0.8) {
        print "1..0 # Skip: newer File::Spec needed\n";
        exit 0;
    }
}

use Storable qw(freeze thaw);

#$Storable::DEBUGME = 1;
BEGIN {
    plan tests => 34;
}

{
    package Banana;
    use overload   
	'<=>' => \&compare,
	    '==' => \&equal,
		'""' => \&real,
		fallback => 1;
    sub compare { return int(rand(3))-1 };
    sub equal { return 1 if rand(1) > 0.5 }
    sub real { return "keep it so" }
}

my (@a);

for my $dbun (1, 0) {  # dbun - don't be utterly nasty - being utterly
                       # nasty means having a reference to the object
                       # directly within itself. otherwise it's in the
                       # second array.
    my $nasty = [
		 ($a[0] = bless [ ], "Banana"),
		 ($a[1] = [ ]),
		];

    $a[$dbun]->[0] = $a[0];

    ok(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)");

    $Storable::Deparse = $Storable::Deparse = 1;
    $Storable::Eval = $Storable::Eval = 1;

    headit("circular overload 1 - freeze");
    my $icicle = freeze $nasty;
    #print $icicle;   # cat -ve recommended :)
    headit("circular overload 1 - thaw");
    my $oh_dear = thaw $icicle;
    ok(ref($oh_dear), "ARRAY", "dclone - circular overload");
    ok($oh_dear->[0], "keep it so", "amagic ok 1");
    ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");

    headit("closure dclone - freeze");
    $icicle = freeze sub { "two" };
    #print $icicle;
    headit("closure dclone - thaw");
    my $sub2 = thaw $icicle;
    ok($sub2->(), "two", "closures getting dcloned OK");

    headit("circular overload, after closure - freeze");
    #use Data::Dumper;
    #print Dumper $nasty;
    $icicle = freeze $nasty;
    #print $icicle;
    headit("circular overload, after closure - thaw");
    $oh_dear = thaw $icicle;
    ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
    ok($oh_dear->[0], "keep it so", "amagic ok 1");
    ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");

    push @{$nasty}, sub { print "Goodbye, cruel world.\n" };
    headit("closure freeze AFTER circular overload");
    #print Dumper $nasty;
    $icicle = freeze $nasty;
    #print $icicle;
    headit("circular thaw AFTER circular overload");
    $oh_dear = thaw $icicle;
    ok(ref($oh_dear), "ARRAY", "dclone - before a closure dclone");
    ok($oh_dear->[0], "keep it so", "amagic ok 1");
    ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");

    @{$nasty} = @{$nasty}[0, 2, 1];
    headit("closure freeze BETWEEN circular overload");
    #print Dumper $nasty;
    $icicle = freeze $nasty;
    #print $icicle;
    headit("circular thaw BETWEEN circular overload");
    $oh_dear = thaw $icicle;
    ok(ref($oh_dear), "ARRAY", "dclone - between a closure dclone");
    ok($oh_dear->[0], "keep it so", "amagic ok 1");
    ok($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2");

    @{$nasty} = @{$nasty}[1, 0, 2];
    headit("closure freeze BEFORE circular overload");
    #print Dumper $nasty;
    $icicle = freeze $nasty;
    #print $icicle;
    headit("circular thaw BEFORE circular overload");
    $oh_dear = thaw $icicle;
    ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
    ok($oh_dear->[1], "keep it so", "amagic ok 1");
    ok($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2");
}

sub headit {

    return;  # comment out to get headings - useful for scanning
             # output with $Storable::DEBUGME = 1

    my $title = shift;

    my $size_left = (66 - length($title)) >> 1;
    my $size_right = (67 - length($title)) >> 1;

    print "# ".("-" x $size_left). " $title "
	.("-" x $size_right)."\n";
}