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