libdate-simple-perl 3.03.03-1build2 / usr / lib / perl5 / Date / Simple / NoXS.pm

# Date::Simple::NoXS - used internally by Date::Simple.

use strict;

package Date::Simple;

sub _ymd {
    my ( $class, @args ) = @_;
    my $days = ymd_to_days(@args);
    return unless defined($days);
    return ( bless \$days, $class );
}

sub _d8 {
    my ( $o, $d8 ) = @_;
    my @ymd = $d8 =~ m/^(\d{4})(\d\d)(\d\d)$/ or return undef;
    return $o->_ymd(@ymd);
}

# Precise integer arithmetic functions unfortunately missing from
# Perl's core:

sub _divmod {
    my ( $quot, $int );

    $quot = $_[0] / $_[1];
    $int  = int($quot);
    $int -= 1 if $int > $quot;
    $_[0] %= $_[1];
    return $int;
}

sub _div {
    my ( $quot, $int );

    $quot = $_[0] / $_[1];
    $int  = int($quot);
    return $int - 1 if $int > $quot;
    return $int;
}

sub leap_year {
    my $y = shift;
    return ( ( $y % 4 == 0 ) and ( $y % 400 == 0 or $y % 100 != 0 ) ) || 0;
}

my @days_in_month = (
    [ 0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ],
    [ 0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ],
);

sub days_in_month ($$) {
    my ( $y, $m ) = @_;
    return $days_in_month[ leap_year($y) ][$m];
}

sub validate ($$$) {
    my ( $y, $m, $d ) = @_;

    # any +ve integral year is valid
    return 0 if $y != abs int $y;
    return 0 unless 1 <= $m and $m <= 12;
    return 0 unless 1 <= $d and $d <= $days_in_month[ leap_year($y) ][$m];
    return 1;
}

# Given a year, month, and day, return the canonical day number.
# That is the number of days since 1 January 1970, negative if earlier.
sub ymd_to_days {
    my ( $Y, $M, $D ) = @_;
    my ( $days, $x );

    if (   $M < 1
        || $M > 12
        || $D < 1
        || ( $D > 28 && $D > days_in_month( $Y, $M ) ) ) {
        return undef;
    }

    $days = $D +
      ( undef, -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333 )[$M];
    $days += 365 * ( $Y - 1970 );
    $x = ( $M <= 2 ? $Y - 1 : $Y );
    $days += _div( ( $x - 1968 ), 4 );
    $days -= _div( ( $x - 1900 ), 100 );
    $days += _div( ( $x - 1600 ), 400 );
    return $days;
}

sub days_since_1970 { ${ $_[0] } }

# Given a canonical day number (days since 1 Jan 1970), return the
# year, month, and day.
sub days_to_ymd {
    my ($days) = @_;
    my ( $year, $mnum, $mday, $tmp );

    # Shift frame of reference from 1 Jan 1970 to (the imaginary) 1 Mar 0AD.
    $tmp = $days + 719468;

    # Do the math.
    $year = 400 * _divmod( $tmp, 146097 );
    if ( $tmp == 146096 ) {

        # Handle 29 Feb 2000, 2400, ...
        $year += 400;
        $mnum = 2;
        $mday = 29;
    }
    else {
        $year += 100 * _divmod( $tmp, 36524 );
        $year += 4 * _divmod( $tmp, 1461 );
        if ( $tmp == 1460 ) {
            $year += 4;
            $mnum = 2;
            $mday = 29;
        }
        else {
            $year += _divmod( $tmp, 365 );
            $mnum = _divmod( $tmp, 31 );
            $mday = $tmp + ( 1, 1, 2, 2, 3, 3, 3, 4, 4, 5, 5, 5 )[$mnum];
            $tmp = ( 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31, 28 )[$mnum];
            if ( $mday > $tmp ) {
                $mday -= $tmp;
                $mnum += 1;
            }
            if ( $mnum > 9 ) {
                $mnum -= 9;
                $year += 1;
            }
            else {
                $mnum += 3;
            }
        }
    }
    return ( $year, $mnum, $mday );
}

sub as_ymd { return days_to_ymd( ${ $_[0] } ); }
sub as_d8  { return sprintf( "%04d%02d%02d", &as_ymd ); }
sub as_iso { return sprintf( "%04d-%02d-%02d", &as_ymd ); }

sub year  { return (&as_ymd)[0]; }
sub month { return (&as_ymd)[1]; }
sub day   { return (&as_ymd)[2]; }

sub day_of_week {
    return ( ( ${ $_[0] } + 4 ) % 7 );
}

#------------------------------------------------------------------------------
# the following methods are called by the overloaded operators, so they should
# not normally be called directly.
#------------------------------------------------------------------------------

sub _add {
    my ( $date, $diff ) = @_;

    if ( $diff !~ /^-?\d+$/ ) {
        Carp::croak("Date interval must be an integer");
    }
    my $new_date = bless( \( $$date + $diff ), ref($date) );
    $new_date->default_format( $date->default_format );
    return $new_date;
}

sub _subtract {
    my ( $left, $right, $reverse ) = @_;

    my $new_date;

    if ($reverse) {
        Carp::croak("Can't subtract a date from a non-date");
    }
    if ( ref($right) eq '' && $right =~ /^-?\d+$/ ) {
        $new_date = bless( \( $$left - $right ), ref($left) );
        $new_date->default_format( $left->default_format );
        return $new_date;
    }
    return ( $$left - $$right );
}

sub _compare {
    my ( $left, $right, $reverse ) = @_;

    $right = $left->new($right) || _inval( $left, $right );
    return ( $reverse ? $$right <=> $$left : $$left <=> $$right );
}

sub _eq {
    my ( $left, $right ) = @_;
    return ( ( $right = $left->_new($right) ) && $$right == $$left );
}

sub _ne {
    return ( !&_eq );
}

1;

=head1 NAME

Date::Simple::NoXS - Pure Perl support for Date::Simple.

=head1 SYNOPSIS

    use Date::Simple;

=head1 DESCRIPTION

Used internally by Date::Simple.

=head1 SEE ALSO

L<Date::Simple>.

=cut