Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 266 lines (237 sloc) 7.436 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;
9 last if /^--$/;
10 $OPTS{$_} = $_;
11 }
12
301db81 @coke respect .spec_config
coke authored
13 my $ME; # implementation
14 my $IN; # test file
15 my $OUT; # fudged file
16
17 if (-f ".spec_config") {
18 open my $cf, "<", ".spec_config";
19 while (<$cf>) {
20 if (m/^\bname\b\s*=\s*(\w+)/) {
21 $ME = $1;
22 }
23 }
24 }
25
26 if (@ARGV == 3) {
27 # impl test fudged
28 $ME = shift;
29 $IN = shift;
30 $OUT = shift;
31 } elsif (@ARGV == 1) {
32 # test
33 $IN = shift;
34 } elsif (@ARGV == 2) {
35 my $arg = shift;
5e75fe9 @ronaldxs The ~~ smart match requires Perl 5.10 and rakudo is supposed to be OK wi...
ronaldxs authored
36 if ($arg =~ /\.t$/) {
301db81 @coke respect .spec_config
coke authored
37 # test fudged
38 $IN = $arg;
39 $OUT = shift;
40 } else {
41 # impl test
42 $ME = $arg;
43 $IN = shift;
44 }
45 }
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
46
5118cd4 [fudge] improved usage message listing verbs
lwall authored
47 if (!$OUT and $IN) {
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
48 ($OUT = $IN) =~ s/\.t$/.$ME/ or $OUT .= ".$ME";
49 }
301db81 @coke respect .spec_config
coke authored
50
d38ece7 @moritz [fudge] give a better error message for missing test files
moritz authored
51 unless ($ME and $IN and $OUT) {
5118cd4 [fudge] improved usage message listing verbs
lwall authored
52
53 die <<"USAGE";
301db81 @coke respect .spec_config
coke authored
54 Usage: $0 [options] [implname] testfilename [fudgedtestfilename]
55
56 implname, if not specified on the command line, is pulled from the
57 .spec_config file in your compiler's directory.
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
58
59 Options:
60 --keep-exit-code
61 by default, fudge modifies the exit code for fudged test files to 1.
62 supplying this option will suppress that behavior.
5118cd4 [fudge] improved usage message listing verbs
lwall authored
63
64 Verbs:
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
65 #?implname [num] skip 'reason'
66 comment out num tests or blocks and call skip(num)
a2d9517 [fudge] implement #?DOES
lwall authored
67
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
68 #?implname [num] eval 'reason'
69 eval num tests or blocks and skip(num) on parsefail
a2d9517 [fudge] implement #?DOES
lwall authored
70
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
71 #?implname [num] try 'reason'
72 try num tests or blocks and fail on exception
a2d9517 [fudge] implement #?DOES
lwall authored
73
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
74 #?implname [num] todo 'reason', :by<1.2.3>
75 run num tests or blocks with todo() preset
a2d9517 [fudge] implement #?DOES
lwall authored
76
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
77 #?implname emit your_ad_here();
78 just pass through your_ad_here();
a2d9517 [fudge] implement #?DOES
lwall authored
79
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
80 #?DOES count
81 for all implementations, the following thing does count tests
82 (disables any attempt to autocount tests within the construct)
83 when construct is a sub, registers the sub name as tester
84 (and multiplies calls to tester sub by count tests)
a2d9517 [fudge] implement #?DOES
lwall authored
85
86 where
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
87 implname is the lc name of your implementation, e.g. pugs or rakudo
88 num is the number of statements or blocks to preprocess, defaults to 1
89 count is how many tests the following construct counts as
a2d9517 [fudge] implement #?DOES
lwall authored
90
5118cd4 [fudge] improved usage message listing verbs
lwall authored
91 USAGE
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
92 }
e34b309 @felher make fudge print usage if no arguments are given
felher authored
93 unless (-e $IN) {
94 die "$0: No such test file '$IN'\n";
95 }
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
96
2372496 @coke Always attempt to refudge.
coke authored
97 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
98
99 my $REALLY_FUDGED = 0;
100 my $OUTPUT = "";
101 my $FUDGE = "";
102 our $PENDING = 0;
103 my $ARGS = '';
343c92a @moritz [fudge] make it recognize throws_like
moritz authored
104 my $IS = '\\b(?:is|ok|nok|is_deeply|is_approx|isnt|like|unlike|eval_dies_ok|cmp_ok|isa_ok|use_ok|throws_ok|dies_ok|lives_ok|eval_lives_ok|pass|flunk|throws_like)(?:\\b|_)';
a2d9517 [fudge] implement #?DOES
lwall authored
105 my %DOES;
106 my $DOES = 0;
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
107 my $EXIT = $OPTS{'--keep-exit-code'} ? '' : 'exit(1);';
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
108
109 @ARGV = ($IN);
110 fudgeblock();
111
112 if ($REALLY_FUDGED) {
113 open OUT, ">", $OUT or die "Can't create $OUT: $!";
114 print OUT $OUTPUT;
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
115 print OUT <<"END";
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
116
117 say "# FUDGED!";
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
118 $EXIT
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
119 END
120 close OUT;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
121 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
122 }
123 else {
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
124 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
125 }
126
127 sub fudgeblock {
128 while (<>) {
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
129 if (/^\s*\#\?DOES[:\s] \s* (.*)/x) {
130 $DOES = $1;
131 next;
132 }
33cafa9 @KrisShannon Completely skip any 'emit' fudges for other implementations
KrisShannon authored
133 if (/^\s*\#\? (\S+?)[:\s] \s* ((\S*).*)/x) {
134 if ($1 eq $ME) {
135 $REALLY_FUDGED = 1;
136 $ARGS = $2;
137 if ($ARGS =~ s/^emit\s*//) {
138 $_ = $ARGS;
139 next;
140 }
141 if ($ARGS =~ s/^(\d+)\s*//) {
142 $PENDING = $1;
143 }
144 else {
145 $PENDING = 1;
146 }
147 $ARGS =~ s/^(\w+)\s*//;
148 $FUDGE = $1;
149 } elsif ($3 eq 'emit') {
150 $_ = '';
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
151 next;
152 }
153 }
154
155 next if /^\s*#/;
156 next if /^\s*$/;
157
158 if ($DOES) {
159 if (/^\s*(sub|multi|proto)\b/) {
160 my $tmp = $_;
161 $tmp =~ s/^\s*proto\s+//;
162 $tmp =~ s/^\s*multi\s+//;
163 $tmp =~ s/^\s*sub\s+//;
164 $tmp =~ /^(\w+)/;
165 $DOES{$1} = $DOES;
166 $DOES = 0;
167 next;
168 }
169 }
170
171 next unless $PENDING > 0;
172
173 if (/^\{/) {
174 $PENDING--;
175 if ($FUDGE eq 'todo') {
176 local $PENDING = 999999; # do all in block as one action
177 $OUTPUT .= $_;
178 $DOES = 0; # XXX ignore?
179 fudgeblock();
180 $_ = '';
181 }
182 else {
183 my $more;
184 while (defined($more = <>)) {
185 $_ .= $more;
186 last if $more =~ /^\}/;
187 }
188 my $numtests = $DOES || do {
189 my $tmp = $_;
190 my $nt = 0;
191 $nt += $1 while $tmp =~ s/^#\?DOES[:\s]\s*(\d+).*\n.*\n//m;
192 if (%DOES) {
193 my $does = join('|',keys(%DOES));
194 $nt += $DOES{$1} while $tmp =~ s/^\s*($does)\b//mx;
195 }
196 $nt += () = $tmp =~ m/^(\s*$IS)/mgx;
197 $nt;
198 };
199 if ($FUDGE eq 'skip') {
200 s/^/# /mg;
ca5c864 @tadzik Fix fudge according to the changes in Rakudo 3bbc066
tadzik authored
201 $_ = "skip($ARGS, $numtests);" . $_;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
202 }
203 elsif ($FUDGE eq 'try') {
204 chomp;
c06a9c0 [fudge] fail should be flunk
lwall authored
205 $_ = "(try $_) // flunk($ARGS);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
206 }
207 elsif ($FUDGE eq 'eval') {
208 chomp;
209 s/(['\\])/\\$1/g;
ca5c864 @tadzik Fix fudge according to the changes in Rakudo 3bbc066
tadzik authored
210 $_ = "eval('$_') // skip($ARGS, $numtests);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
211 }
212 else {
213 warn "Don't know how to mark block for $FUDGE!\n";
214 }
215 }
216 }
217 else {
218 if ($FUDGE eq 'todo') {
219 $DOES = 0; # XXX ignore?
805fea2 @moritz [fudge] allow todo() and skip() of custom test subs (installed via #?DOE...
moritz authored
220 my $does = join '|', keys %DOES;
221 $PENDING -= s/^(\s*)/${1}todo($ARGS); / if /^\s*(?:$IS|$does)\b/;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
222 }
223 else {
224 while ($_ !~ /;[ \t]*(#.*)?$/) {
225 my $more = <>;
226 last unless $more;
227 $_ .= $more;
228 }
1a3b0cc [spec tests] allow fudge and fudgeall to process arguments
particle authored
229 my ($keyword) = /^\s*(\w+)/ || '';
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
230 my $numtests;
231 if ($DOES{$keyword}) {
232 $numtests = $DOES{$keyword};
233 }
234 elsif ($DOES) {
235 $numtests = $DOES;
236 }
237 else {
805fea2 @moritz [fudge] allow todo() and skip() of custom test subs (installed via #?DOE...
moritz authored
238 my $does = join '|', keys %DOES;
239 next unless /^\s*($IS|$does)/;
6c36d55 @ruz [fudge] return back compatibility with perl 5.8
ruz authored
240 $numtests = defined $DOES{$1}? $DOES{$1} : 1;
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
241 }
242 $PENDING--;
243 $_ = "{ " . $_ . " }";
244 if ($FUDGE eq 'skip') {
245 s/^/# /mg;
e15910b @moritz [fudge] fix skip() argument order in two more cases
moritz authored
246 $_ = "skip($ARGS, $numtests); $_\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
247 }
248 elsif ($FUDGE eq 'try') {
c06a9c0 [fudge] fail should be flunk
lwall authored
249 $_ = "(try $_) // flunk($ARGS);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
250 }
251 elsif ($FUDGE eq 'eval') {
252 s/(['\\])/\\$1/g;
e15910b @moritz [fudge] fix skip() argument order in two more cases
moritz authored
253 $_ = "eval('$_') // skip($ARGS, $numtests);\n";
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
254 }
255 else {
256 warn "Don't know how to mark statement for $FUDGE!\n";
257 }
258 }
259 }
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
260 }
261 continue {
94688ba [fudge] added 'is_approx' and removed tabs
particle authored
262 $OUTPUT .= $_;
263 return if /^\}/ and $PENDING > 0;
0fa3c27 [fudge] move fudge/fudgeall to t/spec to make easy to check out with off...
lwall authored
264 }
265 }
Something went wrong with that request. Please try again.