view Lib/DateTime.pm @ 31:d59526f6310e

Small fixes to Test framework (correct handlinf of the compilation errors in the test units) Imported and refactored SQL DB schema from the old project
author Sergey
date Mon, 09 Nov 2009 01:39:16 +0300
parents 03e58a454b20
children 16ada169ca75
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;