File Coverage

blib/lib/Date/Convert.pm

Criterion	Covered	Total	%
statement	245	257	95.3
branch	51	70	72.8
condition	44	84	52.3
subroutine	32	33	96.9
pod	3	5	60.0
total	375	449	83.5

package Date::Convert;

use Carp;

$VERSION="0.16";


$VERSION=$VERSION; # to make -w happy.  :)

# methods that every class should have:
# initialize, day, date, date_string

# methods that are recommended if applicable:
# year, month, day, is_leap


$BEGINNING=1721426; # 1 Jan 1 in the Gregorian calendar, although technically,
                    # the Gregorian calendar didn't exist at the time.
$VERSION_TODAY=2450522; # today in JDN, when I wrote this.


sub new { # straight out of the perlobj manpage:
    my $class = shift;
    my $self = {};
    bless $self, $class;
    $self->initialize(@_);
    return $self;
}


sub initialize {
    my $self = shift;
    my $val  = shift || $VERSION_TODAY;
    carp "Date::Convert is not reliable before Absolute $BEGINNING"
	if $val < $BEGINNING;
    $$self{absol}=$val;
}



sub clean {
    my $self  = shift;
    my $key;
    foreach $key (keys %$self) {
	delete $$self{$key} unless $key eq 'absol';
    }
}



sub convert {
    my $class = shift;
    my $self  = shift;
    $self->clean;
    bless $self, $class;
}




sub absol {
    my $self = shift;
    return $$self{absol};
}





package Date::Convert::Gregorian;

use Carp;
@ISA = qw ( Date::Convert );

$GREG_BEGINNING=1721426; # 1 Jan 1 in the Gregorian calendar, although
                    # technically, the Gregorian calendar didn't exist at
                    # the time.
@MONTHS_SHORT  = qw ( nil Jan Feb Mar Apr May Jun July Aug Sep Oct Nov Dec );
@MONTH_ENDS    = qw ( 0   31  59  90  120 151 181  212 243 273 304 334 365 );
@LEAP_ENDS     = qw ( 0   31  60  91  121 152 182  213 244 274 305 335 366 );

$NORMAL_YEAR    = 365;
$LEAP_YEAR      = $NORMAL_YEAR + 1;
$FOUR_YEARS     = 4 * $NORMAL_YEAR + 1; # one leap year every four years
$CENTURY        = 25 * $FOUR_YEARS - 1; # centuries aren't leap years . . .
$FOUR_CENTURIES = 4 * $CENTURY + 1;     # . . .except every four centuries.


sub year {
    my $self = shift;
    return $$self{year} if exists $$self{year}; # no point recalculating.
    my $days;
    my $year;
    # note:  years and days are initially days *before* today, rather than
    # today's date.  This is because of fenceposts.  :)
    $days =  $$self{absol} - $GREG_BEGINNING;
    if (($days+1) % $FOUR_CENTURIES) { # normal case
	$year =  int ($days / $FOUR_CENTURIES) * 400;
	$days %= $FOUR_CENTURIES;
	$year += int ($days / $CENTURY) * 100; # years.
	$days %= $CENTURY;
	$year += int ($days / $FOUR_YEARS) * 4;
	$days %= $FOUR_YEARS;
	if (($days+1) % $FOUR_YEARS) {
	    $year += int ($days / $NORMAL_YEAR); # fence post from year 1
	    $days %= $NORMAL_YEAR;
	    $days += 1; # today
	    $year += 1;
	} else {
	    $year += int ($days / $NORMAL_YEAR + 1) - 1;
	    $days =  $LEAP_YEAR;
	}
    } else { # exact four century boundary.  Uh oh. . .
	$year =  int ($days / $FOUR_CENTURIES + 1) * 400;
	$days =  $LEAP_YEAR; # correction for later.
    }
    $$self{year}=$year;
    $$self{days_into_year}=$days;
    return $year;
}




sub is_leap {
    my $self = shift;
    my $year = shift || $self->year; # so is_leap can be static or method
    return 0 if (($year %4) || (($year % 400) && !($year % 100)));
    return 1;
}


sub month {
    my $self = shift;
    return $$self{month} if exists $$self{month};
    my $year = $self -> year;
    my $days = $$self{days_into_year};
    my $MONTH_REF = \@MONTH_ENDS;
    $MONTH_REF = \@LEAP_ENDS if ($self->is_leap);
    my $month= 13 - (grep {$days <= $_} @$MONTH_REF);
    $$self{month} = $month;
    $$self{day}   = $days-@$MONTH_REF[$month-1];
    return $month;
}



sub day {
    my $self = shift;
    return $$self{day} if exists $$self{day};
    $self->month; # calculates day as a side-effect
    return $$self{day};
}



sub date {
    my $self = shift;
    return ($self->year, $self->month, $self->day);
}



sub date_string {
    my $self  = shift;
    my $year  = $self->year;
    my $month = $self->month;
    my $day   = $self->day;
    return "$year $MONTHS_SHORT[$month] $day";
}




sub initialize {
    my $self = shift;
    my $year = shift || return Date::Convert::initialize;
    my $month= shift ||
	croak "Date::Convert::Gregorian::initialize needs more args";
    my $day  = shift ||
	croak "Date::Convert::Gregorian::initialize needs more args";
    warn "These routines don't work well for Gregorian before year 1"
	if $year<1;
    my $absol = $GREG_BEGINNING;
    $$self{'year'} = $year;
    $$self{'month'}= $month;
    $$self{'day'}  = $day;
    my $is_leap = is_leap Date::Convert::Gregorian $year;
    $year --;  #get years *before* this year.  Makes math easier.  :)
    # first, convert year into days. . .
    $absol += int($year/400)*$FOUR_CENTURIES;
    $year  %= 400;
    $absol += int($year/100)*$CENTURY;
    $year  %= 100;
    $absol += int($year/4)*$FOUR_YEARS;
    $year  %= 4;
    $absol += $year*$NORMAL_YEAR;
    # now, month into days.
    croak "month number $month out of range"
	if $month < 1 || $month >12;
    my $MONTH_REF=\@MONTH_ENDS;
    $MONTH_REF=\@LEAP_ENDS if $is_leap;
    croak "day number $day out of range for month $month"
	if $day<1 || $day+$$MONTH_REF[$month-1]>$$MONTH_REF[$month];
    $absol += $day+$$MONTH_REF[$month-1]-1;
    $$self{absol}=$absol;
}





package Date::Convert::Hebrew;
use Carp;
@ISA = qw ( Date::Convert );

$HEBREW_BEGINNING = 347996; # 1 Tishri 1

                                # @MONTH       = (29,   12, 793);
@NORMAL_YEAR = (354,   8, 876); # &part_mult(12,  @MONTH);
@LEAP_YEAR   = (383,  21, 589); # &part_mult(13,  @MONTH);
@CYCLE_YEARS = (6939, 16, 595); # &part_mult(235, @MONTH);
@FIRST_MOLAD = ( 1,  5, 204);
@LEAP_CYCLE  = qw ( 3 6 8 11 14 17 0 );

@MONTHS = ('Nissan', 'Iyyar', 'Sivan', 'Tammuz', 'Av',
	'Elul', 'Tishrei', 'Cheshvan', 'Kislev', 'Teves',
	'Shevat', 'Adar', 'Adar II' );

# In the Hebrew calendar, the year starts in the seventh month, there can
# be a leap month, and there are two months with a variable number of days.
# Rather than calculate do the actual math, let's set up lookup tables based
# on year length.  :)

%MONTH_START=
    ('353' => [177, 207, 236, 266, 295, 325, 1, 31, 60, 89, 118, 148],
     '354' => [178, 208, 237, 267, 296, 326, 1, 31, 60, 90, 119, 149],
     '355' => [179, 209, 238, 268, 297, 327, 1, 31, 61, 91, 120, 150],
     '383' => [207, 237, 266, 296, 325, 355, 1, 31, 60, 89, 118, 148, 178],
     '384' => [208, 238, 267, 297, 326, 356, 1, 31, 60, 90, 119, 149, 179],
     '385' => [209, 239, 268, 298, 327, 357, 1, 31, 61, 91, 120, 150, 180]);

sub is_leap {
    my $self = shift;
    my $year = shift;
    $year=$self->year if ! defined $year;
    my $mod=$year % 19;
    return scalar(grep {$_==$mod} @LEAP_CYCLE);
}


sub initialize {
    my $self = shift;
    my $year = shift || return Date::Convert::initialize;
    my $month= shift ||
	croak "Date::Convert::Hebrew::initialize needs more args";
    my $day  = shift ||
	croak "Date::Convert::Hebrew::initialize needs more args";
    warn "These routines don't work well for Hebrew before year 1"
	if $year<1;
    $$self{year}=$year; $$self{$month}=$month; $$self{day}=$day;
    my $rosh=$self->rosh;
    my $year_length=(rosh Date::Convert::Hebrew ($year+1))-$rosh;
    carp "Impossible year length" unless defined $MONTH_START{$year_length};
    my $months_ref=$MONTH_START{$year_length};
    my $days=$$months_ref[$month-1]+$day-1;
    $$self{days}=$days;
    my $absol=$rosh+$days-1;
    $$self{absol}=$absol;
}



sub year {
    my $self = shift;
    return $$self{year} if exists $$self{year};
    my $days=$$self{absol};
    my $year=int($days/365)-3*365; # just an initial guess, but a good one.
    warn "Date::Convert::Hebrew isn't reliable before the beginning of\n".
	"\tthe Hebrew calendar" if $days < $HEBREW_BEGINNING;
    $year++ while rosh Date::Convert::Hebrew ($year+1)<=$days;
    $$self{year}=$year;
    $$self{days}=$days-(rosh Date::Convert::Hebrew $year)+1;
    return $year;
}


sub month {
    my $self = shift;
    return $$self{month} if exists $$self{month};
    my $year_length=
	rosh Date::Convert::Hebrew ($self->year+1) -
	    rosh Date::Convert::Hebrew $self->year;
    carp "Impossible year length" unless defined $MONTH_START{$year_length};
    my $months_ref=$MONTH_START{$year_length};
    my $days=$$self{days};
    my ($n, $month)=(1);
    my $day=31; # 31 is too large.  Good.  :)
    grep {if ($days>=$_ && $days-$_<$day)
	  {$day=$days-$_+1;$month=$n}
	  $n++} @$months_ref;
    $$self{month}=$month;
    $$self{day}=$day;
    return $month;
}




sub day {
    my $self = shift;
    return $$self{day} if exists $$self{day};
    $self->month; # calculates day as a side-effect.
    return $$self{day};
}


sub date {
    my $self = shift;
    return ($self->year, $self->month, $self->day);
}


sub date_string {
    my $self=shift;
    return $self->year." $MONTHS[$self->month-1] ".$self->day;
}


sub rosh {
    my $self = shift;
    my $year = shift || $self->year;
    my @molad= @FIRST_MOLAD;
    @molad = &part_add(@molad, &part_mult(int(($year-1)/19),@CYCLE_YEARS));
    my $offset=($year-1)%19;
    my $num_leaps=(grep {$_<=$offset} @LEAP_CYCLE) - 1;
    @molad = &part_add(@molad, &part_mult($num_leaps, @LEAP_YEAR));
    @molad = &part_add(@molad, &part_mult($offset-$num_leaps,
					      @NORMAL_YEAR));
    my $day=shift @molad;
    my $hour=shift @molad;
    my $part= shift @molad;
    my $guess=$day%7;
    if (($hour>=18)                              # molad zoken al tidrosh
	or
	((is_leap Date::Convert::Hebrew $year) and   # gatrad b'shanah
	 ($guess==2) and                         #      p'shutah g'rosh
	 (($hour>9)or($hour==9 && $part>=204)))
        or
        ((is_leap Date::Convert::Hebrew $year-1) and # b'to takfat achar
	 ($guess==1) and                         #      ha'ibur akor
	 (($hour>15)or($hour==15&&$part>589)))){ #      mi-lishorsh
	$guess++;
	$day++;
    }
    $guess%=7;
    if (scalar(grep {$guess==$_} (0, 3, 5))) {   # lo ad"o rosh
	$guess++;
	$day++;
    }
    $guess%=7;
    return ($day+1+$HEBREW_BEGINNING);
}




sub part_add {
    my ($day1, $hour1, $part1)=(shift, shift, shift);
    my ($day2, $hour2, $part2)=(shift, shift, shift);
    my $part=$part1+$part2;
    my $hour=$hour1+$hour2;
    my $day =$day1 +$day2;
    if ($part>1080) {
	$part-=1080;
	$hour++;
    }
    if ($hour>24) {
	$hour-=24;
	$day++;
    }
    return ($day, $hour, $part);
}


sub part_mult {
    my $scalar = shift;
    my $day= ((0+ shift) * $scalar);
    my $hour=((0+ shift) * $scalar);
    my $part=((0+ shift) * $scalar);
    my $tmp;
    if ($part>1080) {
	$tmp=int($part/1080);
	$part%=1080;
	$hour+=$tmp;
    }
    if ($hour>24) {
	$tmp=int($hour/24);
	$hour%=24;
	$day+=$tmp;
    }
    return($day, $hour, $part);
}


# Here's a quickie, based on the base class.

package Date::Convert::Absolute;
use Date::Convert;
@ISA = qw ( Date::Convert );

sub initialize {
    return Date::Convert::initialize @_;
}


sub date {
    my $self=shift;
    return $$self{'absol'};
}

sub date_string {
    my $self=shift;
    my $date=$self->date; # just a scalar
    return "$date";
}



# Julian is kinda like Gregorian, but the leap year rule is easier.

package Date::Convert::Julian;

use Carp;
@ISA = qw ( Date::Convert::Gregorian Date::Convert );
# we steal useful constants from Gregorian
$JULIAN_BEGINNING=$Date::Convert::Gregorian::GREG_BEGINNING - 2;
$NORMAL_YEAR=     $Date::Convert::Gregorian::NORMAL_YEAR;
$LEAP_YEAR=       $Date::Convert::Gregorian::LEAP_YEAR;
$FOUR_YEARS=      $Date::Convert::Gregorian::FOUR_YEARS;

@MONTH_ENDS    = @Date::Convert::Gregorian::MONTH_ENDS;
@LEAP_ENDS     = @Date::Convert::Gregorian::LEAP_ENDS;

sub initialize {
    my $self=shift ||
	croak "Date::Convert::Julian::initialize needs more args";
    my $year=shift || return Date::Convert::initialize;
    my $month=shift ||
	croak "Date::Convert::Julian::initialize needs more args";
    my $day=shift ||
	croak "Date::Convert::Julian::initialize needs more args";

    warn "These routines don't work well for Julian before year 1"
	if $year<1;
    my $absol = $JULIAN_BEGINNING;
    $$self{'year'} = $year;
    $$self{'month'}= $month;
    $$self{'day'}  = $day;
    my $is_leap = is_leap Date::Convert::Gregorian $year;
    $year --;  #get years *before* this year.  Makes math easier.  :)
    # first, convert year into days. . .
    $absol += int($year/4)*$FOUR_YEARS;
    $year  %= 4;
    $absol += $year*$NORMAL_YEAR;
    # now, month into days.
    croak "month number $month out of range"
	if $month < 1 || $month >12;
    my $MONTH_REF=\@MONTH_ENDS;
    $MONTH_REF=\@LEAP_ENDS if $is_leap;
    croak "day number $day out of range for month $month"
	if $day<1 || $day+$$MONTH_REF[$month-1]>$$MONTH_REF[$month];
    $absol += $day+$$MONTH_REF[$month-1]-1;
    $$self{absol}=$absol;
}


sub year {
    my $self = shift;
    return $$self{year} if exists $$self{year};
    my ($days, $year);
    # To avoid fenceposts, year and days are initially *before* today.
    # the next code is stolen directly form the ::Gregorian code.  Good thing
    # I'm the one who wrote it. . .
    $days=$$self{absol}-$JULIAN_BEGINNING;
    $year =  int ($days / $FOUR_YEARS) * 4;
    $days %= $FOUR_YEARS;
    if (($days+1) % $FOUR_YEARS) { # Not on a four-year boundary.  Good!
	$year += int ($days / $NORMAL_YEAR); # fence post from year 1
	$days %= $NORMAL_YEAR;
	$days += 1; # today
	$year += 1;
    } else {
	$year += int ($days / $NORMAL_YEAR + 1) - 1;
	$days =  $LEAP_YEAR;
    }
    $$self{year}=$year;
    $$self{days_into_year}=$days;
    return $year;
}



sub is_leap {
    my $self = shift;
    my $year = shift || $self->year; # so is_leap can be static or method
    return 0 if ($year %4);
    return 1;
}


# OK, we're done.  Everything else just gets inherited from Gregorian.


1;

__END__