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
|
package Test::LMU;
use strict;
require Exporter;
use Test::More import => ['!pass'];
use Carp qw/croak/;
use base qw(Test::Builder::Module Exporter);
our @EXPORT = qw(freeze is_true is_false is_defined is_undef is_dying not_dying grow_stack leak_free_ok);
our @EXPORT_OK = qw(freeze is_true is_false is_defined is_undef is_dying not_dying grow_stack leak_free_ok);
my $CLASS = __PACKAGE__;
eval "use Storable qw();";
$@ or Storable->import(qw(freeze));
__PACKAGE__->can("freeze") or eval <<'EOFR';
use inc::latest 'JSON::PP';
use JSON::PP qw();
sub freeze {
my $json = JSON::PP->new();
$json->encode($_[0]);
}
EOFR
######################################################################
# Support Functions
sub is_true
{
@_ == 1 or croak "Expected 1 param";
my $tb = $CLASS->builder();
$tb->ok($_[0], "is_true ()");
}
sub is_false
{
@_ == 1 or croak "Expected 1 param";
my $tb = $CLASS->builder();
$tb->ok(!$_[0], "is_false()");
}
sub is_defined
{
@_ < 1 or croak "Expected 0..1 param";
my $tb = $CLASS->builder();
$tb->ok(defined($_[0]), "is_defined ()");
}
sub is_undef
{
@_ <= 1 or croak "Expected 0..1 param";
my $tb = $CLASS->builder();
$tb->ok(!defined($_[0]), "is_undef()");
}
sub is_dying
{
@_ == 1 or @_ == 2 or croak "is_dying(name => code)";
my ($name, $code);
$name = shift if @_ == 2;
$code = shift;
ref $code eq "CODE" or croak "is_dying(name => code)";
my $tb = $CLASS->builder();
eval { $code->(); };
my $except = $@;
chomp $except;
$tb->ok($except, "$name is_dying()") and note($except);
}
sub not_dying
{
@_ == 1 or @_ == 2 or croak "not_dying(name => code)";
my ($name, $code);
$name = shift if @_ == 2;
$code = shift;
ref $code eq "CODE" or croak "not_dying(name => code)";
my $tb = $CLASS->builder();
eval { $code->(); };
my $except = $@;
chomp $except;
$tb->ok(!$except, "$name not_dying()") or diag($except);
}
my @bigary = (1) x 500;
sub func { }
sub grow_stack
{
func(@bigary);
}
my $have_test_leak_trace = eval { require Test::LeakTrace; 1 };
sub leak_free_ok
{
while (@_)
{
my $name = shift;
my $code = shift;
SKIP:
{
skip 'Test::LeakTrace not installed', 1 unless $have_test_leak_trace;
local $Test::Builder::Level = $Test::Builder::Level + 1;
&Test::LeakTrace::no_leaks_ok($code, "No memory leaks in $name");
}
}
}
{
package DieOnStringify;
use overload '""' => \&stringify;
sub new { bless {}, shift }
sub stringify { die 'DieOnStringify exception' }
}
1;
=head1 AUTHOR
Jens Rehsack E<lt>rehsack AT cpan.orgE<gt>
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2013 - 2017 by Jens Rehsack
All code added with 0.417 or later is licensed under the Apache License,
Version 2.0 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
All code until 0.416 is licensed under the same terms as Perl itself,
either Perl version 5.8.4 or, at your option, any later version of
Perl 5 you may have available.
=cut
|
