File Coverage

blib/lib/Date/Tie.pm

Criterion	Covered	Total	%
statement	246	255	96.4
branch	141	156	90.3
condition	51	61	83.6
subroutine	12	12	100.0
pod	0	1	0.0
total	450	485	92.7

#
# Copyright (c) 2001,2002 Flavio Soibelmann Glock.
# All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Date::Tie;
use strict;
use Tie::Hash;
use Exporter;
use POSIX;  # floor()
use Time::Local qw( timegm );
use vars    qw( @ISA %Frac %Max %Min %Mult $Infinity $VERSION $Resolution );
@ISA =      qw( Tie::StdHash );
$VERSION =  '0.20';
$Infinity = 999_999_999_999;

%Frac = (   frac_hour =>    60 * 60,      frac_minute => 60,
            frac_second =>  1,            frac_epoch =>  1 );

%Mult = (   day =>      24 * 60 * 60,  hour =>    60 * 60,      minute => 60,
            second =>   1,             epoch =>   1,
            monthday => 24 * 60 * 60,  weekday => 24 * 60 * 60, yearday => 24 * 60 * 60,
            week => 7 * 24 * 60 * 60,  tzhour =>  60 * 60,      tzminute => 60 );

%Max  = (   year =>     $Infinity,     yearday =>  365,         month =>    12,
            monthday => 28,            day =>      28,          week =>     52,
            weekday =>  7,             hour =>     23,          minute =>   59,
            second =>   59,            weekyear => $Infinity,   epoch =>    $Infinity );

%Min  = (   year =>     -$Infinity,    yearday =>  1,           month =>    1,
            monthday => 1,             day =>      1,           week =>     1,
            weekday =>  1,             hour =>     0,           minute =>   0,
            second =>   0,             weekyear => -$Infinity,  epoch =>    -$Infinity  );

sub STORE {
    my ($self, $key, $value) = @_;
    my ($delta);
    $key = 'day' if $key eq 'monthday';
    $value =~ tr/\,/\./;  # translate comma to dot
    $value += 0;

    my $i_value = POSIX::floor($value);    # get integer part

    if ($value =~ /e/i) {
        # SCIENTIFIC NOTATION!
        ($value) = sprintf("%0.20f", $value) =~ /(.*?)0*$/;  # without trailing zeroes
    }

    # TODO: make 3 separate 'if's
    if (($i_value != $value) or ($key eq 'frac') or (exists $Frac{$key})) {
        # has fractional part

        my ($frac) = $value =~ /\.(.*)/;  # get fractional part as an 'integer'
        $frac = 0 unless defined $frac;       # or get zero

        if ($key eq 'frac') {
            if (($value < 0) or ($value >= 1)) {
                # fractional overflow
                $self->STORE('second', $self->FETCH('second') + $i_value);
                # make sure frac is a positive number
                my $len_frac = length($frac);
                $frac = ('1' . '0' x $len_frac ) - $frac if ($value < 0) and ($frac != 0);
                $frac = '0' x ($len_frac - length($frac)) . $frac;
            }
            $self->{frac} = '.' . $frac;
            return;
        }
        if (exists $Frac{$key}) {

            my ($not_frac_key) = $key =~ /frac_(.*)/;
            $self->STORE($not_frac_key, $i_value);
            my $mult = $Frac{$key};

            # make sure frac is a positive number
            my $len_frac = length($frac);
            $frac = ('1' . '0' x $len_frac ) - $frac if ($value < 0) and ($frac != 0);
            $frac = '0' x ($len_frac - length($frac)) . $frac;
            $frac = '.' . $frac;

            # round last digit if the number is a fraction of '3': 1/3 1/9 ...
            # 9 digits is enough for nano-second resolution...
            if (length($frac) > 9) {
                my ($last_frac, $last_mult) = ($frac, $mult);

                foreach(0..3) {

                    if ( $_ == 3 ) {
                        # give-up rounding --- go back to original values ???
                        ($frac, $mult) = ($last_frac, $last_mult);
                        last;
                    }

                    #   000.$
                    if ($frac =~ /000.$/) {
                        $frac =~ s/.$//;
                        last;
                    }
                    elsif ($frac =~ /999.$/) {
                        my ($zeroes, $digit) = $frac =~ /\.(.*)(.)$/;
                        $digit = '0.' . '0' x (length($zeroes)-1) . sprintf("%02d", 10 - $digit);
                        $frac += $digit;
                        last;
                    }
                    else {
                        $frac *= 3;
                        $mult /= 3;
                    }

                } # foreach
            } # round 1/3 1/9 ...

            # zero units below this
            if ($not_frac_key eq 'hour') {
                $self->STORE('minute', 0);
                $self->STORE('second', 0);
            }
            if ($not_frac_key eq 'minute') {
                $self->STORE('second', 0);
            }
            $self->STORE('frac', $mult * $frac);

            return;
        }

        # error - this unit does not allow a fractional part
        $key =~ s/frac_//;
        $value = POSIX::floor($value + 0.5);    # round to integer

    }   # end: has fractional part

    if ($key eq 'tz') {
        # note: this must be "int", not "floor" !!
        STORE($self, 'tzminute', $value - 40 * int($value / 100));   #  60 - 100 !
        return;
    }
    if (($key eq 'tzhour') or ($key eq 'tzminute')) {
        $self->{tz100} = 0 unless exists $self->{tz100};
        if ($key eq 'tzhour') {
            $delta = $value * 3600 - $self->{tz100};
        }
        else {
            $delta = $value * 60   - $self->{tz100};
        }
        $self->{tz100} += $delta;

        $self->STORE('epoch', FETCH($self, 'epoch') + $delta);
        return;
    }

    if ($key eq 'utc_epoch') {
        %{$self} = ( utc_epoch => $value, epoch => $value + ($self->{tz100} || 0),
                     tz100 => $self->{tz100}, frac => $self->{frac} );
        return;
    }

    if ($key eq 'epoch') {
        $self->{epoch} = $value;
        # remove all other keys (now invalid)
        %{$self} = ( epoch => $self->{epoch}, tz100 => $self->{tz100}, frac => $self->{frac} );
        return;
    }
    if ($key eq 'month') {
        return if (exists $self->{month}) and ($self->{month} == $value);
        $self->FETCH('day') unless exists $self->{day};  # save 'day' before deleting epoch!

        delete $self->{epoch};
        delete $self->{utc_epoch};
        delete $self->{weekday};
        delete $self->{yearday};
        delete $self->{week};
        delete $self->{weekyear};

        if (($value >= $Min{$key}) and ($value <= $Max{$key})) {
            $self->{$key} = $value;
        }
        else {
            $value -= 1;
            $self->{year} += POSIX::floor( $value / 12);
            $self->{month} = 1 + $value % 12;
        }

        if ($self->{day} >= 29) {
            my ($tmp_month) = $self->FETCH('month');
            # check for day overflow
            $self->STORE('day',$self->{day});
            $self->FETCH('month');
            if ($tmp_month != $self->{month}) {
                $self->STORE('day', 0);
            }
        }

        return;
    }
    if ($key eq 'year') {
        return if (exists $self->{year}) and ($self->{year} == $value);
        $self->FETCH('day') unless exists $self->{day};  # save 'day' before deleting epoch!

        delete $self->{epoch};
        delete $self->{utc_epoch};
        delete $self->{weekday};
        delete $self->{yearday};
        delete $self->{week};
        delete $self->{weekyear};

        $self->{year} = $value;

        if ($self->{day} >= 29) {
            my ($tmp_month) = $self->FETCH('month');
            # check for day overflow
            $self->STORE('day',$self->{day});
            $self->FETCH('month');
            if ($tmp_month != $self->{month}) {
                $self->STORE('day', 0);
            }
        }

        return;
    }
    if ($key eq 'weekyear') {
        my $week =     exists $self->{week} ?     $self->{week} :     FETCH($self, 'week');
        my $weekyear = exists $self->{weekyear} ? $self->{weekyear} : FETCH($self, 'weekyear');
        FETCH($self, 'epoch') unless exists $self->{epoch};
        $self->{epoch} += 52 * $Mult{week} * ($value - $weekyear);
        %{$self} = ( epoch => $self->{epoch}, tz100 => $self->{tz100}, frac => $self->{frac} );
        my $week2 =    FETCH($self, 'week');
        while ($week2 != $week) {
            STORE($self, 'week', $week2 + ($value <=> $weekyear) );
            $week2 =   FETCH($self, 'week');
        }
        return;
    }
    # all other keys

    unless ( exists $self->{$key} ) {
        FETCH($self, $key);
    }
    $delta = $value - $self->{$key};

    if (($value >= $Min{$key}) and ($value <= $Max{$key}) and
        ($key ne 'weekday') and ($key ne 'yearday') and ($key ne 'week')) {
        if (exists $self->{epoch}) {
            $self->{epoch} += $delta * $Mult{$key};
            delete $self->{utc_epoch};
        }
        $self->{$key}  =  $value;
        # update dependencies
        if ($key eq 'day') {
            delete $self->{weekday};
            delete $self->{yearday};
            delete $self->{weekyear};
            delete $self->{week};
        }
        return;
    }
    # handle overflow
    # init epoch key
    unless ( exists $self->{epoch} ) {
        FETCH($self, 'epoch');
    }
    $self->{epoch} += $delta * $Mult{$key};
    # remove all other keys (now invalid)
    %{$self} = ( epoch => $self->{epoch}, tz100 => $self->{tz100}, frac => $self->{frac} );
    return;
}

sub FETCH {
    my ($self, $key) = @_;
    my ($value);
    $key = 'day' if $key eq 'monthday';

    if ($key eq 'frac') {
        return $self->{frac};
    }
    if (exists $Frac{$key}) {
        my ($not_frac_key) = $key =~ /frac_(.*)/;
        $value = $self->FETCH($not_frac_key);
        return $value . $self->{frac} if ($Frac{$key} == 1);  # no rounding
        # units below this
        if ($not_frac_key eq 'hour') {
            $value += $self->FETCH('minute') / 60.0;
            $value += $self->FETCH('second') / 3600.0;
        }
        if ($not_frac_key eq 'minute') {
            $value += $self->FETCH('second') / 60.0;
        }
        $value += $self->FETCH('frac') / $Frac{$key};
        $value = '0' . $value if ($value >= 0) and ($value < 10);  # format output
        $value = $value . '.0' unless ($value =~ /\./);            # format output
        return $value;
    }
    if ($key eq 'tz') {
        my ($h, $m) = (FETCH($self, 'tzhour'), FETCH($self, 'tzminute'));
        my $s = $self->{tz100} < 0 ? '-' : '+';
        return $s . substr($h,1,2) . sprintf("%02d", abs($m));
    }
    if ($key eq 'tzhour') {
        my $s = $self->{tz100} < 0 ? '-' : '+';
        # note: this must be "int", not "floor" !!
        $value = int($self->{tz100} / 3600);
        return $s . sprintf("%02d", abs($value));
    }
    if ($key eq 'tzminute') {
        my $s = $self->{tz100} < 0 ? '-' : '+';
        # note: this must be "int", not "floor" !!
        $value = int( ( $self->{tz100} - 3600 * int($self->{tz100} / 3600) ) / 60 );
        return $s . sprintf("%02d", abs($value));
    }

    unless (exists($self->{$key}) ) {
        # create key if possible
        if (( $key eq 'epoch') or not exists $self->{epoch} ) {
            my ($year, $month, $day, $hour, $minute, $second);
            $day =    exists $self->{day} ?    $self->{day}    : 1;
            $month =  exists $self->{month} ?  $self->{month} - 1   : 0;
            $year =   exists $self->{year} ?   $self->{year} - 1900 : 0;
            $hour =   exists $self->{hour} ?   $self->{hour}   : 0;
            $minute = exists $self->{minute} ? $self->{minute} : 0;
            $second = exists $self->{second} ? $self->{second} : 0;

            # TODO: test for month overflow (error when using perl 5.8.0)
            #    Day '31' out of range 1..30 at lib/Date/Tie.pm line 383
            eval { $self->{epoch} = timegm( $second, $minute, $hour, $day, $month, $year ); };
            # warn $@ if $@;
            while ($@ =~ /Day \'\d+\' out of range/ ) {
                $day = $self->{day}--;
                eval { $self->{epoch} = timegm( $second, $minute, $hour, $day, $month, $year ); };
                # warn $@ if $@;
            }
            return $self->{epoch} if $key eq 'epoch';  # ???
        }
        (   $self->{second},  $self->{minute},   $self->{hour},
            $self->{day},     $self->{month},    $self->{year},
            $self->{weekday}, $self->{yearday} ) = gmtime($self->{epoch});
        $self->{year} += 1900;
        $self->{month}++;
        $self->{weekday} = 7 unless $self->{weekday};
        $self->{yearday}++;
        $self->{utc_epoch} = $self->{epoch} - ( $self->{tz100} || 0 );

        if ( $key eq 'week' || $key eq 'weekyear' ) {
            $self->{week} = POSIX::floor( ($self->{yearday} - $self->{weekday} + 10) / 7 );
            if ($self->{yearday} > 361) {
                # find out next year's jan-04 weekday
                tie my %tmp, 'Date::Tie', year => ($self->{year} + 1), month => '01', day => '04';
                # jan-04 weekday: 1  2  3  4  5  6  7
                my @wk1 = qw( 29 32 32 32 32 31 30 29 );
                my $last_day = $wk1[$tmp{weekday}];
                $self->{week} = 1 if ($self->{day} >= $last_day);
            }
            if ( $self->{week} == 0 ) {
                my @t = gmtime( timegm( 0,0,0, 31,11,($self->{year} - 1) ) );
                $self->{week} = POSIX::floor( ($t[7] - $t[6] + 11) / 7 );
            }

            $self->{weekyear} = $self->{year};
            $self->{weekyear}++ if ($self->{week} < 2)  and ($self->{month} > 10);
            $self->{weekyear}-- if ($self->{week} > 50) and ($self->{month} < 2);
        }
    } # create keys

    $value = $self->{$key};
    return $value if $key eq 'weekday';
    return $value if $key eq 'utc_epoch';
    return sprintf("%02d", $value) if $key ne 'yearday';
    return sprintf("%03d", $value);
}

sub TIEHASH  {
    my $self = bless {}, shift;
    my ($tmp1, $tmp2);
    $self->{frac} = '.0';
    $self->{tz100} = 0;
    ( $self->{second},  $self->{minute}, $self->{hour},
      $self->{day},     $self->{month},  $self->{year},
      $self->{weekday}, $self->{yearday} ) = gmtime();
    $self->{year} += 1900;
    $self->{month}++;
    $self->{weekday} = 7 unless $self->{weekday};
    $self->{yearday}++;
    while ($#_ > -1) {
        ($tmp1, $tmp2) = (shift, shift);
        STORE ($self, $tmp1, $tmp2);
    }
    return $self;
}

sub new {
    my $class = shift;
    my @parent;
    @parent = %$class if ref $class;
    push @parent, @_;
    my $self = bless {}, ref $class || $class;
    tie %$self, 'Date::Tie', @parent;
    return $self;
}

# FIRSTKEY added to support recommended assignment order: set timezone, then epoch and fractional seconds
#   tie my %b, 'Date::Tie', tz => $d{tz}, epoch => $d{epoch}, frac => $d{frac};

sub FIRSTKEY {
    my ($self) = @_;
    return 'tz';
}

sub NEXTKEY {
    my ($self, $lastkey) = @_;
    return 'epoch' if $lastkey eq 'tz';
    return 'frac'  if $lastkey eq 'epoch';
    return undef;
}

# This is for debugging only !
# sub iso { my $self = shift; return $self->{year} . '-' . $self->{month} . '-' . $self->{day} . " $self->{weekyear}-W$self->{week}-$self->{weekday}"; }
# sub debug { return; my $self = shift; return join(':',%{$self}); }

1;

__END__