|
Packit |
14c646 |
#!./perl
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
use Test::More tests => 16;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
use Storable ();
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
use warnings;
|
|
Packit |
14c646 |
use strict;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
package TEST;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub make {
|
|
Packit |
14c646 |
my $pkg = shift;
|
|
Packit |
14c646 |
return bless { a => 1, b => 2 }, $pkg;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
package TIED_HASH;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub TIEHASH {
|
|
Packit |
14c646 |
my $pkg = shift;
|
|
Packit |
14c646 |
return bless { a => 1, b => 2 }, $pkg;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub FETCH {
|
|
Packit |
14c646 |
my ($self, $key) = @_;
|
|
Packit |
14c646 |
return $self->{$key};
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub STORE {
|
|
Packit |
14c646 |
my ($self, $key, $value) = @_;
|
|
Packit |
14c646 |
$self->{$key} = $value;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub FIRSTKEY {
|
|
Packit |
14c646 |
my $self = shift;
|
|
Packit |
14c646 |
keys %$self;
|
|
Packit |
14c646 |
return each %$self;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub NEXTKEY {
|
|
Packit |
14c646 |
my $self = shift;
|
|
Packit |
14c646 |
return each %{$self};
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub EXISTS {
|
|
Packit |
14c646 |
my ($self, $key) = @_;
|
|
Packit |
14c646 |
return exists $self->{$key};
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
package main;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
{
|
|
Packit |
14c646 |
my $obj = TEST->make;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
is_deeply($obj, { a => 1, b => 2 }, "object contains correct data");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $frozen = Storable::freeze($obj);
|
|
Packit |
14c646 |
my ($t1, $t2) = Storable::thaw($frozen);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
{
|
|
Packit |
14c646 |
no warnings 'once';
|
|
Packit |
14c646 |
local $Storable::flags = Storable::FLAGS_COMPAT();
|
|
Packit |
14c646 |
$t2 = Storable::thaw($frozen);
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
is_deeply($t1, $t2, "objects contain matching data");
|
|
Packit |
14c646 |
is(ref $t1, 'TEST', "default object is blessed");
|
|
Packit |
14c646 |
is(ref $t2, 'TEST', "compat object is blessed into correct class");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $t3 = Storable::thaw($frozen, Storable::FLAGS_COMPAT());
|
|
Packit |
14c646 |
is_deeply($t2, $t3, "objects contain matching data (explicit test)");
|
|
Packit |
14c646 |
is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test)");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $t4 = Storable::thaw($frozen, Storable::BLESS_OK());
|
|
Packit |
14c646 |
is_deeply($t2, $t3, "objects contain matching data (explicit test for bless)");
|
|
Packit |
14c646 |
is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test for bless)");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
{
|
|
Packit |
14c646 |
no warnings 'once';
|
|
Packit |
14c646 |
local $Storable::flags = Storable::FLAGS_COMPAT();
|
|
Packit |
14c646 |
my $t5 = Storable::thaw($frozen, 0);
|
|
Packit |
14c646 |
my $t6 = Storable::thaw($frozen, Storable::TIE_OK());
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
is_deeply($t1, $t5, "objects contain matching data");
|
|
Packit |
14c646 |
is_deeply($t1, $t6, "objects contain matching data for TIE_OK");
|
|
Packit |
14c646 |
is(ref $t5, 'HASH', "default object is unblessed");
|
|
Packit |
14c646 |
is(ref $t6, 'HASH', "TIE_OK object is unblessed");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
{
|
|
Packit |
14c646 |
tie my %hash, 'TIED_HASH';
|
|
Packit |
14c646 |
ok(tied %hash, "hash is tied");
|
|
Packit |
14c646 |
my $obj = { bow => \%hash };
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $frozen = Storable::freeze($obj);
|
|
Packit |
14c646 |
my $t1 = Storable::thaw($frozen, Storable::FLAGS_COMPAT());
|
|
Packit |
14c646 |
my $t2 = eval { Storable::thaw($frozen); };
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
ok(!$@, "trying to thaw a tied value succeeds");
|
|
Packit |
14c646 |
ok(tied %{$t1->{bow}}, "compat object is tied");
|
|
Packit |
14c646 |
is(ref tied %{$t1->{bow}}, 'TIED_HASH', "compat object is tied into correct class");
|
|
Packit |
14c646 |
}
|