package Genealogy::Gedcom::Date::Actions;
use strict;
use warnings;
use Data::Dumper::Concise; # For Dumper().
our $calendar;
our $logger;
our $VERSION = '2.02';
# ------------------------------------------------
sub about_date
{
my($cache, $t1, $t2) = @_;
my($t3) = $$t2[1];
$t3 = $$t3[0] if (ref $t3 eq 'ARRAY');
$$t3{flag} = 'ABT';
return [$$t2[0], $t3];
} # End of about_date.
# ------------------------------------------------
sub after_date
{
my($cache, $t1, $t2) = @_;
my($t3) = $$t2[1];
$t3 = $$t3[0] if (ref $t3 eq 'ARRAY');
$$t3{flag} = 'AFT';
return [$$t2[0], $t3];
} # End of after_date.
# ------------------------------------------------
sub before_date
{
my($cache, $t1, $t2) = @_;
my($t3) = $$t2[1];
$t3 = $$t3[0] if (ref $t3 eq 'ARRAY');
$$t3{flag} = 'BEF';
return [$$t2[0], $t3];
} # End of before_date.
# ------------------------------------------------
sub between_date
{
my($cache, $t1, $t2, $t3, $t4) = @_;
my($t5) = $$t2[1][0];
$$t5{flag} = 'BET';
my($t6) = $$t4[1][0];
$$t6{flag} = 'AND';
if (ref $$t2[0] eq 'HASH')
{
$t1 = $$t2[0];
}
else
{
$t1 = {kind => 'Calendar', type => $calendar};
}
if (ref $$t4[0] eq 'HASH')
{
$t3 = $$t4[0];
}
else
{
$t3 = {kind => 'Calendar', type => $calendar};
}
$t1 = [$t1, $t5, $t3, $t6];
return $t1;
} # End of between_date.
# ------------------------------------------------
sub calculated_date
{
my($cache, $t1, $t2) = @_;
my($t3) = $$t2[1];
$t3 = $$t3[0] if (ref $t3 eq 'ARRAY');
$$t3{flag} = 'CAL';
return [$$t2[0], $t3];
} # End of calculated_date.
# ------------------------------------------------
sub calendar_name
{
my($cache, $t1) = @_;
$t1 =~ s/\@\#d(.+)\@/$1/; # Zap gobbledegook if present.
$t1 = ucfirst lc $t1;
return
{
kind => 'Calendar',
type => $t1,
};
} # End of calendar_name.
# ------------------------------------------------
sub date_phrase
{
my($cache, $t1) = @_;
return
{
kind => 'Phrase',
phrase => "($$t1[0])",
type => 'Phrase',
};
} # End of date_phrase.
# ------------------------------------------------
sub estimated_date
{
my($cache, $t1, $t2) = @_;
my($t3) = $$t2[1];
$t3 = $$t3[0] if (ref $t3 eq 'ARRAY');
$$t3{flag} = 'EST';
return [$$t2[0], $t3];
} # End of estimated_date.
# ------------------------------------------------
sub french_date
{
my($cache, $t1) = @_;
my($bce);
my($day);
my($month);
my($year);
# Check for year, month, day.
if ($#$t1 == 0)
{
$year = $$t1[0];
}
elsif ($#$t1 == 1)
{
# First check for BCE.
if ($$t1[1] =~ /[0-9]/)
{
$month = $$t1[0];
$year = $$t1[1];
}
else
{
$bce = $$t1[1];
$year = $$t1[0];
}
}
else
{
$day = $$t1[0];
$month = $$t1[1];
$year = $$t1[2];
}
my($result) =
{
kind => 'Date',
type => 'French r',
year => $year,
};
$$result{bce} = $bce if (defined $bce);
$$result{day} = $day if (defined $day);
$$result{month} = $month if (defined $month);
$result = [$result];
return $result;
} # End of french_date.
# ------------------------------------------------
sub from_date
{
my($cache, $t1, $t2) = @_;
my($t3) = $$t2[0];
$t2 = $$t2[1];
$t2 = $$t2[0] if (ref $t2 eq 'ARRAY');
$$t2{flag} = 'FROM';
# Is there a calendar hash present?
if (ref $t3 eq 'HASH')
{
$t2 = [$t3, $t2];
}
return $t2;
} # End of from_date.
# ------------------------------------------------
sub german_date
{
my($cache, $t1) = @_;
my($bce);
my($day);
my($month);
my($year);
# Check for year, month, day.
if ($#$t1 == 0)
{
$year = $$t1[0][0];
$bce = $$t1[0][1];
}
elsif ($#$t1 == 2)
{
$month = $$t1[0];
$year = $$t1[2][0];
$bce = $$t1[2][1];
}
else
{
$day = $$t1[0];
$month = $$t1[2];
$year = $$t1[4][0];
$bce = $$t1[4][1];
}
my($result) =
{
kind => 'Date',
type => 'German',
year => $year,
};
$$result{bce} = $bce if (defined $bce);
$$result{day} = $day if (defined $day);
$$result{month} = $month if (defined $month);
$result = [$result];
return $result;
} # End of german_date.
# ------------------------------------------------
sub gregorian_date
{
my($cache, $t1) = @_;
# Is it a BCE date? If so, it's already a hashref.
if (ref($$t1[0]) eq 'HASH')
{
return $$t1[0];
}
my($day);
my($month);
my($year);
# Check for year, month, day.
if ($#$t1 == 0)
{
$year = $$t1[0];
}
elsif ($#$t1 == 1)
{
$month = $$t1[0];
$year = $$t1[1];
}
else
{
$day = $$t1[0];
$month = $$t1[1];
$year = $$t1[2];
}
my($result) =
{
kind => 'Date',
type => 'Gregorian',
year => $year,
};
# Check for /00.
if ($year =~ m|/|)
{
($$result{year}, $$result{suffix}) = split(m|/|, $year);
}
$$result{month} = $month if (defined $month);
$$result{day} = $day if (defined $day);
$result = [$result];
return $result;
} # End of gregorian_date.
# ------------------------------------------------
sub gregorian_month
{
my($cache, $t1) = @_;
$t1 = $$t1[0] if (ref $t1);
return $t1;
} # End of gregorian_month.
# ------------------------------------------------
sub gregorian_year_bce
{
my($cache, $t1, $t2) = @_;
return
{
bce => $t2,
kind => 'Date',
type => 'Gregorian',
year => $t1,
};
} # End of gregorian_year_bce.
# ------------------------------------------------
sub hebrew_date
{
my($cache, $t1) = @_;
my($bce);
my($day);
my($month);
my($year);
# Check for year, month, day.
if ($#$t1 == 0)
{
$year = $$t1[0];
}
elsif ($#$t1 == 1)
{
# First check for BCE.
if ($$t1[1] =~ /[0-9]/)
{
$month = $$t1[0];
$year = $$t1[1];
}
else
{
$bce = $$t1[1];
$year = $$t1[0];
}
}
else
{
$day = $$t1[0];
$month = $$t1[1];
$year = $$t1[2];
}
my($result) =
{
kind => 'Date',
type => 'Hebrew',
year => $year,
};
$$result{bce} = $bce if (defined $bce);
$$result{day} = $day if (defined $day);
$$result{month} = $month if (defined $month);
$result = [$result];
return $result;
} # End of hebrew_date.
# ------------------------------------------------
sub interpreted_date
{
my($cache, $t1) = @_;
my($t2) = $$t1[1][1][0];
$$t2{flag} = 'INT';
$$t2{phrase} = "($$t1[2][0])";
return [$$t1[1][0], $t2];
} # End of interpreted_date.
# ------------------------------------------------
sub julian_date
{
my($cache, $t1) = @_;
# Is it a BCE date? If so, it's already a hashref.
if (ref($$t1[0]) eq 'HASH')
{
return $$t1[0];
}
my($day);
my($month);
my($year);
# Check for year, month, day.
if ($#$t1 == 0)
{
$year = $$t1[0];
}
elsif ($#$t1 == 1)
{
$month = $$t1[0];
$year = $$t1[1];
}
else
{
$day = $$t1[0];
$month = $$t1[1];
$year = $$t1[2];
}
my($result) =
{
kind => 'Date',
type => 'Julian',
year => $year,
};
$$result{month} = $month if (defined $month);
$$result{day} = $day if (defined $day);
$result = [$result];
return $result;
} # End of julian_date.
# ------------------------------------------------
sub julian_year_bce
{
my($cache, $t1, $t2) = @_;
return
{
bce => $t2,
kind => 'Date',
type => 'Julian',
year => $t1,
};
} # End of julian_year_bce.
# ------------------------------------------------
sub to_date
{
my($cache, $t1, $t2) = @_;
my($t3) = $$t2[0];
$t2 = $$t2[1];
$t2 = $$t2[0] if (ref $t2 eq 'ARRAY');
$$t2{flag} = 'TO';
# Is there a calendar hash present?
if (ref $t3 eq 'HASH')
{
$t2 = [$t3, $t2];
}
return $t2;
} # End of to_date.
# ------------------------------------------------
sub year
{
my($cache, $t1, $t2) = @_;
$t1 = "$t1/$t2" if (defined $t2);
return $t1;
} # End of year.
# ------------------------------------------------
1;
=pod
=head1 NAME
C<Genealogy::Gedcom::Date::Actions> - A nested SVG parser, using XML::SAX and Marpa::R2
=head1 Synopsis
See L<Genealogy::Gedcom::Date/Synopsis>.
=head1 Description
Basically just utility routines for L<Genealogy::Gedcom::Date>. Only used indirectly by
L<Marpa::R2>.
Specifially, calls to functions are triggered by items in the input stream matching elements of
the current grammar (and Marpa does the calling).
Each action function returns a arrayref or hashref, which Marpa gathers. The calling code in
L<Genealogy::Gedcom::Date> decodes the result so that its C<parse()> method can return an arrayref.
=head1 Installation
See L<Genealogy::Gedcom::Date/Installation>.
=head1 Constructor and Initialization
This class has no constructor. L<Marpa::R2> fabricates an instance, but won't let us get access to
it.
So, we use a global variable, C<$logger>, initialized in L<Genealogy::Gedcom::Date>,
in case we need logging. Details:
=over 4
=item o logger => aLog::HandlerObject
By default, an object of type L<Log::Handler> is created which prints to STDOUT,
but given the default, nothing is actually printed unless the C<maxlevel> attribute of this object
is changed in L<Genealogy::Gedcom::Date>.
Default: anObjectOfTypeLogHandler.
Usage (in this module): $logger -> log(info => $string).
=back
=head1 Methods
None.
=head1 Functions
Many.
=head1 Globals
Yes, some C<our> variables are used to communicate the C<Genealogy::Gedcom::Date>.
=head1 FAQ
See L<Genealogy::Gedcom::Date/FAQ>.
=head1 Author
L<Genealogy::Gedcom::Date> was written by Ron Savage I<E<lt>ron@savage.net.auE<gt>> in 2011.
Home page: L<http://savage.net.au/>.
=head1 Copyright
Australian copyright (c) 2011, Ron Savage.
All Programs of mine are 'OSI Certified Open Source Software';
you can redistribute them and/or modify them under the terms of
The Artistic License 2.0, a copy of which is available at:
http://www.opensource.org/licenses/index.html
=cut