#!perl
use strict;
use warnings;
# must be loaded before Sereal::TestSet
use Sereal::Encoder qw(encode_sereal);
use Sereal::Encoder::Constants qw(:all);
use File::Spec;
use Test::More;
use Data::Dumper;
use lib File::Spec->catdir(qw(t lib));
BEGIN {
lib->import('lib')
if !-d 't';
}
use Sereal::TestSet qw(:all);
my $ok = have_encoder_and_decoder();
if (not $ok) {
plan skip_all => 'Did not find right version of decoder';
exit 0;
}
my $thaw_called = 0;
my $freeze_called = 0;
package Foo;
sub new {
my $class = shift;
return bless({bar => 1, @_} => $class);
}
sub FREEZE {
my ($self, $serializer) = @_;
$freeze_called = $serializer eq 'Sereal' ? 1 : 0;
return "frozen object", 12, [2];
}
sub THAW {
my ($class, $serializer, @data) = @_;
$thaw_called = $serializer eq 'Sereal' ? 1 : 0;
Test::More::is_deeply(\@data, ["frozen object", 12, [2]], "Array of frozen values roundtrips");
return Foo->new();
}
package Bar;
sub new {
my $class = shift;
return bless({bar => 1, @_} => $class);
}
sub FREEZE {
my ($self, $serializer) = @_;
return "frozen Bar";
}
package main;
my $enc = Sereal::Encoder->new({freeze_callbacks => 1});
my $srl = $enc->encode(Foo->new());
ok($freeze_called, "FREEZE was invoked");
# Simple round-trip test
my $dec = Sereal::Decoder->new;
my $obj = $dec->decode($srl);
ok(defined($obj));
isa_ok($obj, "Foo");
is(eval{$obj->{bar}}, 1) or diag Dumper($obj);
# Test referential integrity
my $foo = Foo->new;
my $data = [$foo, $foo];
$srl = $enc->encode($data);
ok($srl =~ /frozen object/);
my $out = $dec->decode($srl);
is_deeply($out, $data, "Roundtrip works");
cmp_ok($out->[0], "eq", $out->[1],
"Referential integrity: multiple RVs do not turn into clones")
or diag(Dumper($data,$out));
my $barobj = Bar->new;
$srl = $enc->encode($barobj);
ok(not(eval {$dec->decode($srl); 1}), "Decoding without THAW barfs");
# Multiple-object-same-class test from Christian Hansen
{
package MyObject;
sub from_num {
my ($class, $num) = @_;
return bless { num => $num }, $class;
}
sub num {
my ($self) = @_;
return $self->{num};
}
sub FREEZE {
return $_[0]->num;
}
sub THAW {
my ($class, undef, $num) = @_;
return $class->from_num($num);
}
}
my @objects = map { MyObject->from_num($_) } (10, 20, 30);
my $encoded = encode_sereal([ @objects ], { freeze_callbacks => 1 });
my $decoded = Sereal::Decoder::decode_sereal($encoded);
isa_ok($decoded, 'ARRAY');
is(scalar @$decoded, 3, 'array has three elements');
isa_ok($decoded->[0], 'MyObject', 'first element');
isa_ok($decoded->[1], 'MyObject', 'second element');
isa_ok($decoded->[2], 'MyObject', 'third element');
is($decoded->[0]->num, 10, 'first MyObject->num');
is($decoded->[1]->num, 20, 'second MyObject->num');
is($decoded->[2]->num, 30, 'third MyObject->num');
done_testing();