1*5759b3d2Safresh1#!./perl 2*5759b3d2Safresh1 3*5759b3d2Safresh1use Test::More tests => 16; 4*5759b3d2Safresh1 5*5759b3d2Safresh1use Storable (); 6*5759b3d2Safresh1 7*5759b3d2Safresh1use warnings; 8*5759b3d2Safresh1use strict; 9*5759b3d2Safresh1 10*5759b3d2Safresh1package TEST; 11*5759b3d2Safresh1 12*5759b3d2Safresh1sub make { 13*5759b3d2Safresh1 my $pkg = shift; 14*5759b3d2Safresh1 return bless { a => 1, b => 2 }, $pkg; 15*5759b3d2Safresh1} 16*5759b3d2Safresh1 17*5759b3d2Safresh1package TIED_HASH; 18*5759b3d2Safresh1 19*5759b3d2Safresh1sub TIEHASH { 20*5759b3d2Safresh1 my $pkg = shift; 21*5759b3d2Safresh1 return bless { a => 1, b => 2 }, $pkg; 22*5759b3d2Safresh1} 23*5759b3d2Safresh1 24*5759b3d2Safresh1sub FETCH { 25*5759b3d2Safresh1 my ($self, $key) = @_; 26*5759b3d2Safresh1 return $self->{$key}; 27*5759b3d2Safresh1} 28*5759b3d2Safresh1 29*5759b3d2Safresh1sub STORE { 30*5759b3d2Safresh1 my ($self, $key, $value) = @_; 31*5759b3d2Safresh1 $self->{$key} = $value; 32*5759b3d2Safresh1} 33*5759b3d2Safresh1 34*5759b3d2Safresh1sub FIRSTKEY { 35*5759b3d2Safresh1 my $self = shift; 36*5759b3d2Safresh1 keys %$self; 37*5759b3d2Safresh1 return each %$self; 38*5759b3d2Safresh1} 39*5759b3d2Safresh1 40*5759b3d2Safresh1sub NEXTKEY { 41*5759b3d2Safresh1 my $self = shift; 42*5759b3d2Safresh1 return each %{$self}; 43*5759b3d2Safresh1} 44*5759b3d2Safresh1 45*5759b3d2Safresh1sub EXISTS { 46*5759b3d2Safresh1 my ($self, $key) = @_; 47*5759b3d2Safresh1 return exists $self->{$key}; 48*5759b3d2Safresh1} 49*5759b3d2Safresh1 50*5759b3d2Safresh1package main; 51*5759b3d2Safresh1 52*5759b3d2Safresh1{ 53*5759b3d2Safresh1 my $obj = TEST->make; 54*5759b3d2Safresh1 55*5759b3d2Safresh1 is_deeply($obj, { a => 1, b => 2 }, "object contains correct data"); 56*5759b3d2Safresh1 57*5759b3d2Safresh1 my $frozen = Storable::freeze($obj); 58*5759b3d2Safresh1 my ($t1, $t2) = Storable::thaw($frozen); 59*5759b3d2Safresh1 60*5759b3d2Safresh1 { 61*5759b3d2Safresh1 no warnings 'once'; 62*5759b3d2Safresh1 local $Storable::flags = Storable::FLAGS_COMPAT(); 63*5759b3d2Safresh1 $t2 = Storable::thaw($frozen); 64*5759b3d2Safresh1 } 65*5759b3d2Safresh1 66*5759b3d2Safresh1 is_deeply($t1, $t2, "objects contain matching data"); 67*5759b3d2Safresh1 is(ref $t1, 'TEST', "default object is blessed"); 68*5759b3d2Safresh1 is(ref $t2, 'TEST', "compat object is blessed into correct class"); 69*5759b3d2Safresh1 70*5759b3d2Safresh1 my $t3 = Storable::thaw($frozen, Storable::FLAGS_COMPAT()); 71*5759b3d2Safresh1 is_deeply($t2, $t3, "objects contain matching data (explicit test)"); 72*5759b3d2Safresh1 is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test)"); 73*5759b3d2Safresh1 74*5759b3d2Safresh1 my $t4 = Storable::thaw($frozen, Storable::BLESS_OK()); 75*5759b3d2Safresh1 is_deeply($t2, $t3, "objects contain matching data (explicit test for bless)"); 76*5759b3d2Safresh1 is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test for bless)"); 77*5759b3d2Safresh1 78*5759b3d2Safresh1 { 79*5759b3d2Safresh1 no warnings 'once'; 80*5759b3d2Safresh1 local $Storable::flags = Storable::FLAGS_COMPAT(); 81*5759b3d2Safresh1 my $t5 = Storable::thaw($frozen, 0); 82*5759b3d2Safresh1 my $t6 = Storable::thaw($frozen, Storable::TIE_OK()); 83*5759b3d2Safresh1 84*5759b3d2Safresh1 is_deeply($t1, $t5, "objects contain matching data"); 85*5759b3d2Safresh1 is_deeply($t1, $t6, "objects contain matching data for TIE_OK"); 86*5759b3d2Safresh1 is(ref $t5, 'HASH', "default object is unblessed"); 87*5759b3d2Safresh1 is(ref $t6, 'HASH', "TIE_OK object is unblessed"); 88*5759b3d2Safresh1 } 89*5759b3d2Safresh1} 90*5759b3d2Safresh1 91*5759b3d2Safresh1{ 92*5759b3d2Safresh1 tie my %hash, 'TIED_HASH'; 93*5759b3d2Safresh1 ok(tied %hash, "hash is tied"); 94*5759b3d2Safresh1 my $obj = { bow => \%hash }; 95*5759b3d2Safresh1 96*5759b3d2Safresh1 my $frozen = Storable::freeze($obj); 97*5759b3d2Safresh1 my $t1 = Storable::thaw($frozen, Storable::FLAGS_COMPAT()); 98*5759b3d2Safresh1 my $t2 = eval { Storable::thaw($frozen); }; 99*5759b3d2Safresh1 100*5759b3d2Safresh1 ok(!$@, "trying to thaw a tied value succeeds"); 101*5759b3d2Safresh1 ok(tied %{$t1->{bow}}, "compat object is tied"); 102*5759b3d2Safresh1 is(ref tied %{$t1->{bow}}, 'TIED_HASH', "compat object is tied into correct class"); 103*5759b3d2Safresh1} 104