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