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 is called with three (named) parameters: =over 4 =item C A references to an array of I (explained below). =item C A reference to a hash of I (explained below). =item C 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 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 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 is reference to an array, all its elements are passed - otherwise, the entry is passed as a whole. Extra arguments provided with C below are prepended. If no coderef is given, C is assumed. =item C 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 - except that C 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 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 method, and as an object using the C 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 The name of this test - mostly used in the test output. =item C The pattern to test with. =item C The subroutine to test with, if any. =item C 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 Extra arguments to pass into the C coderef for all the targets belonging to this tests, if not overriden as discussed below. =item C Extra arguments to pass into the C coderef for all the targets belonging to this tests, if not overriden as discussed below. =item C Indicates which targets (discussed above) should be run with expected passes. The value of C 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 Extra arguments to pass into the C coderef belonging to this test. See discussion above. =item C Extra arguments to pass into the C coderef belonging to this test. See discussion above. =back =item C As C, except that it will list targets with an expected failure. =back