Regexp-Common-2017060201/t/Common.pm

package t::Common;

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

use Regexp::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