Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 265 lines (237 sloc) 7.436 kb
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
1a3b0cc7 » particle
2008-04-25 [spec tests] allow fudge and fudgeall to process arguments
6 my %OPTS;
7 while( $_ = $ARGV[0], /^-/ ) {
8 shift;
9 last if /^--$/;
10 $OPTS{$_} = $_;
11 }
12
301db81b » coke
2012-03-06 respect .spec_config
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;
5e75fe9c » ronaldxs
2012-04-29 The ~~ smart match requires Perl 5.10 and rakudo is supposed to be OK…
36 if ($arg =~ /\.t$/) {
301db81b » coke
2012-03-06 respect .spec_config
37 # test fudged
38 $IN = $arg;
39 $OUT = shift;
40 } else {
41 # impl test
42 $ME = $arg;
43 $IN = shift;
44 }
45 }
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
46
5118cd4c » lwall
2008-01-21 [fudge] improved usage message listing verbs
47 if (!$OUT and $IN) {
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
48 ($OUT = $IN) =~ s/\.t$/.$ME/ or $OUT .= ".$ME";
49 }
301db81b » coke
2012-03-06 respect .spec_config
50
d38ece79 » moritz
2011-03-11 [fudge] give a better error message for missing test files
51 unless ($ME and $IN and $OUT) {
5118cd4c » lwall
2008-01-21 [fudge] improved usage message listing verbs
52
53 die <<"USAGE";
301db81b » coke
2012-03-06 respect .spec_config
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.
1a3b0cc7 » particle
2008-04-25 [spec tests] allow fudge and fudgeall to process arguments
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.
5118cd4c » lwall
2008-01-21 [fudge] improved usage message listing verbs
63
64 Verbs:
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
65 #?implname [num] skip 'reason'
66 comment out num tests or blocks and call skip(num)
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
67
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
68 #?implname [num] eval 'reason'
69 eval num tests or blocks and skip(num) on parsefail
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
70
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
71 #?implname [num] try 'reason'
72 try num tests or blocks and fail on exception
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
73
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
74 #?implname [num] todo 'reason', :by<1.2.3>
75 run num tests or blocks with todo() preset
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
76
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
77 #?implname emit your_ad_here();
78 just pass through your_ad_here();
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
79
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
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)
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
85
86 where
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
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
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
90
5118cd4c » lwall
2008-01-21 [fudge] improved usage message listing verbs
91 USAGE
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
92 }
e34b309f » felher
2011-04-01 make fudge print usage if no arguments are given
93 unless (-e $IN) {
94 die "$0: No such test file '$IN'\n";
95 }
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
96
23724966 » coke
2012-01-08 Always attempt to refudge.
97 unlink $OUT; # old fudged version, may or may not regenerate...
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
98
99 my $REALLY_FUDGED = 0;
100 my $OUTPUT = "";
101 my $FUDGE = "";
102 our $PENDING = 0;
103 my $ARGS = '';
343c92a9 » moritz
2012-06-06 [fudge] make it recognize throws_like
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|_)';
a2d9517a » lwall
2008-01-23 [fudge] implement #?DOES
105 my %DOES;
106 my $DOES = 0;
1a3b0cc7 » particle
2008-04-25 [spec tests] allow fudge and fudgeall to process arguments
107 my $EXIT = $OPTS{'--keep-exit-code'} ? '' : 'exit(1);';
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
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;
1a3b0cc7 » particle
2008-04-25 [spec tests] allow fudge and fudgeall to process arguments
115 print OUT <<"END";
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
116
117 say "# FUDGED!";
1a3b0cc7 » particle
2008-04-25 [spec tests] allow fudge and fudgeall to process arguments
118 $EXIT
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
119 END
120 close OUT;
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
121 print "$OUT\n"; # pick the output file to run
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
122 }
123 else {
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
124 print "$IN\n"; # pick the input file to run
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
125 }
126
127 sub fudgeblock {
128 while (<>) {
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
129 if (/^\s*\#\?DOES[:\s] \s* (.*)/x) {
130 $DOES = $1;
131 next;
132 }
33cafa97 » KrisShannon
2012-01-08 Completely skip any 'emit' fudges for other implementations
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 $_ = '';
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
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;
ca5c8641 » tadzik
2011-02-27 Fix fudge according to the changes in Rakudo 3bbc066
201 $_ = "skip($ARGS, $numtests);" . $_;
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
202 }
203 elsif ($FUDGE eq 'try') {
204 chomp;
c06a9c05 » lwall
2008-05-02 [fudge] fail should be flunk
205 $_ = "(try $_) // flunk($ARGS);\n";
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
206 }
207 elsif ($FUDGE eq 'eval') {
208 chomp;
209 s/(['\\])/\\$1/g;
ca5c8641 » tadzik
2011-02-27 Fix fudge according to the changes in Rakudo 3bbc066
210 $_ = "eval('$_') // skip($ARGS, $numtests);\n";
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
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?
805fea29 » moritz
2011-07-15 [fudge] allow todo() and skip() of custom test subs (installed via #?…
220 my $does = join '|', keys %DOES;
221 $PENDING -= s/^(\s*)/${1}todo($ARGS); / if /^\s*(?:$IS|$does)\b/;
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
222 }
223 else {
224 while ($_ !~ /;[ \t]*(#.*)?$/) {
225 my $more = <>;
226 last unless $more;
227 $_ .= $more;
228 }
1a3b0cc7 » particle
2008-04-25 [spec tests] allow fudge and fudgeall to process arguments
229 my ($keyword) = /^\s*(\w+)/ || '';
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
230 my $numtests;
231 if ($DOES{$keyword}) {
232 $numtests = $DOES{$keyword};
233 }
234 elsif ($DOES) {
235 $numtests = $DOES;
236 }
237 else {
805fea29 » moritz
2011-07-15 [fudge] allow todo() and skip() of custom test subs (installed via #?…
238 my $does = join '|', keys %DOES;
239 next unless /^\s*($IS|$does)/;
6c36d55d » ruz
2011-08-07 [fudge] return back compatibility with perl 5.8
240 $numtests = defined $DOES{$1}? $DOES{$1} : 1;
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
241 }
242 $PENDING--;
243 $_ = "{ " . $_ . " }";
244 if ($FUDGE eq 'skip') {
245 s/^/# /mg;
e15910b2 » moritz
2011-02-28 [fudge] fix skip() argument order in two more cases
246 $_ = "skip($ARGS, $numtests); $_\n";
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
247 }
248 elsif ($FUDGE eq 'try') {
c06a9c05 » lwall
2008-05-02 [fudge] fail should be flunk
249 $_ = "(try $_) // flunk($ARGS);\n";
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
250 }
251 elsif ($FUDGE eq 'eval') {
252 s/(['\\])/\\$1/g;
e15910b2 » moritz
2011-02-28 [fudge] fix skip() argument order in two more cases
253 $_ = "eval('$_') // skip($ARGS, $numtests);\n";
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
254 }
255 else {
256 warn "Don't know how to mark statement for $FUDGE!\n";
257 }
258 }
259 }
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
260 }
261 continue {
94688ba9 » particle
2008-01-27 [fudge] added 'is_approx' and removed tabs
262 $OUTPUT .= $_;
263 return if /^\}/ and $PENDING > 0;
0fa3c274 » lwall
2008-01-21 [fudge] move fudge/fudgeall to t/spec to make easy to check out with …
264 }
265 }
Something went wrong with that request. Please try again.