Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 384 lines (349 sloc) 10.812 kb
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
6 my %OPTS;
7 while( $_ = $ARGV[0], /^-/ ) {
8 shift;
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
9 last if $_ eq '--';
10 if (/^--([^=]+)(=(.*))?$/) {
11 $OPTS{$1} = $3 // 1;
12 }
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
13 }
14
301db81 @coke respect .spec_config
coke authored
15 my $ME; # implementation
16 my $IN; # test file
17 my $OUT; # fudged file
18
19 if (-f ".spec_config") {
20 open my $cf, "<", ".spec_config";
21 while (<$cf>) {
22 if (m/^\bname\b\s*=\s*(\w+)/) {
23 $ME = $1;
24 }
25 }
26 }
27
28 if (@ARGV == 3) {
29 # impl test fudged
30 $ME = shift;
31 $IN = shift;
32 $OUT = shift;
33 } elsif (@ARGV == 1) {
34 # test
35 $IN = shift;
36 } elsif (@ARGV == 2) {
37 my $arg = shift;
5e75fe9 @ronaldxs The ~~ smart match requires Perl 5.10 and rakudo is supposed to be OK wi...
ronaldxs authored
38 if ($arg =~ /\.t$/) {
301db81 @coke respect .spec_config
coke authored
39 # test fudged
40 $IN = $arg;
41 $OUT = shift;
42 } else {
43 # impl test
44 $ME = $arg;
45 $IN = shift;
46 }
47 }
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
48
5118cd4 [fudge] improved usage message listing verbs
lwall authored
49 if (!$OUT and $IN) {
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
50 ($OUT = $IN) =~ s/\.t$/.$ME/ or $OUT .= ".$ME";
51 }
301db81 @coke respect .spec_config
coke authored
52
d38ece7 @moritz [fudge] give a better error message for missing test files
moritz authored
53 unless ($ME and $IN and $OUT) {
5118cd4 [fudge] improved usage message listing verbs
lwall authored
54
55 die <<"USAGE";
301db81 @coke respect .spec_config
coke authored
56 Usage: $0 [options] [implname] testfilename [fudgedtestfilename]
57
58 implname, if not specified on the command line, is pulled from the
59 .spec_config file in your compiler's directory.
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
60
61 Options:
62 --keep-exit-code
63 by default, fudge modifies the exit code for fudged test files to 1.
64 supplying this option will suppress that behavior.
5118cd4 [fudge] improved usage message listing verbs
lwall authored
65
66 Verbs:
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
67 #?implname [num] skip 'reason'
68 comment out num tests or blocks and call skip(num)
a2d9517 [fudge] implement #?DOES
lwall authored
69
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
70 #?implname [num] eval 'reason'
71 eval num tests or blocks and skip(num) on parsefail
a2d9517 [fudge] implement #?DOES
lwall authored
72
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
73 #?implname [num] try 'reason'
74 try num tests or blocks and fail on exception
a2d9517 [fudge] implement #?DOES
lwall authored
75
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
76 #?implname [num] todo 'reason', :by<1.2.3>
77 run num tests or blocks with todo() preset
a2d9517 [fudge] implement #?DOES
lwall authored
78
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
79 #?implname emit your_ad_here();
80 just pass through your_ad_here();
a2d9517 [fudge] implement #?DOES
lwall authored
81
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
82 #?v6+ [num|*] ['reason']
83 #?v6.0+ [num|*] ['reason']
84 #?v6.0.0..* [num|*] ['reason']
85 #?v6.0.0..v6.0.5 [num|*] ['reason']
d214528 @FROGGS allow to skip for a matching Perl 6 language version
FROGGS authored
86 run num/all tests for the given Perl 6 language version. Skipped
87 on non-matching Perl 6 language versions.
88
89 #?v6+ [num|*] skip|emit|todo|eval|try ['reason']
90 skip or todo (etc) tests for the matching Perl 6 language version.
91 Non-matching Perl 6 language versions are left untouched.
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
92
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
93 #?DOES count
94 for all implementations, the following thing does count tests
95 (disables any attempt to autocount tests within the construct)
96 when construct is a sub, registers the sub name as tester
97 (and multiplies calls to tester sub by count tests)
a2d9517 [fudge] implement #?DOES
lwall authored
98
99 where
fcf62f1 @coke Remove any Pugs fudges
coke authored
100 implname is the lc name of your implementation, e.g. niecza or rakudo
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
101 num is the number of statements or blocks to preprocess, defaults to 1
102 count is how many tests the following construct counts as
1f38222 @sorear Extend fudge to allow an implementation "rakudo.jvm" that matches #?raku...
sorear authored
103 implnames are compared as a prefix match on sequences of components,
104 i.e. #?rakudo matches rakudo.jvm
a2d9517 [fudge] implement #?DOES
lwall authored
105
5118cd4 [fudge] improved usage message listing verbs
lwall authored
106 USAGE
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
107 }
e34b309 @felher make fudge print usage if no arguments are given
felher authored
108 unless (-e $IN) {
109 die "$0: No such test file '$IN'\n";
110 }
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
111
2372496 @coke Always attempt to refudge.
coke authored
112 unlink $OUT; # old fudged version, may or may not regenerate...
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
113
114 my $REALLY_FUDGED = 0;
115 my $OUTPUT = "";
116 my $FUDGE = "";
117 our $PENDING = 0;
118 my $ARGS = '';
b6e2526 @usev6 Register all functions from test modules used in roast
usev6 authored
119 my $IS = _register_functions( # regex with test functions used in roast
120 # from Test
09fbd75 @lizmat Make sure we will fudge kebabcased test functions
lizmat authored
121 qw(
122 cmp_ok cmp-ok
123 dies_ok dies-ok
124 eval_dies_ok eval-dies-ok
125 eval_lives_ok eval-lives-ok
126 flunk
127 is
128 is_approx is-approx
129 is_deeply is-deeply
130 isa_ok isa-ok
131 isnt
132 like
133 lives_ok lives-ok
134 nok
135 ok
136 pass
137 throws_like throws-like
138 unlike
139 use_ok use-ok
140 ),
b6e2526 @usev6 Register all functions from test modules used in roast
usev6 authored
141 # from Test::Util
09fbd75 @lizmat Make sure we will fudge kebabcased test functions
lizmat authored
142 qw(
143 is_run is-run
144 ),
b6e2526 @usev6 Register all functions from test modules used in roast
usev6 authored
145 # from Test::Tap
09fbd75 @lizmat Make sure we will fudge kebabcased test functions
lizmat authored
146 qw(
147 tap-ok
148 ),
b6e2526 @usev6 Register all functions from test modules used in roast
usev6 authored
149 # from Test::Compile
09fbd75 @lizmat Make sure we will fudge kebabcased test functions
lizmat authored
150 qw(
151 loads_ok loads-ok
152 precomp_loads_ok precomp-loads-ok
153 loads_is loads-is
154 precomp_loads_is precomp-loads-is
155 ),
b6e2526 @usev6 Register all functions from test modules used in roast
usev6 authored
156 );
a2d9517 [fudge] implement #?DOES
lwall authored
157 my %DOES;
158 my $DOES = 0;
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
159 my $EXIT = $OPTS{'keep-exit-code'} ? '' : 'exit(1);';
160 my $VERSION = $OPTS{'version'} || 'v6.0.0';
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
161
162 @ARGV = ($IN);
163 fudgeblock();
164
165 if ($REALLY_FUDGED) {
166 open OUT, ">", $OUT or die "Can't create $OUT: $!";
167 print OUT $OUTPUT;
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
168 print OUT <<"END";
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
169
170 say "# FUDGED!";
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
171 $EXIT
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
172 END
173 close OUT;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
174 print "$OUT\n"; # pick the output file to run
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
175 }
176 else {
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
177 print "$IN\n"; # pick the input file to run
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
178 }
179
180 sub fudgeblock {
181 while (<>) {
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
182 if (/^\s*\#\?DOES[:\s] \s* (.*)/x) {
183 $DOES = $1;
184 next;
185 }
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
186 if (!$PENDING && /^\s*\#([?!]) (\S+?)[:\s] \s* ((\S*).*)/x) {
187 my $sense = $1;
188 my $name = $2;
189 my $args = $3;
190 my $cmd = $4;
191 my $applies = 0;
192 if ($name =~ /^v\d/) { # Perl 6 language version
d214528 @FROGGS allow to skip for a matching Perl 6 language version
FROGGS authored
193 my $num = $args =~ s/(\d+)\s*// ? $1 : 1;
194 $cmd = 'skip';
195 $applies = !version_matches($VERSION, $name);
196 if ($args =~ s/^(skip|emit|todo|eval|try)\b\s*//) {
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
197 $applies = 1;
d214528 @FROGGS allow to skip for a matching Perl 6 language version
FROGGS authored
198 $cmd = $1;
199 }
200 if ($applies) {
201 $args = "$num $cmd " . ($args || "'Version $name required'")
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
202 }
203 }
204 elsif ($name gt 'a') { # lowercase is compiler name
205 $applies = 1 if substr("$ME.",0,length($name)+1) eq "$name.";
206 }
207 else { # uppercase is env var
208 $applies = $ENV{$name};
209 }
210 $applies = !$applies if $sense eq '!';
211 if ($applies) {
33cafa9 @KrisShannon Completely skip any 'emit' fudges for other implementations
KrisShannon authored
212 $REALLY_FUDGED = 1;
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
213 $ARGS = $args;
33cafa9 @KrisShannon Completely skip any 'emit' fudges for other implementations
KrisShannon authored
214 if ($ARGS =~ s/^emit\s*//) {
215 $_ = $ARGS;
216 next;
217 }
218 if ($ARGS =~ s/^(\d+)\s*//) {
219 $PENDING = $1;
220 }
221 else {
222 $PENDING = 1;
223 }
224 $ARGS =~ s/^(\w+)\s*//;
225 $FUDGE = $1;
dbecd40 @TimToady teach fudge to know about envvars
TimToady authored
226 } elsif ($cmd eq 'emit') {
33cafa9 @KrisShannon Completely skip any 'emit' fudges for other implementations
KrisShannon authored
227 $_ = '';
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
228 next;
229 }
230 }
231
232 next if /^\s*#/;
233 next if /^\s*$/;
234
235 if ($DOES) {
236 if (/^\s*(sub|multi|proto)\b/) {
237 my $tmp = $_;
238 $tmp =~ s/^\s*proto\s+//;
239 $tmp =~ s/^\s*multi\s+//;
240 $tmp =~ s/^\s*sub\s+//;
241 $tmp =~ /^(\w+)/;
242 $DOES{$1} = $DOES;
243 $DOES = 0;
244 next;
245 }
246 }
247
248 next unless $PENDING > 0;
249
250 if (/^\{/) {
251 $PENDING--;
252 if ($FUDGE eq 'todo') {
253 local $PENDING = 999999; # do all in block as one action
254 $OUTPUT .= $_;
255 $DOES = 0; # XXX ignore?
256 fudgeblock();
257 $_ = '';
258 }
259 else {
260 my $more;
261 while (defined($more = <>)) {
262 $_ .= $more;
263 last if $more =~ /^\}/;
264 }
265 my $numtests = $DOES || do {
266 my $tmp = $_;
267 my $nt = 0;
268 $nt += $1 while $tmp =~ s/^#\?DOES[:\s]\s*(\d+).*\n.*\n//m;
269 if (%DOES) {
270 my $does = join('|',keys(%DOES));
271 $nt += $DOES{$1} while $tmp =~ s/^\s*($does)\b//mx;
272 }
273 $nt += () = $tmp =~ m/^(\s*$IS)/mgx;
274 $nt;
275 };
276 if ($FUDGE eq 'skip') {
277 s/^/# /mg;
ca5c864 @tadzik Fix fudge according to the changes in Rakudo 3bbc066
tadzik authored
278 $_ = "skip($ARGS, $numtests);" . $_;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
279 }
280 elsif ($FUDGE eq 'try') {
281 chomp;
c06a9c0 [fudge] fail should be flunk
lwall authored
282 $_ = "(try $_) // flunk($ARGS);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
283 }
284 elsif ($FUDGE eq 'eval') {
285 chomp;
286 s/(['\\])/\\$1/g;
ca5c864 @tadzik Fix fudge according to the changes in Rakudo 3bbc066
tadzik authored
287 $_ = "eval('$_') // skip($ARGS, $numtests);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
288 }
289 else {
290 warn "Don't know how to mark block for $FUDGE!\n";
291 }
292 }
293 }
294 else {
295 if ($FUDGE eq 'todo') {
296 $DOES = 0; # XXX ignore?
805fea2 @moritz [fudge] allow todo() and skip() of custom test subs (installed via #?DOE...
moritz authored
297 my $does = join '|', keys %DOES;
e550267 @usev6 Fix fudging for 'todo'
usev6 authored
298 $PENDING -= s/^(\s*)/${1}todo($ARGS); / if $does ? /^\s*(?:$IS|$does)\b/ : /^\s*(?:$IS)\b/;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
299 }
300 else {
301 while ($_ !~ /;[ \t]*(#.*)?$/) {
302 my $more = <>;
303 last unless $more;
304 $_ .= $more;
305 }
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
306 my ($keyword) = /^\s*(\w+)/ || '';
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
307 my $numtests;
308 if ($DOES{$keyword}) {
309 $numtests = $DOES{$keyword};
310 }
311 elsif ($DOES) {
312 $numtests = $DOES;
313 }
314 else {
805fea2 @moritz [fudge] allow todo() and skip() of custom test subs (installed via #?DOE...
moritz authored
315 my $does = join '|', keys %DOES;
bc9f52e @usev6 Fix fudging for 'skip'
usev6 authored
316 next unless $does ? /^\s*($IS|$does)/ : /^\s*($IS)/;
6c36d55 @ruz [fudge] return back compatibility with perl 5.8
ruz authored
317 $numtests = defined $DOES{$1}? $DOES{$1} : 1;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
318 }
319 $PENDING--;
320 $_ = "{ " . $_ . " }";
321 if ($FUDGE eq 'skip') {
322 s/^/# /mg;
e15910b @moritz [fudge] fix skip() argument order in two more cases
moritz authored
323 $_ = "skip($ARGS, $numtests); $_\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
324 }
325 elsif ($FUDGE eq 'try') {
c06a9c0 [fudge] fail should be flunk
lwall authored
326 $_ = "(try $_) // flunk($ARGS);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
327 }
328 elsif ($FUDGE eq 'eval') {
329 s/(['\\])/\\$1/g;
e15910b @moritz [fudge] fix skip() argument order in two more cases
moritz authored
330 $_ = "eval('$_') // skip($ARGS, $numtests);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
331 }
332 else {
333 warn "Don't know how to mark statement for $FUDGE!\n";
334 }
335 }
336 }
d6fc355 @FROGGS clear $DOES flag after loop iteration
FROGGS authored
337 $DOES = 0;
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
338 }
339 continue {
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
340 $OUTPUT .= $_;
6edb64e @usev6 Clear $DOES flag when leaving top level block
usev6 authored
341 $DOES = 0 if /^\}/;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
342 return if /^\}/ and $PENDING > 0;
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
343 }
344 }
1b01911 @FROGGS allow to fudge for specific language versions
FROGGS authored
345
346 sub version_matches {
347 my ($lhs, $rhs) = @_;
348 my $plus = $rhs =~ s/\+$// ? 1 : 0;
349 my $cmp = version_cmp($lhs, $rhs);
350 return if $cmp == -42; # out of range
351 return $cmp == 0 || $plus && $cmp > 0
352 }
353 sub version_cmp {
354 my ($lhs, $rhs) = @_;
355
356 # v1 ~~ v2..v3
357 if ($rhs =~ /(.+?)\.\.(.+)/) {
358 return version_cmp($lhs, $1) >= 0 && version_cmp($lhs, $2) <= 0 ? 0 : -42
359
360 }
361 # v1 ~~ *
362 elsif ($rhs eq '*') {
363 return 0
364 }
365 # v1 ~~ v2
366 else {
367 my @lhs = split /[\.\b]/, $lhs;
368 my @rhs = split /[\.\b]/, $rhs;
369 while (@lhs || @rhs) {
370 my $v = shift @rhs // 0;
371 my $o = shift @lhs // 0;
372 next if $v eq '*';
373 next if $o eq '*';
374 return $o cmp $v if $o cmp $v;
375 }
376 return 0;
377 }
378 }
b6e2526 @usev6 Register all functions from test modules used in roast
usev6 authored
379
380 sub _register_functions {
381 my $functions = join '|', @_;
382 return '\\b(?:' . $functions . ')(?:\\b|_)';
383 }
Something went wrong with that request. Please try again.