File Coverage

blib/lib/Date/Roman.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Date::Roman;
use Carp;
use Roman qw(); #do not import roman and Roman, we want define our
                #'roman' sub, which does something entierly different
                #from Roman::roman

use strict;

use vars qw($VERSION);

use constant LastJulian => 1582;

# Symbolic constants to identify fixed days

use constant Kalendae => 0;
use constant Nonae => 1;
use constant Idibus => 2;

$VERSION = '1.06';

# Array local variables containing months' names
my @MONS_SHORT = ('','Ian.','Feb.','Mar.','Apr.','Mai.','Iun.',
		  'Iul.','Aug.','Sep.','Oct.','Nov.','Dec.');

my @MONS = ('','Ianuarias','Februarias','Martias','Apriles',
	    'Maias','Iunias','Iulias','Augustas','Septembres',
	    'Octobres','Novembres','Decembres');

my @MONS_FD = ('','Ianuariis','Februariis','Martiis','Aprilibus',
	       'Maiis','Iuniis','Iuliis','Augustis','Septembribus',
	       'Octobribus','Novembribus','Decembribus');


# Array local variables containing fixed day names (Nota: the indexing
# is based on the constants above).

my @FD_SHORT = ('Kal.','Non.','Id.');
my @FD = ('Kalendas','Nonas','Idus');
my @FD_FD = ('Kalendis','Nonis','Idibus');




sub new {
  my $class = shift;
  my ($ical,$roman);

  # default behavior: Date::Roman->new() is the same thing as
  # Date::Roman->new(epoch => time())

  @_ = ('epoch',time()) unless @_;

  if (ref($_[0])) {
    my $dateobject = shift;
    if ($dateobject->can('roman')) {
      $roman = _parse_roman($dateobject->roman());
    }
    elsif ($dateobject->can('ical')) {
      $ical = _parse_ical($dateobject->ical());
    }
    else {
      croak "Bad parameter to ",__PACKAGE__,"::new()";
    }
  }
  elsif ($_[0] eq 'roman') {
    $roman = _parse_roman($_[1]);
  }
  elsif ($_[0] eq 'ical') {
    $ical = _parse_ical($_[1]);
  }
  elsif ($_[0] eq 'epoch') {
    my ($day,$month,$year) = (localtime($_[1]))[3,4,5];
    $ical->{day} = $day;
    $ical->{month} = $month + 1;
    $ical->{year} = $year + 1900;
  }
  else {
    my %args = @_;
    if (grep {exists $args{$_}} qw(base mons annus)) {
      $args{ad} = 1 unless exists $args{ad};
      $args{bis} = 0 unless exists $args{bis};
      $args{base} = lc($args{base});
      $args{base} = ($args{base} eq 'kal') ? Kalendae :
	(($args{base} eq 'non') ? Nonae : Idibus);

      foreach (qw(base mons annus)) {
	croak "Parameter $_ is mandatory" unless exists $args{$_};
      }

      #I hate it...
      foreach (qw(ad mons annus)) {
	$args{$_} += 0;
      }

      _check_roman(\%args);
      $roman = \%args;
    }
    elsif (grep {exists $args{$_}} qw(day month year)) {
      #I hate it...
      foreach (keys %args) {
	croak "Parameter $_ mandatory" unless exists $args{$_};
	$args{$_} += 0;
      }
      _check_ical(\%args);
      $ical = \%args;
    }
    else {
      croak "Bad parameters to ",__PACKAGE__,"::new()";
    }
  }

  $roman = _ical_to_roman($ical) unless $roman;


  bless $roman,$class;
}

sub roman {
  my $self = shift;

  if (@_) {
    my $roman = shift;
    my $rhash = _parse_roman($roman);
    if ($rhash) {
      %{$self} = %{$rhash};
    }
    else {
      carp __PACKAGE__," Malformed roman date string $roman";
    }
  }

  my $result;
  if ($self->{bis}) {
    $result = "b6 ";
  }
  elsif ($self->{ad} == 2) {
    $result = "pd ";
  }
  elsif ($self->{ad} > 2) {
    $result = "$self->{ad} ";
  }

  $result .= (qw(kal non id))[$self->{base}];

  $result .= " $self->{mons} $self->{annus}";

  return $result;
}


sub ical {
  my $self = shift;
  my $ihash;

  if (@_) {
    my $ical = shift;
    $ihash = _parse_ical($ical);
    if ($ihash) {
      my $rhash = _ical_to_roman($ihash);
      %{$self} = %{$rhash};
    }
    else {
      carp __PACKAGE__," Malformed ical string $ical";
    }
  }

  unless ($ihash) {
    $ihash = _roman_to_ical($self);
  }

  sprintf "%d%0.2d%0.2d",$ihash->{year},$ihash->{month},$ihash->{day};
}



sub add {
  my $self = shift;
  my ($days) = @_;
  my $class = ref($self);

  my %result = %{$self};
  $result{ad} -= $days;

  _normalize_roman_date(\%result);

  bless \%result,$class;
}

sub postridie {
  $_[0]->add(1);
}

sub heri {
  $_[0]->add(-1);
}


sub as_string {
  my $self = shift;
  my %args = @_;
  my %params = ();
  my $string = "";

  $params{prefix} = $args{prefix} ||$args{words} || 'abbrev';
  $params{die} = $args{die} || $args{num} || 'Roman';
  $params{mons} = $args{mons} || $args{words} || 'abbrev';
  $params{fday} = $args{fday} || $args{words} || 'abbrev';
  $params{annus} = $args{annus} || $args{num} || 'Roman';
  $params{auc} = $args{auc} || $args{words} || 'abbrev';

  if ($self->{ad} == 2) {
    $string = ($params{prefix} eq 'abbrev') ? "p.d. " : "pridie ";
  }
  elsif ($self->{ad} > 2) {
    $string = ($params{prefix} eq 'abbrev') ? "a.d. " : "ante diem ";
    if ($params{die} eq 'Roman') {
      $string .= Roman::Roman($self->{ad});
    }
    elsif ($params{die} eq 'roman') {
      $string .= Roman::roman($self->{ad});
    }
    else {
      $string .= $self->{ad};
    }
    $string .= " ";
  }


  if ($params{fday} eq 'abbrev') {
    $string .= $FD_SHORT[$self->{base}]." ";
  }
  else {
    $string .= ($self->{ad} == 0) ? "$FD_FD[$self->{base}] "
      : "$FD[$self->{base}] ";
  }

  if ($params{mons} eq 'abbrev') {
    $string .= "$MONS_SHORT[$self->{mons}] ";
  }
  else {
    $string .= ($self->{ad} == 0) ? $MONS_FD[$self->{mons}] : $MONS[$self->{mons}];
    $string .= " ";
  }

  if ($params{annus} eq 'Roman') {
    $string .= Roman::Roman($self->{annus});
  }
  elsif ($params{annus} eq 'roman') {
    $string .= Roman::roman($self->{annus});
  }
  else {
    $string .= $self->{annus};
  }

  if ($params{auc} eq 'abbrev') {
    $string .= " AUC";
  }
  else {
    $string .= " ab Urbe Condida";
  }

  return $string;
}




#private subroutines

# _parse_roman: takes a roman date string and returns a reference to
# an hash describing the corresponding roman date and ready to be
# blessed.

my $roman_date_regexp = qr/^(?:(b6|pd|\d+)\s+)?(kal|non|id)\s+(\d+)\s+(\d+)/i;

sub _parse_roman {
  my $datestring = shift;

  my %result = (bis => 0);
  unless ($datestring =~ /$roman_date_regexp/) {
    croak "Malformed roman date string: $datestring";
  }

  my ($prefix,$base,$mons,$annus) = map lc,($1,$2,$3,$4);

  if (!$prefix) {
    $result{ad} = 1;
  }
  elsif ($prefix eq 'pd') {
    $result{ad} = 2;
  }
  elsif ($prefix eq 'b6') {
    $result{ad} = 6;
    $result{bis} = 1;
  }
  else {
    $result{ad} = $prefix;
  }

  $result{base} = ($base eq 'kal') ? Kalendae :
    (($base eq 'non') ? Nonae : Idibus);

  $result{mons} = $mons;
  $result{annus} = $annus;

  #sanity checks
  _check_roman(\%result) || carp "Malformed Roman date hash";

  return \%result;

}

# _check_roman: given a reference to an hash supposed to define a date
# in the Roman format (such the one returned by _parse_roman) it
# returns true if and only if the hash repesents a correct date.

sub _check_roman {
  my $rhr = shift;

  return undef unless $rhr->{base} >= Kalendae and $rhr->{base} <= Idibus;
  return undef unless ($rhr->{mons} >= 1) and ($rhr->{mons} <= 12);
  return undef if $rhr->{bis} and ($rhr->{base} != Kalendae or
				   $rhr->{mons} != 3 or
				   ! _leap($rhr->{annus},'roman'));
  return undef unless $rhr->{ad} <= _days_before($rhr->{base},$rhr->{mons});
  return 1;
}


# _parse_ical: takes a ical date string and returns a reference to
# an hash describing the corresponding date.

my $ical_date_regexp = qr/^(-?\d+)(\d\d)(\d\d)(?:$|T)/;

sub _parse_ical {
  my $datestring = shift;
  my %result = ();

  unless (@result{'year','month','day'} = map {$_+0} ($datestring =~ /$ical_date_regexp/)) {
    croak "Malformed ical date string: $datestring";
  }

  #sanity check
  _check_ical(\%result) || carp "Malformed ical date hash";

  return \%result;
}

# _check_ical: given a reference to an hash supposed to define a date
# in the ical format (such the one returned by _parse_ical) it
# returns true if and only if the hash repesents a correct date.
sub _check_ical {
  my $ihr = shift;

  return undef if ($ihr->{month} < 1 or
		   $ihr->{month} > 12);

  return undef if ($ihr->{day} <= 0  or
		   $ihr->{day} > 31);

  return undef if ($ihr->{day} > 30 and
		   ($ihr->{month} == 4 or $ihr->{month} == 6 or
		    $ihr->{month} == 9 or $ihr->{month} == 11));

  return undef if ($ihr->{month} == 2 and
		   ($ihr->{day} > 29 or
		    ($ihr->{day} > 28 and !_leap($ihr->{year}))));
  return 1;
}


# _normalize_month: Given a month number, 'normalize' it, i.e. replace
# it in the 1..12 interval.

sub _normalize_month {
  use integer;

  my ($mons) = @_;
  my $result = (($_[0] - 1) % 12) + 1;

  unless (wantarray()) {
    return $result;
  }

  return ($result,$mons/12);
}

sub _normalize_roman_date {
  my $rhr = shift;

#   print "_normalize_roman_date({",
#     join(",", map {"$_ => $rhr->{$_}"} keys %{$rhr}),
#       "})\n";

  my ($mons,$deltay) = _normalize_month($rhr->{mons});

  $rhr->{mons} = $mons;
  $rhr->{annus} += $deltay;
  $rhr->{ad}++ if $rhr->{bis} or (($rhr->{mons} == 3) and
				  ($rhr->{base} == Kalendae) and
				  ($rhr->{ad} > 6) and
				  (_leap($rhr->{annus},'roman')));
  $rhr->{bis} = 0;

#  print "After initialization:\n";
#  print "{",join(",", map {"$_ => $rhr->{$_}"} keys %{$rhr}),"}\n";

  while (($rhr->{ad} > _days_before($rhr->{base},$rhr->{mons}) - 1) or
	 (($rhr->{base} == Kalendae) and
	  ($rhr->{mons} == 3) and
	  _leap($rhr->{annus},'roman') and
	  ($rhr->{ad} > 17))) {
    #decrement $rhr->{ad} and set mons and annus accordingly
#    print "decrementing\n";

    $rhr->{ad} -= _days_before($rhr->{base},$rhr->{mons});
    $rhr->{ad}-- if (($rhr->{base} == Kalendae) and
		     ($rhr->{mons} == 3) and
		     _leap($rhr->{annus},'roman'));


    $rhr->{base} = ($rhr->{base} - 1) % 3;
    $rhr->{mons}-- if $rhr->{base} == Idibus;

    if ($rhr->{mons} == 0) {
      $rhr->{mons} = 12;
      $rhr->{annus}--;
    }
  }

  while ($rhr->{ad} < 1) {
#    print "Incrementing\n";
    #increment $rhr->{ad} and set mons and annus accordingly
    $rhr->{base} = ($rhr->{base} + 1) % 3;

    $rhr->{mons}++ if $rhr->{base} == Kalendae;

    if ($rhr->{mons} == 13) {
      $rhr->{mons} = 1;
      $rhr->{annus}++;
    }

    $rhr->{ad} += _days_before($rhr->{base},$rhr->{mons});

     $rhr->{ad}++ if (($rhr->{base} == Kalendae) and
 		     ($rhr->{mons} == 3) and
		     _leap($rhr->{annus},'roman'));
  }

  if (_leap($rhr->{annus},'roman') and
      ($rhr->{mons} == 3) and
      ($rhr->{base} == Kalendae) and
      ($rhr->{ad} > 6)) {
    $rhr->{bis} = 1 if $rhr->{ad} == 7;
    $rhr->{ad}--;
  }

  return $rhr;

}

# _days_before: Given a fixed day and a month returns the number of
# days existing in that month before that given fixed day. Reamrks
# that this is always the same, unregarding if the year is leap or
# not.

sub _days_before {
  my ($base,$month) = @_;
  return 8 if $base == Idibus;

  return _fixed_day(Nonae,$month) -1 if $base == Nonae;

  #Kalendas
  return _monthlength($month - 1) - _fixed_day(Idibus,$month - 1) + 1;
}

# _fixed_day: Given a fixed day and a month returns the 'position' of
# the fixed day in the month. Month is normalized.

sub _fixed_day {
  my ($fd,$mons) = @_;

  return 1 if $fd == Kalendae;

  $mons = _normalize_month($mons);

  if ($fd == Idibus) {
    return 15 if ($mons == 3) or ($mons == 5) or
      ($mons == 7) or ($mons == 10);
    return 13;
  }
  else {
    return 7 if ($mons == 3) or ($mons == 5) or
	($mons == 7) or ($mons == 10);
    return 5;
  }
}

# _monthlength: given a month number returns the length of the month.
#
# Notes:
#
# 1. for February we always returns 28.
#
# 2. month is normalized.

sub _monthlength {
  my $month = _normalize_month(shift);

  return 28 if $month == 2;
  return 30 if ($month == 4 or $month == 6 or $month == 9 or $month == 11);
  return 31;
}

# _leap: is a given year leap?
sub _leap {
  my $year = shift;
  my $format = shift || 'christian';

  $year -= 753 if $format eq 'roman';

  return 0 if ($year % 4);
  return 1 if ($year <= LastJulian) or ($year % 100);
  return 0 if ($year  % 400);
  return 1;
}


# _ical_to_roman: Given a reference to an hash representing a date in
# the ical format (as returned by the _parse_ical sub) it returns a
# reference to an hash containing the corresponding Roman date, as
# returned by the _parse_roman sub.

sub _ical_to_roman {
  my $ihr = shift; #ical hash ref
  my %result = (bis => 0);
  my $fd;

  if ($ihr->{day} == 1) {
    $result{ad} = 1;
    $result{base} = Kalendae;
    $result{mons} = $ihr->{month};
    $result{annus} = $ihr->{year};
  }
  elsif ($ihr->{day} <= ($fd = _fixed_day(Nonae,$ihr->{month}))) {
    $result{ad} = $fd - $ihr->{day} + 1;
    $result{base} = Nonae;
    $result{mons} = $ihr->{month};
    $result{annus} = $ihr->{year};
  }
  elsif ($ihr->{day} <= ($fd = _fixed_day(Idibus,$ihr->{month}))) {
    $result{ad} = $fd - $ihr->{day} + 1;
    $result{base} = Idibus;
    $result{mons} = $ihr->{month};
    $result{annus} = $ihr->{year};
  }
  else {
    $result{base} = Kalendae;
    $result{mons} = ($ihr->{month} < 12) ? $ihr->{month} + 1 : 1;
    $result{annus} = ($result{mons} == 1) ? $ihr->{year} + 1 : $ihr->{year};

    if ($result{mons} != 3 or !_leap($ihr->{year}) or ($ihr->{day} < 24)) {
      $result{ad} = _monthlength($ihr->{month}) - $ihr->{day} + 2;
    }
    elsif ($ihr->{day} == 24) {
      $result{bis} = 1;
      $result{ad} = 6;
    }
    else {
      $result{ad} = 31 - $ihr->{day};
    }
  }

  $result{annus} += 753;

  return \%result;
}

# _roman_to_ical:
sub _roman_to_ical {
  my $rhr = shift; # roman hash ref
  my %result = ();


  $result{year} = (($rhr->{mons} == 1) and
                   ($rhr->{base} == Kalendae) and
		   ($rhr->{ad} > 1)) ? $rhr->{annus} - 1 : $rhr->{annus};

  $result{year} -= 753;

  $result{month} = (($rhr->{base} != Kalendae) or ($rhr->{ad} == 1)) ?
    $rhr->{mons} :
      (($rhr->{mons} > 1) ? $rhr->{mons} - 1 : 12);

  if ($rhr->{base} == Kalendae) {
    if ($rhr->{ad} == 1) {
      $result{day} = 1;
    }
    else {
      $result{day} = _monthlength($result{month}) - $rhr->{ad} + 2;
      if ($result{month} == 2 and
	  ($rhr->{ad} < 6 or ($rhr->{ad} == 6 and !$rhr->{bis})) and
	  (_leap($result{year}))) {
	$result{day}++;
      }
    }
  }
  else {
    $result{day} = _fixed_day($rhr->{base},$rhr->{mons}) - $rhr->{ad} + 1;
  }

  return \%result;
}
1;
__END__