use strict; use warnings; my (@match, $num_tests); BEGIN { @match = ( # hms tests. # Base case ['10:23:45am', 'hms', [], 1, [qw(10:23:45am 10 23 45 am)]], # am/pm variations ['10:23:45a', 'hms', [], 1, [q(10:23:45a), qw(10 23 45 a)]], ['10:23:45am', 'hms', [], 1, [q(10:23:45am), qw(10 23 45 am)]], ['10:23:45a.m.', 'hms', [], 1, [q(10:23:45a.m.), qw(10 23 45 a.m.)]], ['10:23:45 a', 'hms', [], 1, [q(10:23:45 a), qw(10 23 45 a)]], ['10:23:45 am', 'hms', [], 1, [q(10:23:45 am), qw(10 23 45 am)]], ['10:23:45 a.m.', 'hms', [], 1, [q(10:23:45 a.m.), qw(10 23 45 a.m.)]], ['10:23:45p', 'hms', [], 1, [q(10:23:45p), qw(10 23 45 p)]], ['10:23:45pm', 'hms', [], 1, [q(10:23:45pm), qw(10 23 45 pm)]], ['10:23:45p.m.', 'hms', [], 1, [q(10:23:45p.m.), qw(10 23 45 p.m.)]], ['10:23:45 p', 'hms', [], 1, [q(10:23:45 p), qw(10 23 45 p)]], ['10:23:45 pm', 'hms', [], 1, [q(10:23:45 pm), qw(10 23 45 pm)]], ['10:23:45 p.m.', 'hms', [], 1, [q(10:23:45 p.m.), qw(10 23 45 p.m.)]], ['10:23:45A', 'hms', [], 1, [q(10:23:45A), qw(10 23 45 A)]], ['10:23:45AM', 'hms', [], 1, [q(10:23:45AM), qw(10 23 45 AM)]], ['10:23:45A.M.', 'hms', [], 1, [q(10:23:45A.M.), qw(10 23 45 A.M.)]], ['10:23:45 A', 'hms', [], 1, [q(10:23:45 A), qw(10 23 45 A)]], ['10:23:45 AM', 'hms', [], 1, [q(10:23:45 AM), qw(10 23 45 AM)]], ['10:23:45 A.M.', 'hms', [], 1, [q(10:23:45 A.M.), qw(10 23 45 A.M.)]], ['10:23:45P', 'hms', [], 1, [q(10:23:45P), qw(10 23 45 P)]], ['10:23:45PM', 'hms', [], 1, [q(10:23:45PM), qw(10 23 45 PM)]], ['10:23:45P.M.', 'hms', [], 1, [q(10:23:45P.M.), qw(10 23 45 P.M.)]], ['10:23:45 P', 'hms', [], 1, [q(10:23:45 P), qw(10 23 45 P)]], ['10:23:45 PM', 'hms', [], 1, [q(10:23:45 PM), qw(10 23 45 PM)]], ['10:23:45 P.M.', 'hms', [], 1, [q(10:23:45 P.M.), qw(10 23 45 P.M.)]], # Separators ['10.23.45am', 'hms', [], 1, [qw(10.23.45am 10 23 45 am)]], ['10 23 45 am','hms', [], 1, [q(10 23 45 am), qw(10 23 45 am)]], ['10/23/45 am','hms', [], 0, ], # Hour boundaries ['0:23:45', 'hms', [], 1, [qw(0:23:45 0 23 45), undef]], ['1:23:45', 'hms', [], 1, [qw(1:23:45 1 23 45), undef]], ['12:23:45', 'hms', [], 1, [qw(12:23:45 12 23 45), undef]], ['13:23:45', 'hms', [], 1, [qw(13:23:45 13 23 45), undef]], ['23:23:45', 'hms', [], 1, [qw(23:23:45 23 23 45), undef]], ['24:34:45', 'hms', [], 0, ], ['25:46:45', 'hms', [], 0, ], ['99:46:45', 'hms', [], 0, ], # Minute limits ['10:00:45am', 'hms', [], 1, [qw(10:00:45am 10 00 45 am)]], ['10:59:45am', 'hms', [], 1, [qw(10:59:45am 10 59 45 am)]], ['10:60:45am', 'hms', [], 0, ], # No second limits! Because out-of-range means no match; must catch in normalize_hms. # Optional seconds ['10:23am', 'hms', [], 1, [qw(10:23am 10 23), undef, qw(am)]], # Optional am/pm ['10:23:45', 'hms', [], 1, [qw(10:23:45 10 23 45), undef]], # Optional both ['10:23', 'hms', [], 1, [qw(10:23 10 23), undef, undef]], ); # How many matches will succeed? my $to_succeed = scalar grep $_->[3], @match; # Run two tests per match, plus two additional per expected success $num_tests = 2 * scalar(@match) + 2 * $to_succeed; } use Test::More tests => $num_tests; use Regexp::Common 'time'; foreach my $match (@match) { my ($text, $name, $flags, $should_succeed, $matchvars) = @$match; my $testname = qq{"$text" =~ "$name"}; my $did_succeed; my @captures; # Regexp captures # FIRST: check whether it succeeded or failed as expected. # 'keep' option is OFF; should be no captures. if (@$flags) { my $flags = join $; => @$flags; @captures = $text =~ /$RE{time}{$name}{$flags}/; } else { @captures = $text =~ /$RE{time}{$name}/; } $did_succeed = @captures > 0; my $ought = $should_succeed? 'match' : 'fail'; my $actual = $did_succeed == $should_succeed? "${ought}ed" : "did not $ought"; # TEST 1: simple matching ok ( ($should_succeed && $did_succeed) || (!$should_succeed && !$did_succeed), "$testname - $actual as expected (nokeep)."); # TEST 2: Shouldn't capture anything if ($should_succeed) { SKIP: { skip "$testname - can't check captures since match unsuccessful", 1 if !$did_succeed; is_deeply(\@captures, [1], "$testname - didn't unduly capture"); } } # SECOND: use 'keep' option to check captures. if (@$flags) { my $flags = join $; => @$flags; @captures = $text =~ /$RE{time}{$name}{$flags}{-keep}/; } else { @captures = $text =~ /$RE{time}{$name}{-keep}/; } $did_succeed = @captures > 0; # TEST 3: matching with 'keep' ok ( ($should_succeed && $did_succeed) || (!$should_succeed && !$did_succeed), "$testname - $actual as expected (keep)."); # TEST 4: capture variables should be set. if ($should_succeed) { SKIP: { skip "$testname - can't check captures since match unsuccessful", 1 if !$did_succeed; is_deeply(\@captures, $matchvars, "$testname - correct capture variables"); } } }