view Lib/DateTime.pm @ 84:e568c7c8b743

Minor changes to the test infrastructure
author wizard
date Wed, 14 Apr 2010 17:38:11 +0400
parents 16ada169ca75
children
line wrap: on
line source

use strict;
package DateTime::Span;
package DateTime;
use Common;
use Time::Local;
use Time::Zone;
use Date::Format;
our @ISA = qw(Object);

use overload
    '+' => \&opAdd,
    '-' => \&opSubtract,
    '<=>' => \&opCompare,
    'bool' => \&opAsBool,
    'fallback' => 1,
    '""' => \&opAsString;

BEGIN {
    DeclareProperty UnixTime => ACCESS_READ;
}

sub CTOR {
    my $this = shift;
    
    if (@_ >= 2) {
        my(%args) = @_;
        
        $this->{$UnixTime} = $args{UnixTime} or die new Exception("A correct unix time value is required");
    } else {
        $this->{$UnixTime} = $this->ParseISOTime(shift,'+000');
    }
}

sub ParseISOTime {
    my ($class,$time,$timezone) = @_;
    
    if ($time =~ /^(\d{4})-(\d{2})-(\d{2})(?:.(\d{2}):(\d{2}):(\d{2})(?:\.\d{3})?)?/ ) {
        my ($yyyy,$mm,$dd,$hh,$MM,$SS) = ($1-1900,$2-1,$3,$4 || 0,$5 || 0,$6 || 0);
        if ($timezone) {
            return tz_offset($timezone) + timegm($SS,$MM,$hh,$dd,$mm,$yyyy);
        } else {
            return timelocal($SS,$MM,$hh,$dd,$mm,$yyyy);
        }
    } else {
        die new Exception("The specified string isn\'t a correct ISO date",$time);
    }
}

sub new_ISO {
    my ($class,$ISOTime,$zone) = @_;
    return $class->new(UnixTime => $class->ParseISOTime($ISOTime,$zone));
}

sub now {
    my ($class) = @_;
    return $class->new(UnixTime => time);
}

sub AsISOString {
    my ($this,$zone) = @_;
    return time2str("%Y-%m-%dT%H:%M:%S",$this->{$UnixTime},$zone);
}

sub AsFormatString {
    my ($this,$format,$zone) = @_;
    return time2str($format,$this->{$UnixTime},$zone);
}

sub opAdd {
    my ($a,$b,$flag) = @_;
    
    if (UNIVERSAL::isa($b,'DateTime::Span')) {
        return new DateTime(UnixTime => $a->{$UnixTime} + $b->SecondsSpan);
    } elsif (not ref $b){
        return new DateTime(UnixTime => $a->UnixTime + $b);
    } else {
        die new Exception("Only a time span can be added to the DateTime object",$b);
    }
}

sub GetDate {
    my ($this) = @_;
    
    return DateTime->new_ISO($this->AsFormatString('%Y-%m-%d'));
}

sub opSubtract {
    my ($a,$b,$flag) = @_;
    
    if (UNIVERSAL::isa($b,'DateTime')) {
        return new DateTime::Span(Seconds => $a->{$UnixTime}-$b->{$UnixTime});
    } elsif (UNIVERSAL::isa($b,'DateTime::Span')) {
        return new DateTime(UnixTime => $flag ? $b->SecondsSpan - $a->UnixTime: $a->UnixTime - $b->SecondsSpan);
    } elsif (not ref $b){
        return new DateTime(UnixTime => $flag ? $b - $a->UnixTime : $a->UnixTime - $b);
    } else {
        die new Exception("Only an another DateTime object or a time span can be subtracted from the DateTime",$b);
    }
}

sub opCompare {
    my ($a,$b,$flag) = @_;
    
    if (UNIVERSAL::isa($b,'DateTime')) {
        return $flag ? $b->{$UnixTime} <=> $a->{$UnixTime} : $a->{$UnixTime} <=> $b->{$UnixTime};
    } else {
        die new Exception("Only a DateTime object can be compared to the DateTime object", $b);
    }
}

sub opAsString {
    my $this = shift;
    $this->AsISOString('+000');
}

sub opAsBool {
    1;
}

package DateTime::Span;
use Common;
our @ISA = qw(Object);

use overload
    '-' => \&opSub,
    '+' => \&opAdd,
    '<=>' => \&opCmp,
    'fallback' => 1;

BEGIN {
    DeclareProperty SecondsSpan=>ACCESS_READ;
}

sub CTOR {
    my ($this,%args) = @_;
    
    $this->{$SecondsSpan} = ($args{'Seconds'} || 0) + ($args{'Minutes'} || 0)*60 + ($args{'Hours'} || 0)*3600 + ($args{'Days'} || 0)*86400;
}

sub Days {
    my ($this) = @_;
    
    return int($this->{$SecondsSpan}/86400);
}

sub Hours {
    my ($this) = @_;
    
    return int($this->{$SecondsSpan}/3600);
}
sub Minutes {
    my ($this) = @_;
    
    return int($this->{$SecondsSpan}/60);
}

sub opAdd {
    my ($a,$b,$flag) = @_;
    
    if (UNIVERSAL::isa($b,'DateTime::Span')) {
        return new DateTime::Span(Seconds => $a->{$SecondsSpan} + $b->{$SecondsSpan});
    } elsif (not ref $b) {
        return new DateTime::Span(Seconds => $a->{$SecondsSpan} + $b);
    } else {
        die new Exception("Only a time span can be added to the time span");
    }
}

sub opSub {
    my ($a,$b,$flag) = @_;
    
    if (UNIVERSAL::isa($b,'DateTime::Span')) {
        return new DateTime::Span(Seconds => $flag ? $b->{$SecondsSpan} - $a->{$SecondsSpan} : $a->{$SecondsSpan} - $b->{$SecondsSpan});
    } elsif (not ref $b) {
        return new DateTime::Span(Seconds => $flag ? $b - $a->{$SecondsSpan} : $a->{$SecondsSpan} - $b);
    } else {
        die new Exception("Only a time span can be subtracted from the time span");
    }
}

sub opCmp {
    my ($a,$b,$flag) = @_;
    
    if (UNIVERSAL::isa($b,'DateTime::Span')) {
        return $flag ? $b->{$SecondsSpan} <=> $a->{$SecondsSpan} : $a->{$SecondsSpan} <=> $b->{$SecondsSpan};
    } elsif (not ref $b) {
    return $flag ? $b <=> $a->{$SecondsSpan} : $a->{$SecondsSpan} <=> $b;
    } else {
        die new Exception("Only a time span can be compared to the time span");
    }
}

package DateTime::TimeLine;
use Common;
our @ISA = qw(Object);

BEGIN {
    DeclareProperty Timeline => ACCESS_READ;
}

sub CTOR {
    my ($this) = @_;

    $this->{$Timeline} = [ {Date => undef} ];
}

# рекурсивно копирует простые структуры
sub SimpleCopy {
    my ($refObject,$cache) = @_;

    return undef if not defined $refObject;

    $cache ||= {};

    if ($cache->{$refObject}) {
        return $cache->{$refObject};
    }

    local $_;

    if (ref $refObject eq 'HASH' ) {
        return ($cache->{$refObject} = { map { $_, SimpleCopy($refObject->{$_},$cache) } keys %$refObject });
    } elsif (ref $refObject eq 'ARRAY' ) {
        return ($cache->{$refObject} = [ map { SimpleCopy($_,$cache) } @$refObject]);
    } else {
        return ($cache->{$refObject} = $refObject);
    }
}

sub Split {
    my ($this,$date) = @_;

    die new Exception('Can\'t split the timeline with an undefined date') unless $date;
    
    for (my $i = 0; $i < @{$this->{$Timeline}}; $i++) {
        my $Elem = $this->{$Timeline}[$i];
        if ($Elem->{Date} and $Elem->{Date} >= $date ) {
            if ($Elem->{Date} == $date) {
                return $Elem;
            } else {
                my $newElem = SimpleCopy($this->{$Timeline}[$i-1]);
                $newElem->{Date} = $date;
        use Data::Dumper;
        
                splice @{$this->{$Timeline}},$i,0,$newElem;
                return $newElem;
            }
        }
    }
    my $Elem = { Date => $date };
    push @{$this->{$Timeline}},$Elem;
    return $Elem;
}

sub Select {
    my ($this,$start,$end) = @_;

    my @result;

    for (my $i=0; $i< @{$this->{$Timeline}}; $i++) {
        my $Elem = $this->{$Timeline}[$i];
        my $Next = $this->{$Timeline}[$i+1];
        if (
            (not $Elem->{Date} or not $start or $Elem->{Date} < $start)
            and
            (not $Next->{Date} or not $start or $Next->{Date} > $start)
        ) {
            # ------*++++(++++*----...--)---
            push @result,$Elem;
        } elsif (
            $Elem->{Date}
            and
            (not $start or $Elem->{Date} >= $start)
            and
            (not $end or $Elem->{Date} < $end )
        ) {
            # ------*---(----*++...++*++)+++*----
            push @result,$Elem;
        } elsif ( $Elem->{Date} and $end and $Elem->{Date} >= $end) {
            last;
        }
    }

    return @result;
}

sub SelectStrict {
    my ($this,$start,$end) = @_;
    $this->Split($start);
    $this->Split($end);
    return grep {
        $_->{Date}
        and
        $start ? $_->{Date} >= $start : 1
        and
        $end ? $_->{Date} < $end : 1
    } @{$this->{$Timeline}};
}

sub SelectAsPeriod {
    my ($this,$start,$end) = @_;
    
    my @Dates = $this->Select($start,$end);
    for (my $i = 0; $i< @Dates; $i++) {
        $Dates[$i]->{Start} = $Dates[$i]->{Date};
        $Dates[$i]->{End} = $Dates[$i+1] ? $Dates[$i+1]->{Date} : undef
    }
    
    return @Dates;
}

1;