File Coverage

blib/lib/Date/Gregorian.pm

Criterion	Covered	Total	%
statement	396	403	98.2
branch	71	78	91.0
condition	93	106	87.7
subroutine	87	87	100.0
pod	33	33	100.0
total	680	707	96.1

# Copyright (c) 1999-2007 Martin Becker.  All rights reserved.
# This package is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# $Id: Gregorian.pm,v 1.15 2007/06/19 12:10:58 martin Stab $

package Date::Gregorian;

use strict;
use integer;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
require Exporter;

@ISA = qw(Exporter);
%EXPORT_TAGS = (
    'weekdays' => [qw(
	    MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY SUNDAY
	)],
    'months' => [qw(
	    JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY
	    AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER
	)],
);
@EXPORT_OK = map @{$_}, values %EXPORT_TAGS;

$VERSION = '0.12';

# ----- object definition -----

# Date::Gregorian=ARRAY(...)

# .......... index ..........	# .......... value ..........
use constant F_DAYNO   => 0;	# continuos day number, "March ...th, 1 BC"
use constant F_TR_DATE => 1;	# first Gregorian date in dayno format
use constant F_TR_EYR  => 2;	# first Gregorian easter year
use constant F_YMD     => 3;	# [year, month, day] (on demand, memoized)
use constant F_YDYW    => 4;	# [yearday, year, week] (on demand, memoized)
use constant F_SEC_NS  => 5;	# [seconds, nanoseconds] (optional)
use constant NFIELDS   => 6;

# ----- other constants -----

use constant MONDAY    => 0;
use constant TUESDAY   => 1;
use constant WEDNESDAY => 2;
use constant THURSDAY  => 3;
use constant FRIDAY    => 4;
use constant SATURDAY  => 5;
use constant SUNDAY    => 6;

use constant JANUARY   =>  1;
use constant FEBRUARY  =>  2;
use constant MARCH     =>  3;
use constant APRIL     =>  4;
use constant MAY       =>  5;
use constant JUNE      =>  6;
use constant JULY      =>  7;
use constant AUGUST    =>  8;
use constant SEPTEMBER =>  9;
use constant OCTOBER   => 10;
use constant NOVEMBER  => 11;
use constant DECEMBER  => 12;

# ----- predefined private variables -----

my @m2d      = map +($_ * 153 + 2) / 5, (0..11);
my $epoch    = _ymd2dayno( 1970, 1, 1, 1, 1);
my @defaults = (
    $epoch,				# F_DAYNO
    _ymd2dayno(1582, 10, 15, 1, 1),	# F_TR_DATE
    1583,				# F_TR_EYR
    undef,				# F_YMD
    undef,				# F_YDYW
    undef,				# F_SEC_NS
);
my ($gmt_epoch, $gmt_correction) = _init_gmt();
my $datetime_epoch = 307;
my $default_sec_ns = [0, 0];
my %JG = ('J' => 0, 'G' => 1);
my $localtime_offset = 0;

# ----- private functions -----

# ($div, $mod) = _divmod($numerator, $denominator)
#
sub _divmod {
    no integer;				# use well defined percent operator
    my $mod = $_[0] % $_[1];
    return (($_[0] - $mod) / $_[1], $mod);
}

# $dayno = _ymd2dayno($year, $month, $day, $tr_date, $fixed)
# fixed == 1: tr_date == 0: force Julian, tr_date == 1: force Gregorian
# fixed == boolean false: normal operation
#
sub _ymd2dayno {
    my ($y, $m, $d, $s, $fixed) = @_;

    if    (15 <= $m) { $m -= 3;      $y += $m / 12; $m %= 12;          }
    elsif ( 3 <= $m) { $m -= 3;                                        }
    elsif (-9 <= $m) { $m += 9;      $y --;                            }
    else             { $m = 14 - $m; $y -= $m / 12; $m = 11 - $m % 12; }

    $d += $m2d[$m] + $y * 365 + ($y >> 2) - 1;
    if (!$fixed && $s <= $d || $fixed && $s) {
	$y = 0 <= $y? $y / 100: -((99 - $y) / 100);
	$d -= $y - ($y >> 2) - 2;
    }
    return $d;
}

# ($year, $month, $day) = _dayno2ymd($dayno, $tr_date)
#
sub _dayno2ymd {
    my ($n, $s) = @_;
    my ($d, $m, $y);
    my $c;
    if ($s <= $n) {
	($c, $n) = _divmod($n - 2, 146097);
	$c *= 400;
	$n += (($n << 2) + 3) / 146097;
    }
    else {
	($c, $n) = _divmod($n, 1461);
	$c <<= 2;
    }
    $y = (($n << 2) + 3) / 1461;
    $n = ($n - $y * 365 - ($y >> 2)) * 5 + 2;
    $m = $n / 153 + 3;
    $d = $n % 153 / 5 + 1;
    $y ++, $m -= 12 if 12 < $m;
    return ($c + $y, $m, $d);
}

# ($dayno, $ymd) = _easter($year, $tr_date, $tr_eyr)
#
sub _easter {
    my ($y, $s, $e) = @_;
    my $m = 3;
    my $d;
    my $n = $y * 365 + ($y >> 2);
    if ($e <= $y) {
	my $g = 0 <= $y? $y / 100: -((99 - $y) / 100);
	$n -= $g - ($g >> 2) - 2;
	{ no integer; $g %= 3000 };
	my $h = 15 + $g - (($g << 3) + 13) / 25 - ($g >> 2);
	$g = do { no integer; $y % 19 };
	$d = ($g * 19 + $h) % 30;
	--$d if 28 <= $d && (28 < $d || 11 <= $g);
    }
    else {
	$d = do { no integer; ($y % 19 * 19 + 15) % 30 };
    }
    $d += do { no integer; 28 - ($n + $d) % 7 };
    $n += $d - 1;
    $d -= 31, $m ++ if 31 < $d;
    return ($n, ($s <= $n xor $e <= $y)? undef: [$y, $m, $d]);
}

# $dayno = _dec31dayno($year, $tr_date)
# calculate day number of last day in year (usually December 31)
#
sub _dec31dayno {
    my ($y, $s) = @_;

    my $n = 306 + $y * 365 + ($y >> 2) - 1;
    if ($s <= $n) {
	$y = 0 <= $y? $y / 100: -((99 - $y) / 100);
	$n -= $y - ($y >> 2) - 2;
	if ($n < $s) {
	    return $s-1;
	}
    }
    return $n;
}

# $ydyw = _ydyw($dayno, $tr_date, $year)
#
sub _ydyw {
    my ($n, $s, $y) = @_;
    my $base = _dec31dayno($y-1, $s);
    my $yd = $n - $base;
    $base += 4;
    { no integer; $base -= $base % 7 };
    if ($n < $base) {
	$y --;
	$base = _dec31dayno($y-1, $s) + 4;
	{ no integer; $base -= $base % 7 };
    }
    else {
	my $limit = _dec31dayno($y, $s) + 4;
	{ no integer; $limit -= $limit % 7 };
	if ($limit <= $n) {
	    $base = $limit;
	    $y ++;
	}
    }
    my $yw = ($n - $base) / 7 + 1;
    return [$yd, $y, $yw];
}

# ($gmt_epoch, $gmt_correction) = _init_gmt()
#
sub _init_gmt {
    my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(0);
    return (
	_ymd2dayno(1900 + $year, 1 + $mon, $mday, 1, 1),
	($hour*60 + $min)*60 + $sec
    );
}

# ----- public methods -----

sub new {
    my $class = $_[0];
    my Date::Gregorian $self;
    if (ref $class) {			# called as obj method: clone it
	$self = bless [@{$class}], ref($class);
    }
    else {				# called as class method: create
	$self = bless [@defaults], $class;
    }
    return $self;
}

sub configure {
    my Date::Gregorian $self = shift;
    my ($y, $m, $d, $e) = @_;
    @{$self}[F_TR_DATE, F_YMD, F_YDYW] =
	( _ymd2dayno($y, $m, $d, 1, 1), undef, undef );
    $self->[F_TR_EYR] = $e if defined $e;
    return $self;
}

sub is_gregorian {
    my Date::Gregorian $self = $_[0];
    return $self->[F_TR_DATE] <= $self->[F_DAYNO];
}

sub set_date {
    my Date::Gregorian ($self, $ref) = @_;
    @{$self}[F_DAYNO, F_YMD, F_YDYW] = ( $ref->[F_DAYNO], undef, undef );
    return $self;
}

sub set_ymd {
    my Date::Gregorian $self = shift;
    my ($y, $m, $d) = @_;
    @{$self}[F_DAYNO, F_YMD, F_YDYW] =
	( _ymd2dayno($y, $m, $d, $self->[F_TR_DATE]), undef, undef );
    return $self;
}

sub check_ymd {
    my Date::Gregorian $self = shift;
    my ($y, $m, $d) = @_;
    my ($dayno, $yy, $mm, $dd);
    if (defined($d) && 1 <= $d && $d <= 31 &&
	defined($m) && 1 <= $m && $m <= 12 &&
	defined($y) && -1469871 <= $y && $y <= 5879489
    ) {
	$dayno = _ymd2dayno($y, $m, $d, $self->[F_TR_DATE]);
	($yy, $mm, $dd) = _dayno2ymd($dayno, $self->[F_TR_DATE]);
	if ($dd == $d && $mm == $m && $yy == $y) {
	    @{$self}[F_DAYNO, F_YMD, F_YDYW] =
		( $dayno, [$yy, $mm, $dd], undef );
	    return $self;
	}
    }
    return undef;
}

sub get_ymd {
    my Date::Gregorian $self = $_[0];
    my $ymd = $self->[F_YMD] ||=
	[ _dayno2ymd($self->[F_DAYNO], $self->[F_TR_DATE]) ];
    return @{$ymd};
}

sub get_weekday {
    no integer;
    my Date::Gregorian $self = $_[0];
    return $self->[F_DAYNO] % 7;
}

sub set_yd {
    my Date::Gregorian $self = shift;
    my ($y, $d) = @_;
    my $n = _dec31dayno($y-1, $self->[F_TR_DATE]) + $d;
    @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($n, undef, undef);
    return $self;
}

sub set_ywd {
    no integer;
    my Date::Gregorian $self = shift;
    my ($y, $w, $d) = @_;
    my $n = _dec31dayno($y-1, $self->[F_TR_DATE]) - 3;
    $n += $w * 7 + $d - $n % 7;
    @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($n, undef, undef);
    return $self;
}

sub check_ywd {
    no integer;
    my Date::Gregorian $self = shift;
    my ($y, $w, $d) = @_;
    if (defined($d) && 0 <= $d && $d <= 6 &&
	defined($w) && 1 <= $w && $w <= 53 &&
	defined($y) && -1469871 <= $y && $y <= 5879489
    ) {
	my $n = _dec31dayno($y-1, $self->[F_TR_DATE]) - 3;
	$n += $w * 7 + $d - $n % 7;
	my $ymd = [_dayno2ymd($n, $self->[F_TR_DATE])];
	my $ydyw = _ydyw($n, $self->[F_TR_DATE], $ymd->[0]);
	if ($ydyw->[1] == $y && $ydyw->[2] == $w) {
	    @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($n, $ymd, $ydyw);
	    return $self;
	}
    }
    return undef;
}

sub get_yd {
    my Date::Gregorian $self = $_[0];
    my ($y, $m, $d) = $self->get_ymd;
    return ($y, $d) if 1 == $m;
    my $ydyw = $self->[F_YDYW] ||= _ydyw(@{$self}[F_DAYNO, F_TR_DATE], $y);
    return ($y, $ydyw->[0]);
}

sub get_ywd {
    no integer;
    my Date::Gregorian $self = $_[0];
    my $y = ($self->get_ymd)[0];
    my $ydyw = $self->[F_YDYW] ||= _ydyw(@{$self}[F_DAYNO, F_TR_DATE], $y);
    return (@{$ydyw}[1, 2], $self->[F_DAYNO] % 7);
}

sub add_days {
    my Date::Gregorian $self = $_[0];
    $self->[F_DAYNO] += $_[1];
    @{$self}[F_YMD, F_YDYW] = (undef, undef);
    return $self;
}

sub get_days_until {
    my Date::Gregorian ($self, $then) = @_;
    return $then->[F_DAYNO] - $self->[F_DAYNO];
}

sub get_days_since {
    my Date::Gregorian ($self, $then) = @_;
    return $self->[F_DAYNO] - $then->[F_DAYNO];
}

sub compare {
    my Date::Gregorian ($self, $then) = @_;
    return $self->[F_DAYNO] <=> $then->[F_DAYNO];
}

sub set_easter {
    my Date::Gregorian $self = $_[0];
    @{$self}[F_DAYNO, F_YMD, F_YDYW] =
	( _easter($_[1], @{$self}[F_TR_DATE, F_TR_EYR]), undef );
    return $self;
}

sub set_gmtime {
    no integer;
    my Date::Gregorian $self = $_[0];
    my $time = $_[1] + $gmt_correction;
    $time -= $time % 86400;
    @{$self}[F_DAYNO, F_YMD, F_YDYW] = (
	$gmt_epoch + $time / 86400,
	undef, undef,
    );
    return $self;
}

sub get_gmtime {
    no integer;
    my Date::Gregorian $self = $_[0];
    my $d = $self->[F_DAYNO] - $gmt_epoch;
    return 86400 * $d - $gmt_correction;
}

sub set_today {
    my Date::Gregorian $self = $_[0];
    return $self->set_localtime(time);
}

sub set_localtime {
    my Date::Gregorian $self = $_[0];
    my ($d, $m, $y) = (localtime $_[1])[3..5];
    $y += 1900;
    ++ $m;
    # presuming localtime always to return Gregorian dates,
    # while $self might be configured to interpret Julian,
    # we must ignore $self->[F_TR_DATE] here
    @{$self}[F_DAYNO, F_YMD, F_YDYW] =
	( _ymd2dayno($y, $m, $d, 1, 1), undef, undef );
    return $self;
}

sub get_localtime {
    no integer;
    my Date::Gregorian $self = $_[0];

    my $time = $self->get_gmtime - $localtime_offset;
    foreach my $step (0..3) {
	my ($S, $M, $H, $d, $m, $y) = localtime $time;
	my $dd = _ymd2dayno(1900+$y, 1+$m, $d, 1, 1) - $self->[F_DAYNO];
	return undef if 24855 < abs($dd);
	my $delta = (($dd * 24 + $H) * 60 + $M) * 60 + $S;
	if ($delta || $dd) {
	    if ($dd < 0 && 0 <= $delta) {
		# hours/minutes/seconds should not cancel out date increase
		$delta = -1;
	    }
	    $time -= $delta;
	    $localtime_offset += $delta if !$step;
	    next;
	}
	return $time;
    }
    return undef;
}

sub set_weekday {
    no integer;
    my Date::Gregorian $self = shift;
    my ($wd, $rel) = @_;
    my $delta = ($wd - $self->[F_DAYNO]) % 7;
    if (defined($rel) && '>=' ne $rel) {
	$delta = 7 if !$delta && '>' eq $rel;
	$delta -= 7 if '<' eq $rel || $delta && '<=' eq $rel;
    }
    if ($delta) {
	$self->[F_DAYNO] += $delta;
	@{$self}[F_YMD, F_YDYW] = (undef, undef);
    }
    return $self;
}

sub get_days_in_year {
    my ($self, $year) = @_;
    return
	_dec31dayno($year,   $self->[F_TR_DATE]) -
	_dec31dayno($year-1, $self->[F_TR_DATE]);
}

sub iterate_days_upto {
    my ($self, $limit, $rel, $step) = @_;
    my $dayno = $self->[F_DAYNO];
    my $final = $limit->[F_DAYNO] - ($rel ne '<=');
    $step = abs($step || 1);
    return sub {
	return undef if $dayno > $final;
	@{$self}[F_DAYNO, F_YMD, F_YDYW] = ($dayno, undef, undef);
	$dayno += $step;
	return $self;
    };
}

sub iterate_days_downto {
    my ($self, $limit, $rel, $step) = @_;
    my $dayno = $self->[F_DAYNO];
    my $final = $limit->[F_DAYNO] + ($rel eq '>');
    $step = abs($step || 1);
    return sub {
	return undef if $dayno < $final;
	@{$self}[F_DAYNO, F_YMD, F_YDYW] = ($dayno, undef, undef);
	$dayno -= $step;
	return $self;
    };
}

# --- DateTime interface ---

sub set_datetime {
    my ($self, $datetime) = @_;
    if (!$datetime->time_zone->is_floating) {
	$datetime = $datetime->clone->set_time_zone('floating');
    }
    my ($rd_days, @sec_ns) = $datetime->utc_rd_values;
    @{$self}[F_DAYNO, F_YMD, F_YDYW, F_SEC_NS] =
       ($rd_days + $datetime_epoch, undef, undef, \@sec_ns);
    return $self;
}

sub utc_rd_values {
    my $self = $_[0];
    return (
	$self->[F_DAYNO] - $datetime_epoch,
	@{$self->[F_SEC_NS] || $default_sec_ns}
    );
}

sub truncate_to_day {
    my $self = $_[0];
    undef $self->[F_SEC_NS];
    return $self;
}

sub from_object {
    my ($class, %param) = @_;
    return $class->new->set_datetime($param{'object'});
}

# must not define time_zone and set_time_zone methods

# --- stringification ---

sub get_string {
    my $self = $_[0];
    my $suffix = $self->is_gregorian? 'G': 'J';
    return sprintf "%d-%02d-%02d$suffix", $self->get_ymd;
}

sub set_string {
    my ($self, $string) = @_;
    if ($string =~ /^(-?\d+)-(\d+)-(\d+)([JG]?)\z/) {
	$self->[F_DAYNO] =
	    _ymd2dayno($1, $2, $3, $4? ($JG{$4}, 1): $self->[F_TR_DATE]);
	@{$self}[F_YMD, F_YDYW] = (undef, undef);
	return $self;
    }
    return undef;
}

# no DESTROY method, nothing to clean up

1;

__END__