#!/usr/bin/perl

use strict;
use warnings;

my %OPTS;
while( $_ = $ARGV[0], /^-/ ) {
    shift;
    last if $_ eq '--';
    if (/^--([^=]+)(=(.*))?$/) {
        $OPTS{$1} = $3 // 1;
    }
}

my $ME;  # implementation
my $IN;  # test file
my $OUT; # fudged file

if (-f ".spec_config") {
    open my $cf, "<", ".spec_config";
    while (<$cf>) {
        if (m/^\bname\b\s*=\s*(\w+)/) {
           $ME = $1;
        }
    }
}

if (@ARGV == 3) {
    # impl test fudged
    $ME = shift;
    $IN = shift;
    $OUT = shift;
} elsif (@ARGV == 1) {
    # test
    $IN = shift;
} elsif (@ARGV == 2) {
    my $arg = shift;
    if ($arg =~ /\.t$/) {
        # test fudged
        $IN = $arg;
        $OUT = shift;
    } else {
        # impl test
        $ME = $arg;
        $IN = shift;
    }
}

if (!$OUT and $IN) {
    ($OUT = $IN) =~ s/\.t$/.$ME/ or $OUT .= ".$ME";
}

unless ($ME and $IN and $OUT) {

    die <<"USAGE";
Usage: $0 [options] [implname] testfilename [fudgedtestfilename]

    implname, if not specified on the command line, is pulled from the
        .spec_config file in your compiler's directory.

    Options:
    --keep-exit-code
        by default, fudge modifies the exit code for fudged test files to 1.
        supplying this option will suppress that behavior.

    --version="v6.0.0"
        pass the targeted Perl 6 language version you attempt to comply with,
        defaults to 'v6.0.0'.

    Verbs:
    #?implname [num] skip 'reason'
        comment out num tests or blocks and call skip(num)

    #?implname [num] eval 'reason'
        eval num tests or blocks and skip(num) on parsefail

    #?implname [num] try 'reason'
        try num tests or blocks and fail on exception

    #?implname [num] todo 'reason', :by<1.2.3>
        run num tests or blocks with todo() preset

    #?implname emit your_ad_here();
        just pass through your_ad_here();

    #?v6+            [num|*] ['reason']
    #?v6.0+          [num|*] ['reason']
    #?v6.0.0..*      [num|*] ['reason']
    #?v6.0.0..v6.0.5 [num|*] ['reason']
        run num/all tests for the given Perl 6 language version. Skipped
        on non-matching Perl 6 language versions.

    #?v6+            [num|*] skip|emit|todo|eval|try ['reason']
        skip or todo (etc) tests for the matching Perl 6 language version.
        Non-matching Perl 6 language versions are left untouched.

    #?DOES count
        for all implementations, the following thing does count tests
        (disables any attempt to autocount tests within the construct)
        when construct is a sub, registers the sub name as tester
        (and multiplies calls to tester sub by count tests)

    where
    implname is the lc name of your implementation, e.g. niecza or rakudo
    num is the number of statements or blocks to preprocess, defaults to 1
    count is how many tests the following construct counts as
    implnames are compared as a prefix match on sequences of components,
    i.e. #?rakudo matches rakudo.jvm

USAGE
}
unless (-e $IN) {
    die "$0: No such test file '$IN'\n";
}

unlink $OUT;        # old fudged version, may or may not regenerate...

my $REALLY_FUDGED = 0;
my $OUTPUT = "";
my $FUDGE = "";
our $PENDING = 0;
my $ARGS = '';
my $IS = _register_functions(  # regex with test functions used in roast
    # from Test
    qw(
      cmp_ok            cmp-ok
      dies_ok           dies-ok
      does-ok
      eval_dies_ok      eval-dies-ok
      eval_lives_ok     eval-lives-ok
      flunk
      is
      is-approx
      is_deeply         is-deeply
      isa_ok            isa-ok
      isnt
      like
      lives_ok          lives-ok
      nok
      ok
      pass
      throws_like       throws-like
      unlike
      use_ok            use-ok
    ),
    # from Test::Util
    qw(
      is_run            is-run
      doesn't-hang
      doesn't-warn
      warns-like
      fails-like
      is-eqv
      is-path
      is-deeply-junction
      test-iter-opt
      throws-like-any
      run-with-tty
      no-fatal-throws-like
    ),
    # from Test::Tap
    qw(
      tap-ok
    ),
    # from Test::Compile
    qw(
      loads_ok          loads-ok
      precomp_loads_ok  precomp-loads-ok
      loads_is          loads-is
      precomp_loads_is  precomp-loads-is
    ),
    # from Test::Idempotency
    qw(
      is-perl-idempotent
    ),
    # from Test::Assuming
    qw(
      is-primed-sig
      is-primed-call
      priming-fails-bind-ok
    ),
);
my %DOES;
my $DOES = 0;
my $EXIT = $OPTS{'keep-exit-code'} ? '' : 'exit(1);';
my $VERSION = $OPTS{'version'} || 'v6.0.0';

@ARGV = ($IN);
fudgeblock();

if ($REALLY_FUDGED) {
    open OUT, ">", $OUT or die "Can't create $OUT: $!";
    print OUT $OUTPUT;
    print OUT <<"END";

say "# FUDGED!";
$EXIT
END
    close OUT;
    print "$OUT\n"; # pick the output file to run
}
else {
    print "$IN\n";  # pick the input file to run
}

sub fudgeblock {
    while (<>) {
        if (/^\s*\#\?DOES[:\s] \s* (.*)/x) {
            $DOES = $1;
            next;
        }
        if (!$PENDING && /^\s*\#([?!]) (\S+?)[:\s] \s* ((\S*).*)/x) {
            my $sense = $1;
            my $name = $2;
            my $args = $3;
            my $cmd = $4;
            my $applies = 0;

            # Guard against false match with shebang line.  See roast RT #268
            next if $sense eq '!' && ! scalar m/\b(DOES|skip|emit|todo|eval|try)\b/ ;

            if ($name =~ /^v\d/) {  # Perl 6 language version
                my $num = $args =~ s/(\d+)\s*// ? $1 : 1;
                $cmd    = 'skip';
                $applies = !version_matches($VERSION, $name);
                if ($args =~ s/^(skip|emit|todo|eval|try)\b\s*//) {
                    $applies = 1;
                    $cmd     = $1;
                }
                if ($applies) {
                    $args = "$num $cmd " . ($args || "'Version $name required'")
                }
            }
            elsif ($name gt 'a') {  # lowercase is compiler name
                $applies = 1 if substr("$ME.",0,length($name)+1) eq "$name.";
            }
            else {  # uppercase is env var
                $applies = $ENV{$name};
            }
            $applies = !$applies if $sense eq '!';
            if ($applies) {
                $REALLY_FUDGED = 1;
                $ARGS = $args;
                if ($ARGS =~ s/^emit\s*//) {
                    $_ = $ARGS;
                    next;
                }
                if ($ARGS =~ s/^(\d+)\s*//) {
                    $PENDING = $1;
                }
                else {
                    $PENDING = 1;
                }
                $ARGS =~ s/^(\w+)\s*//;
                $FUDGE = $1;
            } elsif ($cmd eq 'emit') {
                $_ = '';
                next;
            }
        }

        next if /^\s*#/;
        next if /^\s*$/;

        if ($DOES) {
            if (/^\s*(sub|multi|proto)\b/) {
                my $tmp = $_;
                $tmp =~ s/^\s*proto\s+//;
                $tmp =~ s/^\s*multi\s+//;
                $tmp =~ s/^\s*sub\s+//;
                $tmp =~ /^(\w+)/;
                $DOES{$1} = $DOES;
                $DOES = 0;
                next;
            }
        }

        next unless $PENDING > 0;

        if (/^\{/) {
            $PENDING--;
            if ($FUDGE eq 'todo') {
                local $PENDING = 999999;    # do all in block as one action
                $OUTPUT .= $_;
                $DOES = 0;  # XXX ignore?
                fudgeblock();
                $_ = '';
            }
            else {
                my $more;
                while (defined($more = <>)) {
                    $_ .= $more;
                    last if $more =~ /^\}/;
                }
                my $numtests = $DOES || do {
                    my $tmp = $_;
                    my $nt = 0;
                    $nt += $1 while $tmp =~ s/^#\?DOES[:\s]\s*(\d+).*\n.*\n//m;
                    if (%DOES) {
                            my $does = join('|',keys(%DOES));
                            $nt += $DOES{$1} while $tmp =~ s/^\s*($does)\b//mx;
                    }
                    $nt += () = $tmp =~ m/^(\s*$IS)/mgx;
                    $nt;
                };
                if ($FUDGE eq 'skip') {
                    s/^/# /mg;
                    $_ = "skip($ARGS, $numtests);" . $_;
                }
                elsif ($FUDGE eq 'try') {
                    chomp;
                    $_ = "(try $_) // flunk($ARGS);\n";
                }
                elsif ($FUDGE eq 'eval') {
                    chomp;
                    s/(['\\])/\\$1/g;
                    $_ = "EVAL('$_') // skip($ARGS, $numtests);\n";
                }
                else {
                    warn "Don't know how to mark block for $FUDGE!\n";
                }
            }
        }
        else {
            if ($FUDGE eq 'todo') {
                $DOES = 0;  # XXX ignore?
                my $does = join '|', keys %DOES;
                $PENDING -= s/^(\s*)/${1}todo($ARGS); / if $does ? /^\s*(?:$IS|$does)\b/ : /^\s*(?:$IS)\b/;
            }
            else {
                while ($_ !~ /;[ \t]*(#.*)?$/) {
                    my $more = <>;
                    last unless $more;
                    $_ .= $more;
                }
                my ($keyword) = /^\s*(\w+)/ || '';
                my $numtests;
                if ($DOES{$keyword}) {
                    $numtests = $DOES{$keyword};
                }
                elsif ($DOES) {
                    $numtests = $DOES;
                }
                else {
                    my $does = join '|', keys %DOES;
                    next unless $does ? /^\s*($IS|$does)/ : /^\s*($IS)/;
                    $numtests = defined $DOES{$1}? $DOES{$1} : 1;
                }
                $PENDING--;
                $_ = "{ " . $_ . " }";
                if ($FUDGE eq 'skip') {
                    s/^/# /mg;
                    $_ = "skip($ARGS, $numtests); $_\n";
                }
                elsif ($FUDGE eq 'try') {
                    $_ = "(try $_) // flunk($ARGS);\n";
                }
                elsif ($FUDGE eq 'eval') {
                    s/(['\\])/\\$1/g;
                    $_ = "EVAL('$_') // skip($ARGS, $numtests);\n";
                }
                else {
                    warn "Don't know how to mark statement for $FUDGE!\n";
                }
            }
        }
        $DOES = 0;
    }
    continue {
        $OUTPUT .= $_;
        $DOES = 0 if /^\}/;
        return if /^\}/ and $PENDING > 0;
    }
}

sub version_matches {
    my ($lhs, $rhs) = @_;
    my $plus        = $rhs =~ s/\+$// ? 1 : 0;
    my $cmp         = version_cmp($lhs, $rhs);
    return if $cmp == -42; # out of range
    return $cmp == 0 || $plus && $cmp > 0
}
sub version_cmp {
    my ($lhs, $rhs) = @_;

    # v1 ~~ v2..v3
    if ($rhs =~ /(.+?)\.\.(.+)/) {
        return version_cmp($lhs, $1) >= 0 && version_cmp($lhs, $2) <= 0 ? 0 : -42

    }
    # v1 ~~ *
    elsif ($rhs eq '*') {
        return 0
    }
    # v1 ~~ v2
    else {
        my @lhs = split /[\.\b]/, $lhs;
        my @rhs = split /[\.\b]/, $rhs;
        while (@lhs || @rhs) {
            my $v = shift @rhs // 0;
            my $o = shift @lhs // 0;
            next if $v eq '*';
            next if $o eq '*';
            return $o cmp $v if $o cmp $v;
        }
        return 0;
    }
}

sub _register_functions {
    my $functions = join '|', @_;
    return '\\b(?:' . $functions . ')(?:\\b|_)';
}
