#!perl
use strict;
use warnings;
use Sereal::Decoder qw(decode_sereal looks_like_sereal scalar_looks_like_sereal);
use Sereal::Decoder::Constants qw(:all);
use Data::Dumper;
use File::Spec;
use Devel::Peek;
use Test::More;
sub doc {
my ($high, $version, $good)= @_;
return(
($high eq "utf8" ? SRL_MAGIC_STRING_HIGHBIT_UTF8 :
$high ? SRL_MAGIC_STRING_HIGHBIT : SRL_MAGIC_STRING) .
chr($version) .
chr(0) .
($good ? chr(SRL_HDR_UNDEF) : "")
);
}
# Simple tests for looks_like_sereal.
my @tests = (
# input, bool outcome, name
[ "", "", "empty string is not Sereal"],
[ undef, "", "undef string is not Sereal"],
[ {}, "", "{} is not Sereal"],
[ [], "", "[] is not Sereal"],
[ SRL_MAGIC_STRING, "", "SRL_MAGIC_STRING alone is not Sereal"],
[ doc(0, 0, 1), "", "SRL_MAGIC_STRING with bad protocol is not Sereal"],
[ doc(0, 1, 0), "", "SRL_MAGIC_STRING protocol 1 with short body is not Sereal"],
[ doc(0, 1, 1), 1, "SRL_MAGIC_STRING protocol 1 with small payload is Sereal"],
[ doc(0, 2, 0), "", "SRL_MAGIC_STRING protocol 2 with short body is not Sereal"],
[ doc(0, 2, 1), 2, "SRL_MAGIC_STRING protocol 2 with small payload is Sereal"],
[ doc(0, 3, 0), "", "SRL_MAGIC_STRING protocol 3 with short body is not Sereal"],
[ doc(0, 3, 1), "", "SRL_MAGIC_STRING protocol 3 with small payload is Sereal"],
[SRL_MAGIC_STRING_HIGHBIT, "", "SRL_MAGIC_STRING_HIGHBIT alone is not Sereal"],
[ doc( 1, 0, 1), "", "SRL_MAGIC_STRING_HIGHBIT with bad protocol is not Sereal"],
[ doc( 1, 1, 0), "", "SRL_MAGIC_STRING_HIGHBIT protocol 1 with short body is not Sereal"],
[ doc( 1, 1, 1), "", "SRL_MAGIC_STRING_HIGHBIT protocol 1 with small payload is not Sereal"],
[ doc( 1, 2, 0), "", "SRL_MAGIC_STRING_HIGHBIT protocol 2 with short body is not Sereal"],
[ doc( 1, 2, 1), "", "SRL_MAGIC_STRING_HIGHBIT protocol 2 with small payload is not Sereal"],
[ doc( 1, 3, 0), "", "SRL_MAGIC_STRING_HIGHBIT protocol 3 with short body is not Sereal"],
[ doc( 1, 3, 1), 3, "SRL_MAGIC_STRING_HIGHBIT protocol 3 with small payload is Sereal"],
[ doc("utf8", 3, 1), 0, "SRL_MAGIC_STRING_HIGHBIT_UTF8 protocol 3 with small payload is identified as utf8"],
["=Srl". chr(1) . chr(0) . chr(SRL_HDR_UNDEF), "", "wrong magic string is not Sereal"],
);
plan tests => 2 + @tests * 5;
is(prototype(\&looks_like_sereal), undef);
is(prototype(\&scalar_looks_like_sereal), "\$");
my $decoder = Sereal::Decoder->new;
foreach my $t (@tests) {
my ($input, $outcome, $name) = @$t;
is( scalar_looks_like_sereal($input), $outcome, "$name (new function oppable)" );
is( &scalar_looks_like_sereal($input), $outcome, "$name (new function non-oppable)" );
is( looks_like_sereal($input), $outcome, "$name (old function)" );
is( $decoder->looks_like_sereal($input), $outcome, "$name (object method)" );
is( Sereal::Decoder->looks_like_sereal($input), $outcome, "$name (class method)" );
}