← Back to branch summary

~ubuntu-branches/ubuntu/precise/rakudo/precise

« back to all changes in this revision

Viewing changes to tools/autounfudge.pl

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur
  • Date: 2009-10-04 14:31:57 UTC
  • Revision ID: james.westby@ubuntu.com-20091004143157-ubq3wu0grk0f1e6a
Tags: upstream-0.1~2009.09
Import upstream version 0.1~2009.09

Show diffs side-by-side

added added

removed removed

Lines of Context:
tools/autounfudge.pl
 
1
#! perl
 
2
# Copyright (C) 2008, The Perl Foundation.
 
3
# $Id$
 
4
 
 
5
=head1 NAME
 
6
 
 
7
autounfudge - automatically write patches for unfudging spec tests
 
8
 
 
9
=head1 DESCRIPTION
 
10
 
 
11
This tool runs the non-pure tests of the C<spectest> make target,
 
12
automatically creates files with less 'skip' fudge directives, runs them 
 
13
again, and if the
 
14
modified tests succeeds, it adds a patch to C<autounfudge.patch> that, when
 
15
applied as C<< patch -p0 < autunfudge.patch >>, removes the superflous fudge
 
16
directives.
 
17
 
 
18
With the C<--untodo> option, C<todo> skip markers are also removed (where
 
19
appropriate), with the C<--unskip> option it tries to substitute C<skip>
 
20
markers by C<todo> markers.
 
21
 
 
22
=head1 USAGE
 
23
 
 
24
Most common usage: C<perl tools/autounfudge.pl --auto>. For more options
 
25
please run this script without any options or command line parameters.
 
26
 
 
27
=head1 WARNINGS
 
28
 
 
29
This tool assumes that all fudge directives are orthogonal,
 
30
which might not be the case in real world tests. So always make sure to
 
31
run C<make spectest> before commiting the changes.
 
32
 
 
33
Never blindly apply the automatically generated patch.
 
34
 
 
35
=head1 MISCELLANEA
 
36
 
 
37
Fudge directives containing the words I<unspecced>, I<noauto> or I<unicode>  
 
38
are ignored.
 
39
The latter is because Unicode related tests can succeed on platforms with icu
 
40
installed, and fail on other platforms.
 
41
 
 
42
By default some files are skipped (which can be overridden with the
 
43
C<--exclude> option) because certain tests loop (at the time of writing
 
44
C<t/spec/S04-statement-modifiers/while.t>), others because processing them
 
45
simply takes too long; C<t/spec/S05-mass/rx.t> contains more than 250
 
46
fudge lines and thus would take about three hours to autoumatically unfudge.
 
47
 
 
48
=cut
 
49
 
 
50
use strict;
 
51
use warnings;
 
52
 
 
53
use Getopt::Long;
 
54
use Fatal qw(close);
 
55
use File::Temp qw(tempfile tempdir);
 
56
use TAP::Harness;
 
57
use TAP::Parser::Aggregator;
 
58
use Cwd qw(getcwd);
 
59
use File::Spec;
 
60
use File::Path;
 
61
use Text::Diff;
 
62
use threads;
 
63
use threads::shared;
 
64
use Thread::Queue;
 
65
 
 
66
my $impl = 'rakudo';
 
67
our $debug = 0;
 
68
our $out_filename = 'autounfudge.patch';
 
69
my $exclude = '(?:(?:radix|modifiers/(?:while|until)|rx|assign)\.t)$';
 
70
our $threads_num = 1;
 
71
 
 
72
GetOptions  'impl=s'        => \$impl,
 
73
            'debug'         => \$debug,
 
74
            'specfile=s'    => \my $specfile,
 
75
            'auto'          => \my $auto,
 
76
            'keep-env'      => \my $keep_env,
 
77
            'unskip'        => \my $unskip,
 
78
            'untodo'        => \my $untodo,
 
79
            'section=s'     => \my $section,
 
80
            'exclude'       => \$exclude,
 
81
            'jobs=i'        => \$threads_num,
 
82
            or usage();
 
83
 
 
84
delete $ENV{PERL6LIB} unless $keep_env;
 
85
 
 
86
my @files;
 
87
 
 
88
$specfile = 't/spectest.data' if $auto;
 
89
 
 
90
if ($specfile){
 
91
    @files = read_specfile($specfile);
 
92
}
 
93
else {
 
94
    @files = @ARGV or usage();
 
95
}
 
96
 
 
97
if ($section) {
 
98
    my $s = ($section =~ m/^\d{1,2}$/)
 
99
            ? sprintf('S%02d', $section)
 
100
            : $section;
 
101
    print "Only of section `$section'\n";
 
102
    @files = grep { m{ spec [/\\] \Q$section\E  }x } @files;
 
103
}
 
104
 
 
105
our $diff_lock :shared = 0;
 
106
open our $diff_fh, '>', $out_filename
 
107
    or die "Can't open '$out_filename' for writing: $!";
 
108
{
 
109
    select $diff_fh;
 
110
    $| = 1;
 
111
    select STDOUT;
 
112
}
 
113
 
 
114
our $tmp_dir = tempdir('RAKUDOXXXXXX', CLEANUP => 1);
 
115
 
 
116
if ($threads_num > 1) {
 
117
    my $queue = Thread::Queue->new;
 
118
    for (1..$threads_num) {
 
119
        threads->create(sub {
 
120
                while(my $file_name = $queue->dequeue) {
 
121
                    auto_unfudge_file($file_name);
 
122
                }
 
123
            });
 
124
    }
 
125
 
 
126
    $queue->enqueue($_) for @files;
 
127
    $queue->enqueue(undef) for 1..$threads_num;
 
128
    $_->join for threads->list;
 
129
}
 
130
else {
 
131
    for (@files) {
 
132
        auto_unfudge_file($_);
 
133
    }
 
134
}
 
135
 
 
136
 
 
137
sub auto_unfudge_file {
 
138
    my $file_name = shift;
 
139
 
 
140
    return unless defined $file_name;
 
141
    open my $f, '<:encoding(UTF-8)', $file_name
 
142
        or die "Can't open '$file_name' for reading: $!";
 
143
    print "Processing file '$file_name'\n";
 
144
    my @fudge_lines;
 
145
    while (<$f>) {
 
146
        push @fudge_lines, [$. , $_] if m/^\s*#\?$impl/ &&
 
147
            !m/unspecced|unicode|utf-?8|noauto/i;
 
148
    }
 
149
    close $f;
 
150
    if (@fudge_lines){
 
151
        print "Found " . (scalar @fudge_lines) . " fudges...\n" if $debug;
 
152
    }
 
153
    else {
 
154
        print "No fudges found. Nothing to do\n" if $debug;
 
155
        return;
 
156
    }
 
157
    my $fudged = fudge($file_name);
 
158
    print "Fudged: $fudged\n" if $debug;
 
159
    if (!tests_ok($fudged)){
 
160
        print "File '$file_name' doesn't even pass in its current state\n";
 
161
        return;
 
162
    }
 
163
    my @to_unfudge;
 
164
    for my $to_unfudge (@fudge_lines){
 
165
        print "trying line $to_unfudge->[0]...\n" if $debug;
 
166
        next if $to_unfudge->[1] =~ m/\btodo\b/ && !$untodo;
 
167
        $fudged = fudge(unfudge_some($file_name, [$to_unfudge->[0], '']));
 
168
        if (tests_ok($fudged)){
 
169
            print "WOOOOOT: Can remove fudge instruction on line $to_unfudge->[0]\n"
 
170
                if $debug;
 
171
            push @to_unfudge, [$to_unfudge->[0], ''],
 
172
        } 
 
173
        elsif ($unskip && $to_unfudge->[1] =~ s/\bskip\b/todo/) {
 
174
            # try to replace 'skip' with 'todo'-markers
 
175
            $fudged = fudge(unfudge_some($file_name, $to_unfudge));
 
176
            if (tests_ok($fudged)){
 
177
                print "s/skip/todo/ successful\n" if $debug;
 
178
                push @to_unfudge, $to_unfudge;
 
179
            }
 
180
        }
 
181
        else {
 
182
            print "not successful\n"if $debug;
 
183
        }
 
184
    }
 
185
 
 
186
    if (@to_unfudge){
 
187
        my $u = unfudge_some($file_name, @to_unfudge);
 
188
        lock($diff_lock);
 
189
        print $diff_fh diff($file_name, $u);
 
190
        unlink $u;
 
191
    }
 
192
 
 
193
}
 
194
 
 
195
sub fudge {
 
196
    my $fn = shift;
 
197
 
 
198
    open my $p, '-|', 't/spec/fudge', '--keep-exit-code',  $impl, $fn
 
199
        or die "Can't launch fudge: $!";
 
200
    my $ret_fn = <$p>;
 
201
    chomp $ret_fn;
 
202
    1 while <$p>;
 
203
    close $p;
 
204
    return $ret_fn;
 
205
}
 
206
 
 
207
sub usage {
 
208
    die <<"USAGE"
 
209
Usage:
 
210
    $0 [options] file+
 
211
Valid options:
 
212
    --debug             Enable debug output
 
213
    --impl impl         Specify a different implementation
 
214
    --specfile file     Specification file to read filenames from
 
215
    --auto              use t/spectest.data for --specfile
 
216
    --keep-env          Keep PERL6LIB environment variable.
 
217
    --exclude regex     Don't run the tests that match regex
 
218
    --section number    Run only on tests belonging to section <number>
 
219
    --unskip            Try to change 'skip' to 'todo' markers
 
220
    --untodo            Try to remove 'todo' markers
 
221
USAGE
 
222
}
 
223
 
 
224
sub unfudge_some {
 
225
    my ($file, @lines) = @_;
 
226
 
 
227
    my ($fh, $tmp_filename) = tempfile(
 
228
            'tempXXXXX',
 
229
            SUFFIX => '.t',
 
230
            DIR => $tmp_dir
 
231
    );
 
232
    open my $in, '<', $file
 
233
        or die "Can't open file '$file' for reading: $!";
 
234
    while (<$in>){
 
235
        if ($. == $lines[0][0]){
 
236
            print $fh $lines[0][1];
 
237
            shift @lines if @lines > 1;
 
238
        }
 
239
        else {
 
240
            print $fh $_;
 
241
        }
 
242
    }
 
243
    close $fh;
 
244
    close $in;
 
245
    return $tmp_filename;
 
246
}
 
247
 
 
248
sub tests_ok {
 
249
    my $fn = shift;
 
250
 
 
251
    $fn =~ s/\s+\z//;
 
252
    my $harness = get_harness();
 
253
    my $agg = TAP::Parser::Aggregator->new();
 
254
    $agg->start();
 
255
    $harness->aggregate_tests($agg, $fn);
 
256
    $agg->stop();
 
257
    return !$agg->has_errors;
 
258
}
 
259
 
 
260
sub get_harness {
 
261
    return TAP::Harness->new({
 
262
            verbosity   => -2,
 
263
            exec        => ['./perl6'],
 
264
            merge       => 1,
 
265
    });
 
266
}
 
267
 
 
268
sub read_specfile {
 
269
    my $fn = shift;
 
270
 
 
271
    my @res;
 
272
    open (my $f, '<', $fn) or die "Can't open file '$fn' for reading: $!";
 
273
    while (<$f>){
 
274
        next if m/#/;
 
275
        next unless m/\S/;
 
276
        next if m/$exclude/;
 
277
        m/(\S+)/ && push @res, "t/spec/$1";
 
278
    }
 
279
    return @res;
 
280
}
 
281
 
 
282
END {
 
283
    close $diff_fh if $diff_fh;
 
284
    File::Path::rmtree($tmp_dir);
 
285
}
 
286
 
 
287
# Local Variables:
 
288
#   mode: cperl
 
289
#   cperl-indent-level: 4
 
290
#   fill-column: 100
 
291
# End:
 
292
# vim: expandtab shiftwidth=4: