Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
HAS_ATTACH.pm	121 B	-r--r--r--	2014-12-27 11:48
HAS_HOOK.pm	82 B	-r--r--r--	2014-12-27 11:48
HAS_OVERLOAD.pm	185 B	-r--r--r--	2014-12-27 11:48
attach.t	1007 B	-r--r--r--	2014-12-27 11:48
attach_errors.t	6.65 KB	-r--r--r--	2014-12-27 11:48
attach_singleton.t	2.32 KB	-r--r--r--	2014-12-27 11:48
blessed.t	6.77 KB	-r--r--r--	2014-12-27 11:48
canonical.t	3.46 KB	-r--r--r--	2014-12-27 11:49
circular_hook.t	1.98 KB	-r--r--r--	2014-12-27 11:48
code.t	7.23 KB	-r--r--r--	2014-12-27 11:48
compat01.t	1.15 KB	-r--r--r--	2014-12-27 11:48
compat06.t	3.25 KB	-r--r--r--	2014-12-27 11:48
croak.t	949 B	-r--r--r--	2014-12-27 11:48
dclone.t	2.19 KB	-r--r--r--	2014-12-27 11:48
destroy.t	362 B	-r--r--r--	2014-12-27 11:48
downgrade.t	17.41 KB	-r--r--r--	2014-12-27 11:48
file_magic.t	13.23 KB	-r--r--r--	2014-12-27 11:48
forgive.t	1.51 KB	-r--r--r--	2014-12-27 11:48
freeze.t	2.56 KB	-r--r--r--	2014-12-27 11:48
integer.t	6.08 KB	-r--r--r--	2014-12-27 11:48
interwork56.t	5.95 KB	-r--r--r--	2014-12-27 11:48
just_plain_nasty.t	4.24 KB	-r--r--r--	2014-12-27 11:48
leaks.t	626 B	-r--r--r--	2014-12-27 11:48
lock.t	1014 B	-r--r--r--	2014-12-27 11:48
make_56_interwork.pl	1.45 KB	-r--r--r--	2014-12-27 11:48
make_downgrade.pl	2.23 KB	-r--r--r--	2014-12-27 11:48
make_overload.pl	177 B	-r--r--r--	2014-12-27 11:48
malice.t	10.3 KB	-r--r--r--	2014-12-27 11:48
overload.t	2.04 KB	-r--r--r--	2014-12-27 11:48
recurse.t	5.74 KB	-r--r--r--	2014-12-27 11:48
restrict.t	3.42 KB	-r--r--r--	2014-12-27 11:48
retrieve.t	1.34 KB	-r--r--r--	2014-12-27 11:48
robust.t	309 B	-r--r--r--	2014-12-27 11:48
sig_die.t	734 B	-r--r--r--	2014-12-27 11:48
st-dump.pl	3.35 KB	-r--r--r--	2014-12-27 11:48
store.t	1.76 KB	-r--r--r--	2014-12-27 11:48
testlib.pl	865 B	-r--r--r--	2014-12-27 11:48
threads.t	1.8 KB	-r--r--r--	2014-12-27 11:48
tied.t	4.12 KB	-r--r--r--	2014-12-27 11:48
tied_hook.t	4.59 KB	-r--r--r--	2014-12-27 11:48
tied_items.t	1.07 KB	-r--r--r--	2014-12-27 11:48
tied_store.t	924 B	-r--r--r--	2014-12-27 11:48
utf8.t	1.14 KB	-r--r--r--	2014-12-27 11:48
utf8hash.t	5.26 KB	-r--r--r--	2014-12-27 11:48
weak.t	3.46 KB	-r--r--r--	2014-12-27 11:48

Rename

#!/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 {
    unshift @INC, 't';
    unshift @INC, 't/compat' if $] < 5.006002;
    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::More;
        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];

is(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;
    is(ref($oh_dear), "ARRAY", "dclone - circular overload");
    is($oh_dear->[0], "keep it so", "amagic ok 1");
    is($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;
    is($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;
    is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
    is($oh_dear->[0], "keep it so", "amagic ok 1");
    is($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;
    is(ref($oh_dear), "ARRAY", "dclone - before a closure dclone");
    is($oh_dear->[0], "keep it so", "amagic ok 1");
    is($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;
    is(ref($oh_dear), "ARRAY", "dclone - between a closure dclone");
    is($oh_dear->[0], "keep it so", "amagic ok 1");
    is($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;
    is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
    is($oh_dear->[1], "keep it so", "amagic ok 1");
    is($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";
}