File Coverage

blib/lib/Geography/Country/TZ/Zone.pm

Criterion	Covered	Total	%
statement	6	96	6.2
branch	0	58	0.0
condition	0	21	0.0
subroutine	2	9	22.2
pod	0	7	0.0
total	8	191	4.1

package Geography::Country::TZ::Zone;
use strict 'vars';
use vars qw(%loc %rule %map %map2);

my $offset = 0;
while () {
        chomp;
        s/#.*$//;
        next unless (/\S/);
        my @tokens = split(/\s+/);
        if ($tokens[0] eq 'Zone') {
                $loc{$tokens[1]} = $offset;
        }
        if ($tokens[0] eq 'Link') {
                $loc{$tokens[2]} = $loc{$tokens[1]};
        }
        if ($tokens[0] eq 'Rule') {
                $rule{$tokens[1]} ||= $offset;
        }
        $offset = tell(DATA);
}

sub getblock {
        my $zone = shift;
        my $offset = $loc{$zone};
        return undef unless (defined($offset));
        seek(DATA, $offset, 0);
        my @ary;
        while () {
                chop;
                s/#.*$//;
                next unless (/\S/);
                my @tokens = split(/\s+/, $_);
                last if ($tokens[0] eq 'Link');
                last if ($tokens[0] eq 'Rule');
                if ($tokens[0] eq 'Zone') {
                        last if @ary;
                        shift @tokens;
                        shift @tokens;
                }
                while (@tokens && !$tokens[0]) {
                        shift @tokens;
                }
                next unless (@tokens);
                @tokens = (@tokens[0 .. 3], join(" ", @tokens[4 .. $#tokens]));
                push(@ary, \@tokens);
        }
        @ary;
}
sub conv {
        my $a = shift;
        $a =~ s/^(-?)//;
        my $neg = $1;
        my @tokens = (split(/:/, $a), 0, 0);
        $neg . ($tokens[0] * 60 + $tokens[1]) * 60 + $tokens[2];
}

sub getoffset {
        my $zone = shift;
        my @ary = &getblock($zone);
        return undef unless (@ary);
        my @t = localtime;
        conv($ary[-1]->[0]) + &getsave($ary[-1]->[1],
                $t[3], $t[4] + 1, $t[5] + 1900);
}

@map{qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)} = (1 .. 12);

sub getpastoffset {
        my ($zone, $d, $m, $y) = @_;
        my @ary = &getblock($zone);
	my $def;
        return undef unless (@ary);
	my $policy;
        foreach (@ary) {
                $def = $_->[0];
                $policy = $_->[1];
                my $from = $_->[3];
		next unless ($from);
                my @tokens = split(/\s+/, $from);
                last if ($tokens[0] > $y);
                last if ($#tokens && $map{$tokens[1]} > $m);
                last if ($#tokens > 1 && $tokens[2] > $d);
        }
        &conv($def) + &getsave($policy, $d, $m, $y);
}

sub getsave {
        my ($cn, $d, $m, $y, $t) = @_;
        return &conv($cn) if ($cn =~ /^[0-9:]+$/);
        my $offset = $rule{$cn};
        return 0 unless ($offset);
        seek(DATA, $offset, 0);
        my $def = 0;
	my $mm;
        $t = &conv($t) if ($t);
        while () {
                chop;
                my @tokens = split(/\s+/);
                last if ($tokens[0] ne 'Rule' || $tokens[1] ne $cn);
                last if ($tokens[2] > $y);
                next if ($tokens[3] =~ /^\d+$/ && $tokens[3]);
                next if ($tokens[3] eq 'only' && $y != $tokens[2]);
                last if (($mm = $map{$tokens[5]}) > $m);
                next if ($m == $mm && &find($tokens[6], $m, $y) > $d);
                $def = $tokens[8];
        }
        &conv($def);
}

@map2{qw(Sun Mon Tue Wed Thu Fri Sat)} = (1 .. 7);

sub find {
        my ($exp, $m, $y) = @_;
        return $exp if ($exp =~ /^\d+$/);
        my $d;
        if ($exp =~ s/^last//) {
                my $l = $map2{$exp};
                my $t = maketime(1, $m, $y);
                for (;;) {
                        my @t = gmtime($t);
                        last if ($t[4] + 1 != $m);
                        $d = $t[3] if ($t[6] + 1 == $l);
                        $t += 3600 * 24;
                }
		return $d;
        }
#	$exp = "$exp>=1" if ($map2{$exp});
        if ($exp =~ s/([<>])\=(\d+)$//) {
                my $val = $2;
                my $neg = ($1 eq "<") ? -1 : 1;
                my $l = $map2{$exp};
                my $t = maketime($val, $m, $y);
                for (;;) {
                        my @t = gmtime($t);
                        return $t[3] if ($t[6] + 1 == $l);
                        $t += 3600 * 24 * $neg;
                }
        }
        die "Unparsable $exp";
}

sub maketime {
        require Time::Local;
        Time::Local::timegm(0, 0, 0, $_[0], $_[1] - 1, $_[2] - 1900);
}

1;
__DATA__