-
Notifications
You must be signed in to change notification settings - Fork 135
/
Util.pm
210 lines (158 loc) · 6.16 KB
/
Util.pm
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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
module Test::Util;
use Test;
proto sub is_run(|) is export { * }
# No input, no test name
multi sub is_run( Str $code, %expected, *%o ) {
return is_run( $code, '', %expected, '', |%o );
}
# Has input, but not a test name
multi sub is_run( Str $code, Str $input, %expected, *%o ) {
return is_run( $code, $input, %expected, '', |%o );
}
# No input, named
multi sub is_run( Str $code, %expected, Str $name, *%o ) {
return is_run( $code, '', %expected, $name, |%o );
}
multi sub is_run( Str $code, Str $input, %expected, Str $name, *%o ) {
my %got = get_out( $code, $input, |%o );
# The test may have executed, but if so, the results couldn't be collected.
if %got<test_died> {
return skip 1, 'test died: ' ~ %got<test_died>;
}
my $ok = ?1;
my $tests_aggregated = 0;
my @diag_q;
# We check each of the attributes and pass the test only if all are good.
for <status out err> -> $attr {
# Attributes not specified are not tested.
next if !(%expected{$attr}:exists);
my $attr_good = %got{$attr} ~~ %expected{$attr};
# The check for this attribute failed.
# Note why for a diag() after the test failure is reported.
if !$attr_good {
@diag_q.push( " got $attr: {%got{$attr}.perl}" );
if %expected{$attr} ~~ Str|Num {
@diag_q.push( "expected $attr: {%expected{$attr}.perl}" );
}
}
$ok = $ok && $attr_good;
$tests_aggregated++;
}
if $tests_aggregated == 0 {
return skip 1, 'nothing tested';
}
ok ?$ok, $name;
diag $_ for @diag_q;
return;
}
our sub run( Str $code, Str $input = '', *%o) {
my %got = get_out( $code, $input, |%o );
if %got<err>:exists && %got<err>.chars {
diag 'error: ' ~ %got<err>;
}
if %got<test_died>:exists && %got<err>.chars {
diag 'test died: ' ~ %got<test_died>;
}
return %got<out>;
}
sub get_out( Str $code, Str $input?, :@args, :@compiler-args) is export {
my $fnbase = 'getout';
$fnbase ~= '-' ~ $*PID if defined $*PID;
$fnbase ~= '-' ~ 1_000_000.rand.Int;
my $clobber = sub ($a, $b) {
my $fh = open $a, :w
or die "Can't create '$a': $!";
$fh.print( $b );
$fh.close or die "close failed: $!";
};
my @actual_args;
my $sep = $*DISTRO.is-win ?? q["] !! q['];
for @args {
if /<['"]>/ {
die "Command line arguments may not contain single or double quotes";
}
@actual_args.push: $sep ~ $_ ~ $sep;
}
my %out;
try {
$clobber( "$fnbase.in", $input );
$clobber( "$fnbase.code", $code ) if defined $code;
my $perl6 = ~$*EXECUTABLE;
my $cmd = $perl6 ~~ m:i/niecza/ ?? "mono $perl6 " !! "$perl6 ";
$perl6 ~~ s{^perl6} = './perl6';
$cmd = $perl6 ~ ' ';
$cmd ~= @compiler-args.join(' ') ~ ' ' if @compiler-args;
$cmd ~= $fnbase ~ '.code' if $code.defined;
$cmd ~= " @actual_args.join(' ') < $fnbase.in > $fnbase.out 2> $fnbase.err";
# diag("Command line: $cmd");
%out<status> = +shell( $cmd ) +< 8;
%out<out> = slurp "$fnbase.out";
%out<err> = slurp "$fnbase.err";
CATCH { %out<test_died> = ~$! }
}
# Try to delete all the temp files written. If any survive, die.
my @files = map { "$fnbase.$_" }, <code in out err>;
for @files -> $f {
try unlink $f;
if $f.IO ~~ :e {
die "Can't unlink '$f'";
}
}
return %out;
}
=begin pod
=head1 NAME
Test::Util - Extra utility code for testing
=head1 SYNOPSIS
use Test;
use Test::Util;
is_run( 'say $*IN.lines', # code to run
'GIGO', # input for code
{ out => "GIGO\n", err => '', status => 0 }, # results expected
'input comes back out' ); # test name
=head1 DESCRIPTION
This module is for test code that would be useful
across Perl 6 implementations.
=head1 FUNCTIONS
=head2 is_run( Str $code, Str $input?, %wanted, Str $name? )
It runs the code given, feeding it the input given, and collects results
in the form of its stdout, stderr, and exit status. The %wanted hash
specifies which of these to check and what to check them against.
Every item in the hash must "match" for the is_run() test to pass.
For example:
{
out => "Hello world!\n", # outputs Hello world!
err => '', # no error output
status => 0, # standard successful exit
},
Any of those items not present in the %wanted hash will not be tested
(that is, the test passes regardless of the results of those items).
For example, if 'status' is not specified, the test passes regardless
of what the code's exit status was.
Each item can be a string, a Regexp, or a Callable. Strings must match
exactly.
A Callable is passed the result, and the test passes
if the Callable returns a true value.
For example:
is_run( 'rand.say', { out => sub { $^a > 0 && $^a < 1 }, err => '' },
'output of rand is between zero and one' );
=head3 Errors
If the underlying code could not be executed properly (e.g., because
temp files could not be accessed), is_run() will skip().
If the %wanted hash passed in does not contain any of the items it checks,
is_run() will skip() (but it will still execute the code not being tested).
is_run() depends on get_out(), which might die. In that case, it dies
also (this error is not trapped).
=head2 get_out( Str $code, Str $input?, :@args )
This is what is_run() uses to do its work. It returns a hash with the
'status', 'err', and 'out' of the code run. In addition, if the hash
it returns has an element named 'test_died', that means it failed to
either run the code or collect the results. Any other elements of the
hash should be disregarded.
C<:@args> can contain command line arguments passed to the program.
They may not contain quote characters, or get_out will complain loudly.
=head3 Errors
This will die if it can't clean up the temp files it uses to do its work.
All other errors should be trapped and reported via the 'test_died' item.
=end pod
# vim: ft=perl6