I'd like to get some feedback on this commit regard platform
interoperability.
I could only test it on linux, so I'm not sure what could break.
(One comment inline in the diff below)
[EMAIL PROTECTED] wrote:
> Author: moritz
> Date: Wed Jul 2 03:34:59 2008
> New Revision: 28944
>
> Added:
> trunk/languages/perl6/tools/autounfudge.pl (contents, props changed)
> Modified:
> trunk/MANIFEST
>
> Log:
> [rakudo] add tools/autounfudge.pl
>
>
> Modified: trunk/MANIFEST
> ==============================================================================
> --- trunk/MANIFEST (original)
> +++ trunk/MANIFEST Wed Jul 2 03:34:59 2008
> @@ -1,7 +1,7 @@
> # ex: set ro:
> # $Id$
> #
> -# generated by tools/dev/mk_manifest_and_skip.pl Wed Jul 2 08:40:48 2008 UT
> +# generated by tools/dev/mk_manifest_and_skip.pl Wed Jul 2 10:46:48 2008 UT
> #
> # See tools/dev/install_files.pl for documentation on the
> # format of this file.
> @@ -2002,6 +2002,7 @@
> languages/perl6/t/pmc/mutable.t [perl6]
> languages/perl6/t/pmc/mutablevar.t [perl6]
> languages/perl6/t/spectest_regression.data [perl6]
> +languages/perl6/tools/autounfudge.pl [perl6]
> languages/perl6/tools/fudge_purity_inspector.pl [perl6]
> languages/perl6/tools/progress-graph.pl [perl6]
> languages/perl6/tools/test_summary.pl [perl6]
>
> Added: trunk/languages/perl6/tools/autounfudge.pl
> ==============================================================================
> --- (empty file)
> +++ trunk/languages/perl6/tools/autounfudge.pl Wed Jul 2 03:34:59 2008
> @@ -0,0 +1,212 @@
> +#! perl
> +# Copyright (C) 2008, The Perl Foundation.
> +# $Id$
> +
> +=head1 NAME
> +
> +autounfudge - automatically write patches for unfudging spec tests
> +
> +=head1 DESCRIPTION
> +
> +This tool runs the non-pure tests of the C<spectest_regression> make target,
> +automatically creates files with less fudges, runs them again, and if the
> +modified tests succeeds, it adds a patch to C<autounfudge.patch> that, when
> +applied as C<< patch -p0 < autunfudge.patch >>, removes the superflous fudge
> +directives.
> +
> +=head1 USAGE
> +
> +Most common usage: C<perl tools/autounfudge.pl --auto>. For more use cases
> +pleae run this script without any options or command line parameters.
> +
> +=head1 WARNINGS
> +
> +This tool is very platform dependant, and not tested on anthing but linux.
> +
> +It assumes that all fudge directives are orthogonal, which might not be the
> +case in real world tests. It is not tested with nested fudges (eg a line
> +based fudge inside a fudged block).
> +
> +Never blindly apply the automatically generated patch.
> +
> +=head1 MISCELANEA
> +
> +Fudge directives containing the words I<unspecced> or I<unicode> are ignored.
> +The latter is because Unicode related tests can succeed on platforms with icu
> +installed, and fail on other platforms.
> +
> +=cut
> +
> +use strict;
> +use warnings;
> +use Getopt::Long;
> +use Fatal qw(close);
> +use File::Temp qw(tempfile tempdir);
> +use TAP::Harness;
> +use TAP::Parser::Aggregator;
> +use Cwd qw(getcwd);
> +use File::Spec;
> +use File::Path;
> +
> +my $impl = 'rakudo';
> +our $debug = 0;
> +our $out_filename = 'autounfudge.patch';
> +
> +if ($^O ne 'linux'){
> + warn <<'WARN';
> +Warning: this tool is only tested on linux so far. Currently it depends on
> +some linux specific hacks. It requires the `diff' program to be installed.
> +If you test this on any platform other than linux, pleaes report your results
> +to [EMAIL PROTECTED]
> +WARN
> +}
> +
> +GetOptions 'impl=s' => \$impl,
> + 'debug' => \$debug,
> + 'specfile=s' => \my $specfile,
> + 'auto' => \my $auto,
> + or usage();
> +my @files;
> +
> +$specfile = 't/spectest_regression.data' if $auto;
> +
> +if ($specfile){
> + @files = read_specfile($specfile);
> +}
> +else {
> + @files = @ARGV or usage();
> +}
> +
> +if (-e $out_filename){
> + unlink $out_filename or warn "Couldn't delete old unfudge.patch";
> +}
> +our $tmp_dir = tempdir('RAKUDOXXXXXX', CLEANUP => 1);
> +
> +for (@files){
> + auto_unfudge_file($_);
> +}
> +
> +sub auto_unfudge_file {
> + my $file_name = shift;
> + open my $f, '<:encoding(UTF-8)', $file_name
> + or die "Can't open '$file_name' for reading: $!";
> + print "Processing file '$file_name'\n";
> + my @fudge_lines;
> + while (<$f>) {
> + push @fudge_lines, $. if m/^\s*#\?$impl/ &&
> + !m/unspecced|unicode|utf-?8/i;
> + }
> + close $f;
> + if (@fudge_lines){
> + print "Found " . (scalar @fudge_lines) . " fudges...\n" if $debug;
> + }
> + else {
> + print "No fudges found. Nothing to do\n" if $debug;
> + return;
> + }
> + my $fudged = fudge($file_name);
> + print "Fudged: $fudged\n" if $debug;
> + if (!tests_ok($fudged)){
> + print "File '$file_name' doesn't even pass in its current state\n";
> + return;
> + }
> + my @to_unfudge;
> + for my $to_unfudge (@fudge_lines){
> + $fudged = fudge(unfudge_some($file_name, 0, $to_unfudge));
> + if (tests_ok($fudged)){
> + print "WOOOOOT: Can remove fudge instruction on line
> $to_unfudge\n"
> + if $debug;
> + push @to_unfudge, $to_unfudge,
> + }
> + }
> +
> + if (@to_unfudge){
> + my $u = unfudge_some($file_name, 1, @to_unfudge);
> + system qq{diff -u "$file_name" "$u" >> "$out_filename"};
This is the line that troubles me most. Will that work on Windows and
MacOS? If not, how could I improve it?
> + unlink $u;
> + }
> +
> +}
> +
> +sub fudge {
> + my $fn = shift;
> + open my $p, '-|', 't/spec/fudge', '--keep-exit-code', $impl, $fn
> + or die "Can't launch fudge: $!";
> + my $ret_fn = <$p>;
> + chomp $ret_fn;
> + 1 while <$p>;
> + close $p;
> + return $ret_fn;
> +}
> +
> +sub usage {
> + die <<"USAGE"
> +Usage:
> + $0 [options] file+
> +Valid options:
> + --debug Enable debug output
> + --impl impl Specify a different implementation
> + --specfile file Specification file to read filenames from
> + --auto use t/spectest_regression.data for --specfile
> +USAGE
> +}
> +
> +sub unfudge_some {
> + my ($file, $delete, @lines) = @_;
> + my ($fh, $tmp_filename) = tempfile(
> + 'tempXXXXX',
> + SUFFIX => '.t',
> + DIR => $tmp_dir
> + );
> + open my $in, '<', $file
> + or die "Can't open file '$file' for reading: $!";
> + while (<$in>){
> + if ($. == $lines[0]){
> + print $fh "###$_" unless $delete;
> + shift @lines if @lines > 1;
> + }
> + else {
> + print $fh $_;
> + }
> + }
> + close $fh;
> + close $in;
> + return $tmp_filename;
> +}
> +
> +sub tests_ok {
> + my $fn = shift;
> + $fn =~ s/\s+\z//;
> + my $harness = get_harness();
> + my $agg = TAP::Parser::Aggregator->new();
> + $agg->start();
> + $harness->aggregate_tests($agg, $fn);
> + $agg->stop();
> +# my $agg = $harness->runtests($fn);
> + return !$agg->has_errors;
> +}
> +
> +sub get_harness {
> + return TAP::Harness->new({
> + verbosity => -2,
> + exec => ['../../parrot', '-G', 'perl6.pbc'],
> + merge => 1,
> + });
> +}
> +
> +sub read_specfile {
> + my $fn = shift;
> + my @res;
> + open (my $f, '<', $fn) or die "Can't open file '$fn' for reading: $!";
> + while (<$f>){
> + next if m/#/;
> + next unless m/\S/;
> + s/\s+\z//;
> + push @res, "t/spec/$_";
> + }
> + return @res;
> +}
> +
> +END {
> + File::Path::rmtree($tmp_dir);
> +}
--
Moritz Lenz
http://moritz.faui2k3.org/ | http://perl-6.de/
