#!perl
use strict;
use warnings;
use Sereal::Encoder;
use Sereal::Encoder::Constants qw(:all);
use File::Spec;
use Test::Warn;
use lib File::Spec->catdir(qw(t lib));
BEGIN {
lib->import('lib')
if !-d 't';
}
use Sereal::TestSet qw(:all);
use Test::More tests => 19;
my ($ok, $err, $out);
# croak_on_bless test
SCOPE: {
my $e = Sereal::Encoder->new({
croak_on_bless => 1,
});
is($e->encode(1), Header().integer(1), "Encoder works before exception");
$ok = eval{$out = $e->encode(bless({}, "Foo")); 1};
$err = $@ || 'Zombie error';
ok(!$ok, "Object throws exception");
ok($err =~ /object/i, 'Exception refers to object');
is($e->encode(1), Header().integer(1), "Encoder works after exception");
$ok = eval {$out = $e->encode({}); 1};
ok($ok, "Non-blessed hash does not throw exception");
# test that code refs throw exception
$ok = eval {$out = $e->encode(sub {}); 1};
ok(!$ok, "Code ref throws exception");
}
# test that code refs with undef_unknown don't throw exceptions
SCOPE: {
my $e = Sereal::Encoder->new({undef_unknown => 1});
$ok = eval {$out = $e->encode(sub{}); 1};
$err = $@ || 'Zombie error';
ok($ok, "undef_unknown makes CODE encoding not fail");
is($out, Header() . chr(SRL_HDR_UNDEF), "output is undef")
or do {
hobodecode($out) if $ENV{DEBUG_SEREAL};
}
}
# test that code refs with stringify_unknown don't throw exceptions
SCOPE: {
my $e = Sereal::Encoder->new({stringify_unknown => 1});
my $sub = sub{};
$ok = eval {$out = $e->encode($sub); 1};
$err = $@ || 'Zombie error';
ok($ok, "stringify_unknown makes CODE encoding not fail");
my $str = $e->encode("$sub");
is($out, $str, "output is stringified ref")
or do {
hobodecode($out), hobodecode($str) if $ENV{DEBUG_SEREAL};
}
}
# test that code refs with warn_unknown do warn
SCOPE: {
my $e = Sereal::Encoder->new({stringify_unknown => 1, warn_unknown => 1});
my $sub = sub{};
warning_like
{
$ok = eval {$out = $e->encode($sub); 1};
}
qr/Sereal/,
"warn_unknown warns about stringified sub";
}
# test that blessed code refs with stringify_unknown don't throw exceptions
SCOPE: {
my $e = Sereal::Encoder->new({stringify_unknown => 1});
my $sub = bless(sub {}, "Foo");
$ok = eval {$out = $e->encode($sub); 1};
$err = $@ || 'Zombie error';
ok($ok, "stringify_unknown makes CODE encoding not fail");
my $str = $e->encode("$sub");
is($out, $str, "output is stringified ref")
or do {
hobodecode($out), hobodecode($str) if $ENV{DEBUG_SEREAL};
}
}
# dito for string overloading
SCOPE: {
SCOPE2: {
package BlessedCodeRefOverload;
use overload '""' => sub {$_[0]->()};
sub new {
my ($class, $data) = @_;
bless sub {return $data} => __PACKAGE__;
}
}
SCOPE3: {
package BlessedCodeRef;
sub new {
my ($class, $data) = @_;
bless sub {return $data} => __PACKAGE__;
}
}
my $e = Sereal::Encoder->new({stringify_unknown => 1});
my $sub = BlessedCodeRefOverload->new("hello");
is("$sub", "hello", "BlessedCodeRefOverload stringification actually works as designed");
$ok = eval {$out = $e->encode($sub); 1};
$err = $@ || 'Zombie error';
ok($ok, "stringify_unknown makes CODE encoding not fail");
my $str = $e->encode("$sub");
is($out, $str, "output is stringified ref")
or do {
hobodecode($out), hobodecode($str) if $ENV{DEBUG_SEREAL};
};
# test that we get a warning with warn_unknown
$e = Sereal::Encoder->new({stringify_unknown => 1, warn_unknown => 1});
warning_like
{
$ok = eval {$out = $e->encode($sub); 1};
}
qr/Sereal/,
"warn_unknown warns about stringified sub despite overloading";
# Test that we do NOT get a warning with warn_unknown set to -1
# FIXME Test::Warn doesn't have a "no_warnings" function, so let's just
# run this for now and hope the user will be spooked by the warning
# if there is one. Duh.
$e = Sereal::Encoder->new({stringify_unknown => 1, warn_unknown => -1});
$out = $e->encode($sub);
ok(defined $out && $out !~ /CODE/ && $out !~ "Blessed", "RV of encode makes some sense");
# Test that we DO get a warning for non-overloaded unsupported stuff
my $sub2 = BlessedCodeRef->new("hello");
warning_like
{
$ok = eval {$out = $e->encode($sub2); 1};
}
qr/Sereal/,
"warn_unknown == -1 warns about stringified sub without overloading";
}