The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
#Copyright 2007-8 Arthur S Goldstein
use Test::More tests => 9;
BEGIN { use_ok('Parse::Stallion') };
use Time::Local;

my %rule;
$rule{start_date} = AND(
  'parsed_date',
  E(sub {my $seconds_since_epoch = $_[0]->{parsed_date};
    my ($seconds, $minutes, $hour, $mday, $month, $year) =
     gmtime($seconds_since_epoch);
    $month++;  #Have January be 01 instead of 00.
    if ($month < 10) { $month = '0'.$month;};
    if ($mday < 10) { $mday = '0'.$mday;};
    if ($seconds < 10) { $seconds = '0'.$seconds;};
    if ($minutes < 10) { $minutes = '0'.$minutes;};
    if ($hour < 10) { $hour = '0'.$hour;};
    return (1900+$year).$month.$mday.$hour.$minutes.$seconds;
  })
);
$rule{parsed_date} = OR
  ('date', 'date_operation'
);
$rule{date_operation} = OR(
  'add_time', 'subtract_time'
);
$rule{add_time} = AND(
  'date', 'plus', 'time',
  E(sub {return $_[0]->{date} + $_[0]->{time}})
);
$rule{subtract_time} = AND(
  'date', 'minus', 'time',
  E(sub {return $_[0]->{date} - $_[0]->{time}})
);
$rule{date} = OR(
  'standard_date', 'special_date'
);
$rule{plus} = LEAF(
  qr/\s*\+\s*/
);
$rule{minus} = LEAF(
  qr/\s*\-\s*/
);
$rule{standard_date} = L(
  qr(\d+\/\d+\/\d+),
  E(sub {my $date = $_[0];
    $date =~ /(\d+)\/(\d+)\/(\d+)/;
    my $month = $1 -1;
    my $mday = $2;
    my $year = $3;
    return timegm(0,0,0,$mday, $month, $year);
  })
);
$rule{special_date} = L(
  qr/now/i,
  E(sub {return timegm(24,40,0,5, 7, 2007);})
);
$rule{time} = OR(
  'just_time', 'just_time_plus_list', 'just_time_minus_list')
;
$rule{just_time_plus_list} = A(
  'just_time', 'plus', 'time',
  E(sub {return $_[0]->{just_time} + $_[0]->{time}})
);
$rule{just_time_minus_list} = A(
  'just_time', 'minus', 'time',
  E(sub {return $_[0]->{just_time} - $_[2]->{time}})
);
$rule{just_time} = L(
  qr(\d+\s*[hdms]),
  E(sub {
    my $to_match = $_[0];
    $to_match =~ /(\d+)\s*([hdms])/;
    my $number = $1;
    my $unit = $2;
    if ($unit eq 'h') {
      return $1 * 60 * 60;
    }
    if ($unit eq 'd') {
      return $1 * 24 * 60 * 60;
    }
    if ($unit eq 's') {
      return $1;
    }
    if ($unit eq 'm') {
      return $1 * 60;
    }
  })
);

my $date_parser = new Parse::Stallion(
  \%rule,
  { start_rule => 'start_date'});

my $parsed_tree;
my $result =
 $date_parser->parse_and_evaluate("now");
print "Result is $result\n";

SKIP: {
skip ('do not trust timegm/gmtime on this machine', 8) if ($result ne '20070805004024');

is ($result, 20070805004024, "now set up with hard coded date");

$result =
 $date_parser->parse_and_evaluate("now - 10s");
print "NResult minus 10 is $result\n";
is ($result, 20070805004014, "10 seconds before hard coded date");

$result =
 $date_parser->parse_and_evaluate("now + 70h");
print "NResult plus 70 hours is $result\n";
is ($result, 20070807224024, "70 hours after hard coded date");

$result =
 $date_parser->parse_and_evaluate("now + 70h +3s");
print "NResult plus 70 hours plus 3 sec is $result\n";
is ($result, 20070807224027, "70 hours 3 secs after hard coded date");

$result =
 $date_parser->parse_and_evaluate("3/22/2007");
print "NResult march 22 2007is $result\n";
is ($result, 20070322000000, "3/22/2007");

$result =
 $date_parser->parse_and_evaluate("3/22/2007 + 5d");
print "NResult march 22 2007 plus 5 days is $result\n";
is ($result, 20070327000000, "3/22/2007 and 5 days");

$result =
 $date_parser->parse_and_evaluate("2/22/2008 + 7d");
print "NResult feb 22 2008 plus 7 days is $result\n";
is ($result, 20080229000000, "2/22/2008 and 7 days");

$result =
 $date_parser->parse_and_evaluate("2/22/2007 + 7d");
print "NResult feb 22 2007 plus 7 days is $result\n";
is ($result, 20070301000000, "2/22/2008 and 7 days");


}

print "\nAll done\n";