view release on metacpan or  search on metacpan

t/09greg.t  view on Meta::CPAN

use strict;
use warnings;

use Test::More;

use DateTime;

undef $ENV{PERL_DATETIME_DEFAULT_TZ};

## no critic (Subroutines::ProtectPrivateSubs)

# test _ymd2rd and _rd2ymd for various dates
# 2 tests are performed for each date (on _ymd2rd and _rd2ymd)
# dates are specified as [rd,year,month,day]
for (    # min and max supported days (for 32-bit system)
    [ -( 2**28 ), -734951, 9, 7 ],
    [ 2**28,       734952, 4, 25 ],

    # some miscellaneous dates (these are actually epoch dates for
    # various calendars from Calendrical Calculations (1st ed) Table
    # 1.1)
    [ -1721425, -4713, 11, 24 ],
    [ -1373427, -3760, 9,  7 ],
    [ -1137142, -3113, 8,  11 ],
    [ -1132959, -3101, 1,  23 ],
    [ -963099,  -2636, 2,  15 ],
    [ -1,        0,    12, 30 ], [ 1, 1, 1, 1 ],
    [  2796,     8,    8,  27 ],
    [  103605,   284,  8,  29 ],
    [  226896,   622,  3,  22 ],
    [  227015,   622,  7,  19 ],
    [  654415,   1792, 9,  22 ],
    [  673222,   1844, 3,  21 ]
) {
    is(
        join( '/', DateTime->_rd2ymd( $_->[0] ) ),
        join( '/', @{$_}[ 1 .. 3 ] ),
        $_->[0] . "   \t=> " . join '/', @{$_}[ 1 .. 3 ]
    );

    is(
        DateTime->_ymd2rd( @{$_}[ 1 .. 3 ] ), $_->[0],
        join( '/', @{$_}[ 1 .. 3 ] ) . "   \t=> " . $_->[0]
    );
}

# normalization tests
for (
    [ -1753469, -4797, -33, 1 ],
    [ -1753469, -4803,  39, 1 ],
    [ -1753105, -4796, -34, 28 ],
    [ -1753105, -4802,  38, 28 ]
) {
    is(
        DateTime->_ymd2rd( @{$_}[ 1 .. 3 ] ), $_->[0],
        join( '/', @{$_}[ 1 .. 3 ] )
            . " \t=> "
            . $_->[0]
            . ' (normalization)'
    );
}

# test first and last day of each month from Jan -4800..Dec 4800
# this test bails after the first failure with a not ok.
# if it completes successfully, only one ok is issued.

my @mlen = ( 0, 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
my ( $dno, $y, $m, $dno2, $y2, $m2, $d2, $mlen ) = ( -1753530, -4800, 1 );

while ( $y <= 4800 ) {

    # test $y,$m,1
    ++$dno;
    $dno2 = DateTime->_ymd2rd( $y, $m, 1 );
    if ( $dno != $dno2 ) {
        is(
            $dno2, $dno,
            "greg torture test: _ymd2rd($y,$m,1) should be $dno"
        );
        last;