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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
#!perl
use strict;
use warnings;
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;
use Sereal::Encoder;
use Sereal::Encoder::Constants qw(:all);
BEGIN {
if (not have_encoder_and_decoder()) {
plan skip_all => 'Did not find right version of decoder';
exit 0;
} else {
plan tests => 19;
}
}
use Sereal::Decoder;
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";
}
|
