package t::Common;

use strict;
use lib qw {blib/lib}, ".";
use vars qw /@ISA @EXPORT @EXPORT_OK $DEBUG/;

use Regex::Common;
use Exporter ();

use warnings;

@ISA       = qw /Exporter/;
@EXPORT    = qw /run_tests run_new_tests NORMAL_PASS NORMAL_FAIL FAIL $DEBUG/;
@EXPORT_OK = qw /cross criss_cross pass fail
  d pd dd pdd l ll L LL a aa w ww _x xx X XX h hh
  gimme sample/;

my @STATES = qw /pass fail/;

our $SKIP;

use constant NORMAL_PASS => 0x01;    # Normal test, should pass.
use constant NORMAL_FAIL => 0x02;    # Normal test, should fail.
use constant NORMAL      => NORMAL_PASS | NORMAL_FAIL;
use constant FAIL        => 0x04;                        # Test for failure.

sub run_test;
sub run_old_keep;
sub run_fail;
sub count_me;
sub is_skipped;

my $count;

sub stringify;

sub stringify {
    my $arg = shift;

    if    ( !defined $arg ) { return "" }
    elsif ( !ref $arg ) {
        $arg =~ s/\\/\\\\/g;
        $arg =~ s/\n/\\n/g;
        $arg =~ s/\t/\\t/g;
        return "$arg";
    }
    elsif ( ref $arg eq "ARRAY" ) {
        local $" = ", ";
        return "[@{[map {q{'} . stringify ($_) . q{'}} @$arg]}]";
    }
    else { return ref $arg }
}

sub mess {
    my $str = stringify $_;
    my $com = join " " => map { stringify $_ } @_;
    $count++;
    if ($SKIP) { printf qq !%4d # SKIP: %s\n! => $count, $SKIP; }
    else       { printf qq !%4d - %-40s (%s)\n! => $count, qq !"$str"!, $com; }
}

sub pass { print "ok ";                      &mess }
sub fail { print +$SKIP ? "ok " : "not ok "; &mess }

sub Fail {
    my $mess = shift;
    my %args = @_;

    if ( $args{got} && $args{expected} ) {
        printf "# Expected: '%s'\n", stringify $args {expected};
        printf "# Got:      '%s'\n", stringify $args {got};
    }

    fail $mess;
}

sub import {
    if ( @_ > 1 && $_[-1] =~ /^\d+\.\d+$/ ) {
        my $version = pop;
        if ( $version > $] ) {
            print "1..1\n";
            print "ok 1\n";
            exit;
        }
    }
    __PACKAGE__->export_to_level( 1, @_ );
}

#
# Return a cross product from its arguments. Arguments are array refs.
# Result is a list of array refs.
#
sub cross {
    my @r = [];
    @r = map {
        my $s = $_;
        map { [ @$_ => $s ] } @r
    } @$_ for @_;
    @r;
}

sub criss_cross {
    my ( $f, $s ) = @_;
    my @r;

    push @r => cross @$f[ 0 .. $_ - 1 ],
      $$s[$_], @$f[ $_ + 1 .. $#$f ]
      for 0 .. $#$f;

    @r;
}

sub __ {
    map { defined() ? $_ : "UNDEF" } @_;
}

sub count_test_runs {
    my ( $tests, $passes, $failures ) = @_;

    my $keep   = 0;
    my $normal = 0;
    my $fail   = 0;

    foreach my $test (@$tests) {
        while ( my ( $name, $mask ) = each %{ $test->[2] } ) {
            $normal += @{ $passes->{$name} }   if $mask & NORMAL;
            $keep   += @{ $passes->{$name} }   if $mask & NORMAL_PASS;
            $fail   += @{ $failures->{$name} } if $mask & FAIL;
        }
    }

    1 + $normal + $keep + $fail;
}

# Arguments:
#    tests:   hash ref with the re's, names, and when to (not)match.
#    good:    ref to array with arrays, parts making patterns.
#    bad:     ref to array with arrays, parts not making patterns.
#    query:   code ref, creates query strings.
#    wanted:  code ref, creates list what keep should return.
#
#             Filter arguments are used to filter chunks before trying them.
#             All of them are code refs.
#    filter:          filter everything.
#    filter_passes:   filter passes.
#    filter_failures: filter failures.
#    filter_test:     filter called with testname.
sub run_tests {
    my %args = @_;

    my $tests = $args{tests};

    # Collect the names of all tags.
    my %tag_names;
    @tag_names{ keys %{ $_->[2] } } = () foreach @$tests;

    my ( @passes, @failures );

    if ( $args{good} ) {
        @passes = cross @{ $args{good} };

        @failures = ();
        foreach my $i ( 0 .. $#{ $args{good} } ) {
            push @failures => cross @{ $args{good} }[ 0 .. $i - 1 ],
              $args{bad}[$i],
              @{ $args{good} }[ $i + 1 .. $#{ $args{good} } ];
        }
    }
    elsif ( $args{good_list} ) {
        @passes = @{ $args{good_list} };
    }

    # General filters.
    @passes = grep { $args{filter_passes}->($_) } @passes
      if defined $args{filter_passes};
    @passes = grep { $args{filter}->($_) } @passes
      if defined $args{filter};

    @failures = grep { $args{filter_failures}->($_) } @failures
      if defined $args{filter_failures};
    @failures = grep { $args{filter}->($_) } @failures
      if defined $args{filter};

    my ( %passes, %failures );

    # Specific filters.
    if ( defined $args{filter_test} ) {
        foreach my $name ( keys %tag_names ) {
            $passes{$name} =
              [ grep { $args{filter_test}->( pass => $name, $_ ) } @passes ];
            $failures{$name} =
              [ grep { $args{filter_test}->( failure => $name, $_ ) }
                  @failures ];
        }
    }
    else {
        foreach my $name ( keys %tag_names ) {
            $passes{$name}   = [@passes];
            $failures{$name} = [@failures];
        }
    }

    my $runs = count_test_runs $tests, \%passes, \%failures;
    print "1..$runs\n";

    print "ok ", ++$count, "\n";

    my @test_names = map { $_->[1] } @$tests;
    my @tag_names  = keys %tag_names;

    my $wanted = $args{wanted};
    foreach my $test (@$tests) {
        my ( $name, $re, $matches ) = @$test;

        while ( my ( $tag, $match ) = each %$matches ) {
            if ( $match & NORMAL ) {
                foreach my $pass ( @{ $passes{$tag} } ) {
                    local $_ = $args{query}->( $tag => $pass );

                    run_test
                      re    => $re,
                      name  => $name,
                      match => $match & NORMAL_PASS;

                    run_old_keep
                      re     => $re,
                      name   => $name,
                      tag    => $tag,
                      parts  => $pass,
                      wanted => $wanted
                      if $match & NORMAL_PASS;
                }
            }
            if ( $match & FAIL ) {
                foreach my $failure ( @{ $failures{$tag} } ) {
                    local $_ = $args{query}->( $tag => $failure );

                    run_fail
                      re   => $re,
                      name => $name;
                }
            }
        }
    }
}

sub run_test {
    my %args = @_;

    my $re           = $args{re};
    my $name         = $args{name};
    my $should_match = $args{match};

    my $match = /^$re/;               # Not anchored at the end on purpose.
    my $good  = $match && $_ eq $&;
    my $line  = $good ? "match" : $match ? "wrong match (got: $&)" : "no match";
    $line .= "; $name";
    if   ($should_match) { $good  ? pass $line : fail $line }
    else                 { $match ? fail $line : pass $line }
}

sub array_cmp {
    my ( $a1, $a2 ) = @_;
    return 0 unless @$a1 eq @$a2;
    foreach my $i ( 0 .. $#$a1 ) {

        # !defined $$a1 [$i] && !defined $$a2 [$i] ||
        #  defined $$a1 [$i] &&  defined $$a2 [$i] && $$a1 [$i] eq $$a2 [$i]
        ( !defined $$a1[$i] || $$a1[$i] eq "" )
          && ( !defined $$a2[$i] || $$a2[$i] eq "" )
          || defined $$a1[$i] && defined $$a2[$i] && $$a1[$i] eq $$a2[$i]
          or return 0;
    }
    return 1;
}

sub run_old_keep {
    my %args = @_;

    my $re         = $args{re};        # Regexp that's being tried.
    my $name       = $args{name};      # Name of the test.
    my $tag        = $args{tag};       # Tag to pass to wanted sub.
    my $parts      = $args{parts};     # Parts to construct string from.
    my $wanted_sub = $args{wanted};    # Sub to contruct wanted array from.

    my @chunks = /^$re->{-keep}$/;
    unless (@chunks) { fail "no match; $name - keep"; return }

    my $wanted = $wanted_sub->( $tag => $parts );

    local $" = ", ";
    array_cmp( \@chunks, $wanted ) ? pass "match; $name - keep"
      : $DEBUG ? fail "wrong match,\n#      got [@{[__ @chunks]}]\n"
      . "# expected [@{[__ @$wanted]}]"
      : fail "wrong match [@{[__ @chunks]}]";
}

##################
#                #
# New style subs #
#                #
##################

#
# Messages printed at end are of the form:
#   [XX/Y/ZZ], with XX denoting the type of match, Y the expected result,
#              and ZZ the result.
#
#   XX: - RE:  Regular expression
#       - SB:  Subroutine call
#       - OM:  OO -> match
#       - OS:  OO -> subs
#       - KP:  Regular expression with -keep
#
#    Y: -  P:  Expected to pass
#       -  F:  Expected to fail
#
#   ZZ: - MT:  Pattern matched correctly
#       - NM:  Pattern did not match
#       - WM:  Pattern matched, but incorrectly.

#
# Given a regex and a string, test whether the regex fails to match.
# Matching anything other than the entire string is a pass (as it regex
# fails to match the entire string)
#
sub run_fail {
    my %args = @_;

    my $re   = $args{re};
    my $name = $args{name};

    /^$re/ && $_ eq $&
      ? fail "[RE/F/MT] $name"
      : pass "[RE/F/NM] $name";
}

#
# Same as 'run_fail', except now not a regex, but a subroutine is given.
#
sub run_sub_fail {
    my %args = @_;

    my $sub  = $args{sub};
    my $name = $args{name};
    my @args =
        $args{sub_args}
      ? ref $args{sub_args}
          ? @{ $args{sub_args} }
          : $args{sub_args}
      : ();

    $_ =~ $sub->(@args) && $_ eq $&
      ? fail "[SB/F/MT] $name"
      : pass "[SB/F/NM] $name";
}

#
# We can test whether it matched, but we can't really test whether
# it matched the entire string. $& relates to the last successful
# match in the current scope, but the match done in $re -> matches()
# is done in a subscope. @-/@+ are equally useless.
#
sub run_OO_pass {
    my %args = @_;

    my $re   = $args{re};
    my $name = $args{name};

    my $match = $re->matches($_);

    if   ($match) { pass "[OM/P/MT] $name" }
    else          { fail "[OM/P/NM] $name" }

}

#
# Test whether the subroutine gives the right answer.
#
sub run_sub_pass {
    my %args = @_;

    my $sub  = $args{sub};
    my $name = $args{name};
    my @args =
        $args{sub_args}
      ? ref $args{sub_args}
          ? @{ $args{sub_args} }
          : $args{sub_args}
      : ();

    my $match = $_ =~ $sub->(@args);
    my $good  = $match && $_ eq $&;

    if    ($good)  { pass "[SB/P/MT] $name" }
    elsif ($match) { Fail "[SB/P/WM] $name", got => $&, expected => $_ }
    else           { fail "[SB/P/NM] $name" }
}

#
# Check whether the substitution (only for OO) works correctly.
#
sub run_OO_substitution_pass {
    my %args = @_;

    my $re    = $args{re};
    my $name  = $args{name};
    my $token = $args{token} || "---";

    my $sub  = $re->subs( $_, $token );
    my $good = $sub eq $token;

    if    ($good) { pass "[OS/P/MT] $name" }
    elsif ( $sub ne $_ ) {
        Fail "[OS/P/NM] $name", got => $sub, expected => $token;
    }
    else { fail "[OS/P/WM] $name" }
}

sub run_pass {
    my %args = @_;

    my $re   = $args{re};
    my $name = $args{name};

    my $match   = /^$re/;    # Not anchored at the end on purpose.
    my $good    = $match && $_ eq $&;
    my $perfect = $good  && !defined $1;    # Should *not* set $1 and friends.

    if    ($perfect) { pass "[RE/P/MT] $name" }
    elsif ($good)    { fail "[RE/P/MT], sets \$1; $name" }
    elsif ($match)   { Fail "[RE/P/WM] $name", got => $&, expected => $_ }
    else             { fail "[RE/P/NM] $name" }
}

sub run_keep {
    my %args = @_;

    my $re     = $args{re};                 # Regexp that's being tried.
    my $name   = $args{name};               # Name of the test.
    my $wanted = $args{wanted};             # Wanted list.

    my @chunks = /^$re->{-keep}/;
    unless (@chunks) { fail "[KP/P/NM] $name"; return }

    array_cmp( \@chunks, $wanted )
      ? pass "[KP/P/MT] $name"
      : Fail "[KP/P/WM] $name",
      got      => \@chunks,
      expected => $wanted;
}

sub get_args {
    my $key = shift;
    foreach my $ref (@_) {
        next unless exists $$ref{$key};
        return ref $$ref{$key} eq 'ARRAY' ? @{ $$ref{$key} } : $$ref{$key};
    }
    return;
}

sub run_new_test_set {
    my %args = @_;

    my $test_set = $args{test_set};
    my $targets  = $args{targets};
    my $name     = $$test_set{name};
    my $regex    = $$test_set{regex} || $$test_set{re};    # Getting tired of
                                                           # getting this wrong.
    my $sub      = $$test_set{sub};
    my $sub_args = $$test_set{sub_args};
    my $keep     = $regex->{-keep};

    my $pass = $$test_set{pass};
    my $fail = $$test_set{fail};

    my $skip_sub = $$test_set{skip_sub};

    #
    # Run the passes.
    #
    foreach my $target_info (@$pass) {
        my $target_name = $$target_info{name};
        my $query       = $$targets{$target_name}{query};
        next
          unless $$targets{$target_name}{list}
          && @{ $$targets{$target_name}{list} };
        my $un_seen = @{ $$targets{$target_name}{list} };
        my $samples = count_me $$targets {$target_name}{list},
          $$target_info{limit},
          $$test_set{limit};
        foreach my $parts ( @{ $$targets{$target_name}{list} } ) {
            next unless $samples > rand $un_seen--;
            $samples--;

            #
            # Calculate the sections we're going to skip.
            #
            my %skips;
            foreach my $skip (qw /RE SB OO OM OS KP/) {
                $skips{$skip} = is_skipped $skip => $target_info, $test_set;
            }
            $skips{OM} ||= $skips{OO};
            $skips{OS} ||= $skips{OO};

            #
            # Find the thing we need to match against.
            # Note that we're going to match against $_.
            #
            my @args  = ref $parts ? @$parts : $parts;
            my @qargs = get_args query_args => $target_info, $test_set;
            local $_ =
                $query     ? $query->( @qargs, @args )
              : ref $parts ? join "" => @$parts
              :              $parts;

            #
            # See whether we want to skip the test
            #
            local $SKIP = $skip_sub && $skip_sub->( pass => $_ );

            #
            # Find out the things {-keep} should return.
            # The thing we match agains is in $_.
            #
            my @wanted;
            unless ( $skips{KP} ) {
                my @wargs = get_args wanted_args => $target_info, $test_set;
                my $w_sub = $$target_info{wanted}
                  || $$targets{$target_name}{wanted};
                @wanted = $w_sub ? $w_sub->( @wargs, @args ) : $_;
                if ( @wanted == 1 && ref $wanted[0] eq "ARRAY" ) {
                    @wanted = @{ $wanted[0] };
                }
            }

            run_pass
              name => $name,
              re   => $regex
              unless $skips{RE};
            run_OO_pass
              name => $name,
              re   => $regex
              unless $skips{OM};
            run_OO_substitution_pass
              name => $name,
              re   => $regex
              unless $skips{OS};
            run_sub_pass
              name     => $name,
              sub_args => $sub_args,
              sub      => $sub
              if $sub && !$skips{SB};
            run_keep
              name   => $name,
              re     => $keep,
              wanted => \@wanted
              unless $skips{KP};
        }
    }

    #
    # Run the failures.
    #
    foreach my $target_info (@$fail) {
        my $target_name = $$target_info{name};
        my $query       = $$targets{$target_name}{query};
        next
          unless $$targets{$target_name}{list}
          && @{ $$targets{$target_name}{list} };
        my $un_seen = @{ $$targets{$target_name}{list} };
        my $samples = count_me $$targets {$target_name}{list},
          $$target_info{limit},
          $$test_set{limit};
        foreach my $parts ( @{ $$targets{$target_name}{list} } ) {
            next unless $samples > rand $un_seen--;
            $samples--;

            my @args  = ref $parts ? @$parts : $parts;
            my @qargs = get_args query_args => $target_info, $test_set;
            local $_ =
                $query     ? $query->( @qargs, @args )
              : ref $parts ? join "" => @$parts
              :              $parts;

            local $SKIP = $skip_sub && $skip_sub->( fail => $_ );

            my %skips;
            foreach my $skip (qw /RE SB/) {
                $skips{$skip} = is_skipped $skip => $target_info, $test_set;
            }

            run_fail
              name => $name,
              re   => $regex
              unless $skips{RE};
            run_sub_fail
              name     => $name,
              sub_args => $sub_args,
              sub      => $sub
              if $sub && !$skips{SB};
        }
    }
}

#
# If there's no list, or an empty list, 0 tests have to be run.
# If no limits are given, return the size of the list.
# Else, for the first defined limit,
#           if the limit is negative, return the size of the list,
#           else if the limit is 0, return 0,
#           else if the limit is less than 1, treat it as a fraction,
#           else, return the smaller of the limit and the size of the list.
#
sub count_me {
    my ( $list, @limits ) = @_;

    return 0 unless $list && @$list;
    foreach my $limit (@limits) {
        if ( defined $limit ) {
            return @$list                 if $limit < 0;
            return int( @$list * $limit ) if $limit < 1;
            return $limit                 if $limit < @$list;
            return @$list;
        }
    }
    @$list;
}

#
# Normify any 'pass','fail' and 'skip' entries in a test.
# What we want is a 'pass' and a 'fail' pointing to an array of hashes,
# each hash being a 'target'.
#
# Since we are passed a reference, the modification is done in situ.
#
sub normify {
    my $test = shift;
    foreach my $state (@STATES) {
        my @list;

        foreach my $postfix ( "", "_arg" ) {
            my $key = "$state$postfix";
            next unless exists $$test{$key};
            my $targets = $$test{$key};
            if ( ref $targets eq 'ARRAY' ) {
                foreach my $thingy (@$targets) {
                    if ( ref $thingy eq 'HASH' ) {
                        push @list => $thingy;
                    }
                    elsif ( !ref $thingy ) {
                        push @list => { name => $thingy };
                    }
                }
            }
            elsif ( ref $targets eq 'HASH' ) {
                push @list => $targets;
            }
            else {
                push @list => { name => $targets };
            }
            delete $$test{$key};
        }

        $$test{$state} = \@list;
    }

    #
    # Skips.
    #
    if    ( !exists $$test{skip} ) { $$test{skip} = {} }
    elsif ( ref $$test{skip} eq 'ARRAY' ) {
        $$test{skip} = { map { $_ => 1 } @{ $$test{skip} } };
    }

    foreach my $state (@STATES) {
        foreach my $target ( @{ $$test{state} } ) {
            if    ( !exists $$target{skip} ) { $$target{skip} = {} }
            elsif ( ref $$target{skip} ) {
                $$target{skip} = { map { $_ => 1 } @{ $$target{skip} } };
            }
        }
    }
}

sub is_skipped {
    my ( $type, @things ) = @_;
    foreach my $thingy (@things) {
        return $$thingy{skip}{$type} if defined $$thingy{skip}{$type};
    }
    return;
}

sub mult {
    my ( $state, $has_sub, @things ) = @_;

    my $mult;

    # Regular expression test.
    $mult++ unless is_skipped RE => @things;

    # Subroutine check.
    $mult++ if $has_sub && !is_skipped SB => @things;

    if ( $state eq "pass" ) {

        # OO checks.
        $mult++ unless is_skipped OO => @things or is_skipped OM => @things;
        $mult++ unless is_skipped OO => @things or is_skipped OS => @things;

        # Keep check.
        $mult++ unless is_skipped RE => @things or is_skipped KP => @things;
    }

    return $mult;
}

sub run_new_tests {
    my %args = @_;

    my ( $tests, $targets, $version, $version_from,
        $extra_runs, $extra_runs_sub )
      = @args{
        qw /tests targets version version_from
          extra_runs extra_runs_sub/
      };

    #
    # Modify any 'pass' and 'fail' entries to arrays of hashes.
    #
    foreach my $test (@$tests) {
        normify $test;
    }

    #
    # Count the number of runs.
    #
    my $runs = defined $version_from;    # VERSION test.
    my $no_tests;
    if ($extra_runs) {
        $runs  += $extra_runs;
        $count += $extra_runs;
    }

    if ( defined $version && $version > $] ) {
        $no_tests = 1;
    }
    else {
        # Count the tests to be run.
        foreach my $test (@$tests) {

            # Test: pass: regex, regex/keep, OO, OO-substitution, sub (if given)
            #       fail: regex, sub (if given).
            my $has_sub = $$test{sub} ? 1 : 0;

            for my $state (@STATES) {
                foreach my $target ( @{ $$test{$state} } ) {
                    my $size = count_me $$targets { $$target{name} }{list},
                      $$target{limit},
                      $$test{limit};
                    $runs += $size * mult $state, $has_sub => $target, $test;
                }
            }
        }
    }

    print "1..$runs\n";

    # Check whether a version is defined.
    if ( defined $version_from ) {
        print "ok ", ++$count, "\n";
    }

    if ($extra_runs_sub) {
        $extra_runs_sub->( \$count );
    }

    unless ($no_tests) {
        foreach my $test (@$tests) {
            run_new_test_set
              test_set => $test,
              targets  => $targets;
        }
    }
}

#
# Function to produce random strings.
#

# Digit.
sub d { int rand 10 }

# Positive digit.
sub pd { 1 + int rand 9 }

# String of digits.
sub dd {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { d } 1 .. $min + int rand( $max - $min );
}

# String of digits, not all 0.
sub pdd {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
  TRY: my $dd = join "" => map { d } 1 .. $min + int rand( $max - $min );
    goto TRY unless $dd =~ /[^0]/;
    $dd;
}

# Lowercase letter.
sub l { chr( ord('a') + int rand 26 ) }

# String of lowercase letters.
sub ll {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { l } 1 .. $min + int rand( $max - $min );
}

# Uppercase letter.
sub L { chr( ord('a') + int rand 26 ) }

# String of uppercase letters.
sub LL {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { L } 1 .. $min + int rand( $max - $min );
}

# Alpha.
sub a { 50 < rand(100) ? l : L }

# String of alphas.
sub aa {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { a } 1 .. $min + int rand( $max - $min );
}

# Alphanum.
sub w { 52 < rand(62) ? d : a }

# String of alphanums.
sub ww {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { w } 1 .. $min + int rand( $max - $min );
}

# Lowercase hex digit.
sub _x { ( 0 .. 9, 'a' .. 'f' )[ int rand 16 ] }

# String of lowercase hex digits.
sub xx {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { _x } 1 .. $min + int rand( $max - $min );
}

# Uppercase hex digit.
sub X { ( 0 .. 9, 'A' .. 'F' )[ int rand 16 ] }

# String of uppercase hex digits.
sub XX {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { X } 1 .. $min + int rand( $max - $min );
}

# Any case hex digit
sub h { ( 0 .. 9, 'A' .. 'F', 'a' .. 'f' )[ int rand 22 ] }

# String of anycase hex digits
sub hh {
    my ( $min, $max ) = @_ > 1 ? (@_) : ( $_[0], $_[0] );
    join "" => map { h } 1 .. $min + int rand( $max - $min );
}

#
# Pass a number N and a callback C. Return N different results from C.
# Will do at most 100 * N tries.
#
sub gimme {
    my ( $count, $call ) = @_;
    my %cache;
    foreach ( 1 .. 100 * $count ) {
        $cache{ $call->() } = 1;
        last if keys %cache >= $count;
    }
    keys %cache;
}

#
# Given a number N, and a list of things, return a sample of N
#
sub sample {
    my $N = shift;
    return @_ if @_ <= $N;

    my @cache = splice @_ => 0, $N;
    my $count = $N;
    map { rand ++$count < $N and splice @cache, rand @cache, 1, $_ } @_;

    @cache;
}

1;

__END__

=head1 DESCRIPTION

C<run_new_tests> is called with three (named) parameters:

=over 4

=item C<tests>

A references to an array of I<tests> (explained below).

=item C<targets>

A reference to a hash of I<targets> (explained below).

=item C<version_from>

The name of the file that is checked for a version number.

=back

=head2 Targets

Targets provide a set of strings to match against. Targets are
indexed by name. Each target is a hash, with the following keys:

=over 4

=item C<list>

Required. This is a reference to an array that will act as building
blocks to build strings to match against. In the simplest form, this
is just an array with strings - but typically, this is an array of
arrays, each subarray used to create a string.

=item C<query>

A coderef. For each entry in array given above, this coderef is called.
It takes a set of arguments and returns a string to match against. If
the corresponding entry in C<list> is reference to an array, all its
elements are passed - otherwise, the entry is passed as a whole. Extra
arguments provided with C<query_args> below are prepended. If no coderef
is given, C<sub {$_ [0]}> is assumed.

=item C<wanted>

A coderef. If the target is used for positive matches (that is, it's
expected to match), this sub is called with the same arguments as C<query>
- except that C<wanted_args> are prepended. It should return a list of
strings as if the regular expression was called with C<{-keep}>. The
string to match against may be assumed to be C<$_>. If no coderef is given,
C<sub {$_}> is assumed.

=back

=head2 Tests

The tests to run are put in an array, and run in that order. Each test
tests a specific pattern. Up to seven types of tests are performed, depending
whether the tests includes expected failures, expected passes or both.
Expected passes are tested as a regular expression, as a regular expression
with the C<{-keep}> option, as a subroutine, as an object using the C<match>
method, and as an object using the C<subs> method. Expected failures are
tested as a regular expression, and as a subroutine. Each test is a hash
with the following keys:

=over 4

=item C<name>

The name of this test - mostly used in the test output.

=item C<regex>

The pattern to test with.

=item C<sub>

The subroutine to test with, if any.

=item C<sub_args>

Any arguments that need to be passed into the subroutine. If more than
one argument needs to be passed, use a reference to an array - the array
will be flattened when calling the subroutine.

=item C<query_args>

Extra arguments to pass into the C<query> coderef for all the targets
belonging to this tests, if not overriden as discussed below.

=item C<wanted_args>

Extra arguments to pass into the C<wanted> coderef for all the targets
belonging to this tests, if not overriden as discussed below.

=item C<pass>

Indicates which targets (discussed above) should be run with expected
passes.  The value of C<pass> is either a reference to an array - the
array containing the names of the targets to run, or a reference to a
hash. In the latter case, the keys are the targets to be run, while the
keys are hash references, containing more configuration options for the
target. Values allowed:

=over 4

=item C<query_args>

Extra arguments to pass into the C<query> coderef belonging to this test.
See discussion above.

=item C<wanted_args>

Extra arguments to pass into the C<wanted> coderef belonging to this test.
See discussion above.

=back

=item C<fail>

As C<pass>, except that it will list targets with an expected failure.

=back
