1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
#!perl
use strict;
use warnings;
use File::Spec;
use lib File::Spec->catdir(qw(t lib));
BEGIN {
lib->import('lib')
if !-d 't';
}
use Sereal::TestSet;
use Test::More;
use Data::Dumper;
use File::Spec;
use Devel::Peek;
use Sereal::Decoder qw(decode_sereal looks_like_sereal scalar_looks_like_sereal);
use Sereal::Decoder::Constants qw(:all);
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 => 3 + @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)" );
}
SKIP:{
skip "Build test only needs to run on linux", 1 if $^O ne "linux";
skip "Test requires Test::MemoryGrowth", 1 if !eval "require Test::MemoryGrowth; 1";
Test::MemoryGrowth::no_growth(sub{ looks_like_sereal(doc(1,3,1)) },'looks_like_sereal should not leak');
}
|
