The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
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");
        }
    }
}