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

use strict;

sub split_time {
  my $time = shift || time;
  my ($seconds, $minutes, $hour, $mday, $month, $year) = localtime($time);
  return {year => $year + 1900, month => $month+1, mday => $mday,
   hour => $hour, minutes => $minutes, seconds => $seconds};
}

my %full_months = (
january => 1,
february => 2,
march => 3,
april => 4,
may => 5,
june => 6,
july => 7,
august => 8,
september => 9,
october => 10,
november => 11,
december => 12,
);
my %abbreviated_months = (
jan => 1,
feb => 2,
mar => 3,
apr => 4,
may => 5,
jun => 6,
jul => 7,
aug => 8,
sep => 9,
oct => 10,
nov => 11,
dec => 12,
);

my %days_in_month = (
  1 => 31,
  3 => 31,
  4 => 30,
  5 => 31,
  6 => 30,
  7 => 31,
  8 => 31,
  9 => 30,
  10 => 31,
  11 => 30,
  12 => 31,
);

sub valid_mday {
  my ($mday, $month, $year) = @_;
#print STDERR "trying to validate $mday and $month and $year\n";
  if ($month == 2) {
    my $is_leap_year = 0;
    my $leap_year = $year % 4;
    if ($leap_year) {
      my $not_leap_year = $year % 100;
      if ($not_leap_year) {
        my $leap_year = $year % 400;
        if ($leap_year) {
          $is_leap_year = 1;
        }
      }
      else {
        $is_leap_year = 1;
      }
    }
    return ((1 <= $mday) && ($mday <= $28 + $is_leap_year));
  }
  return ((1 <= $mday) && ($mday <= $days_in_month{$month}));
}

my %keywords = (
  when => 'when',
  what => 'details',
  details => 'details',
  where => 'where',
  location => 'where',
);

my %event_rules = (

event => 
  A('event_detail', L(qr/\z/),
  E(sub {
#use Data::Dumper;
  #print STDERR "parms in ".Dumper(\@_)."\n";
  #print STDERR "hoo\n";
   return $_[0]->{event_detail}})
),

event_detail => M(
  'event_detail_item',
  E(sub {
    my $parameters = shift;
    my %detail;
#use Data::Dumper;
  #print STDERR "parms out ".Dumper($parameters)."\n";
#print STDERR "edi\n";
    if (defined $parameters->{event_detail_item}) {
#print STDERR "defined\n";
      foreach my $i (@{$parameters->{event_detail_item}}) {
        $detail{$i->{keyword}} = $i->{information};
      }
    }
#print STDERR "detail back is ".Dumper(\%detail)."\n";
    return \%detail;
  })
),

event_detail_item => A(
  'keyword', 'separator', 'information'
),

separator => L(qr/\s*\:\s*/),

keyword => L(
  qr/\w+/,
  E(sub {
    my $word = shift;
    if (defined $keywords{lc $word}) {
      return $keywords{lc $word};
    }
    else {
      return (undef, 1);
    }
  }),
),

any_char => L(
  qr/./s
),

information => M(
  'any_char', MATCH_MIN_FIRST(), E(
  sub {
#use Data::Dumper; print STDERR "information is ".Dumper(\@_)."\n";
    my $param = shift;
    if ($param->{any_char}) {return join ('',@{$param->{any_char}})};
  })
),

);


use Parse::Stallion;
my $event_parser = new Parse::Stallion(
 \%event_rules,
  { start_rule => 'event',
 do_evaluation_in_parsing => 1,
});

my $event_in = 'when: yesterday
what: nothing';

my $result = $event_parser->parse_and_evaluate($event_in);
#use Data::Dumper;
#print STDERR "Results out ".(Dumper($ne_result))."\n";
#foreach my $tr (@{$result->{parse_trace}}) {
#  print STDERR "tr is now ".Dumper($tr)."\n";
#};
#my $result = $event_parser->do_tree_evaluation($ne_result);
#print STDERR "result is ".Dumper($result)."\n";

is_deeply ($result, {
          'when' => 'yesterday
',
          'details' => 'nothing'
        }, 'event break down');

1;