# Timezone/DST code for Date::Set

# Copyright (c) 2003 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::Set::Timezone;

use strict;
# use warnings;
use Carp;
use Date::Set;
use AutoLoader;
use vars qw(
    @ISA $VERSION $AUTOLOAD %Is_Leaf_Subroutine 
);
@ISA = qw( Date::Set Set::Infinite );

$VERSION = 0.05; 

# avoid warnings about 'used only once'
$Date::Set::PRETTY_PRINT = $Date::Set::PRETTY_PRINT;
$Date::Set::too_complex  = $Date::Set::too_complex;

my $inf = 100**100**100;

# ------------ POD --------------

=head1 NAME

Date::Set::Timezone - DEPRECATED - use DateTime::Set - Date set math with timezones and DST

=head1 SYNOPSIS

    use Date::Set::Timezone;

    $a = Date::Set::Timezone->event( at => '20020311Z' );      # 20020311

    # TODO! (see timezone.t for some examples)

=head1 DESCRIPTION

Date::Set::Timezone is a module for date/time sets. It allows you to generate
groups of dates, like "every wednesday", and then find all the dates
matching that pattern. It also allows operations with timezones and 
daylight saving times.

This module is part of the Reefknot project http://reefknot.sf.net

It requires Date::ICal, Set::Infinite, and Date::Set.

It doesn't include timezones definitions.

=cut

# Timezone parameters
#
#    dst => Date::Set::Timezone->new( '20030105Z', '20030115T020000Z' )->complement( '20030115T020000Z' ),
#
# 'dst' is a floating time set that includes all the DST times.
#
# This set is built of local times (it does not have a timezone)
#
#    name => ['STD-1', 'DST-1'],
#
# 'name' is an array containing the standard timezone name and the DST timezone name.
#
#    offset => [ 0, 3600 ],
#
# 'offset' is an array containing the standard timezone offset and the DST timezone offset.
#

# Internal timezone parameters
#
# These parameters are generated by _tz_normalize()
#
#    id => random
#
# A unique tz identifier
#
#    dst_utc => set
#
# A floating time set, representing the 'dst' as seen in UTC context
#

=head1 RELEASE NOTES

=head2 Floating time

Any existing Date::Set or Date::ICal data is interpreted as 
floating time.

=head2 Set data

Data extracted from sets as Date::ICal objects will always come in UTC time.

Floating times are extracted "as-is".

=head2 new()

Parameters to new() must be UTC time (with 'Z' at the end).
They generate floating times, however.

=cut

# ------------ TIMEZONE METHODS --------------

=head1 TIMEZONE METHODS

=head2 tz

Returns the set, translated to another timezone.
It changes the timezone only. Time values are not changed.

    tz( { dst => $new_timezone_set , 
          name => ['STD-1', 'DST-1'], 
          offset => [ 3600, 2*3600 ] } )

This is a function. It doesn't change it's object. It returns a new object.

tz( undef ) returns a set in 'floating time' mode 
(removes timezone info).

There might be conversion errors nearby DST endings because of 'repeated times' when time 'goes back'.

=cut

# internal timezones
# this is the internal "floating time" timezone.
# it is used in the stringification routines only.
my $null_tz = { dst =>    Date::Set::Timezone->new(),
                name =>   [ '', '' ],
                offset => [ 0, 0 ] };

# this is the internal "UTC time" timezone.
my $utc_tz =  { dst =>    Date::Set::Timezone->new(),
                name =>   [ 'Z', '' ],
                offset => [ 0, 0 ] };

sub _valid_tz {
    my $tz = shift;
    return 1 unless defined $tz;
    return 0 unless exists $tz->{dst};
    return 1;
}

sub tz {
    my ($self, $new_tz) = @_;
    # my @caller = caller; print "tz caller @caller\n";
    # carp "invalid timezone" unless _valid_tz( $new_tz );
    if ( $self->is_too_complex ) {
        my $b = $self->_function( 'tz', $new_tz );
        $b->{tz} = $new_tz;
        my @first = $self->first;
        $first[0] = $first[0]->tz( $new_tz ) if defined $first[0];
        $first[1] = $first[1]->_function( 'tz', $new_tz ) if defined $first[1]; 
        $b->{first} = \@first;
        return $b;
    }
    my $res = $self->_tz_change( $new_tz );
    $res->{cant_cleanup} = $self->{cant_cleanup};
    return $res;
}

=head2 tz_change

Moves a set to another timezone.
It changes both the timezone and time values, and adjusts DST.

    tz_change( { dst => $new_timezone_set , 
          name => ['STD-1', 'DST-1'], 
          offset => [ 3600, 2*3600 ] } )

This is a function. It doesn't change it's object. It returns a new object.

tz_change() without a parameter removes the timezone 
information, moving the time back to 'UTC' and 
putting the set in 'floating time' mode.

tz_change() of a 'floating time' does not change time values.

=cut

sub tz_change {
    my ($self, $new_tz) = @_;
    # carp "invalid timezone" unless _valid_tz( $new_tz );
    # my @caller = caller; print "tz_change caller @caller\n";
    if ( $self->is_too_complex ) {
        my $b = $self->_function( 'tz_change', $new_tz );
        $b->{tz} = $new_tz;
        my @first = $self->first;
        $first[0] = $first[0]->tz( $new_tz ) if defined $first[0];
        $first[1] = $first[1]->_function( 'tz_change', $new_tz ) if defined $first[1];
        $b->{first} = \@first;
        return $b;
    }
    if ( ( ! defined $self->{tz} ) || ( ! defined $new_tz ) ) {
        # floating times are just dst-adjusted
        my $res = $self->_tz_change( $new_tz );
        $res->{cant_cleanup} = $self->{cant_cleanup};
        return $res;
    }

    # non-floating times are offset-changed and dst-adjusted

    my $res = $self->copy;
    # carp "tz_change internal setting from " . ( $self->{tz} ? $self->{tz}{name}[0] : "floating time" ). " to " . ( $new_tz ? $new_tz->{name}[0] : "floating time" ) ;
    $res->{tz} = $new_tz;
    return $res;
}

# internal function that changes a set timezone to another timezone
# translating the times:
#    20021010 DST => 20021010 EST
#    20021010Z => 20021010 EST
sub _tz_change {
    my ($self, $new_tz) = @_;

    # my @caller = caller; print "_tz_change caller @caller\n";
    # warn "_tz_change from " . ( $self->{tz} ? $self->{tz}{name}[0] : "floating time" ). " to " . ( $new_tz ? $new_tz->{name}[0] : "floating time" ); # . " plain value is " . $self->SUPER::as_string;

    my $tz = $self->{tz};

    _tz_normalize($tz);
    _tz_normalize($new_tz);
    return $self if ( ! defined $tz && ! defined $new_tz ) || 
                    ( defined $tz && defined $new_tz && $tz->{id} == $new_tz->{id} ); 
    $self = $self->copy;
    $self->{tz} = undef;
    my $result = $self->new();
    $result->{tz} = $new_tz;
    for my $subset ( @{$self->{list}} ) {
            my $interval = $subset;
            if ($tz) {
                    # warn "tz subset ". $subset->{a} . " .. " . $subset->{b} . " ref=" . ref ($tz->{dst}) . " ref=" . ref ($tz->{dst_utc}) . " ofs=@{$tz->{offset}} ";
                    my $min = $subset->{a};
                    my $max = $subset->{b};

                    my $year_min = (ref $min) ? $min->year : Date::Set::ICal->new($min)->year;
                    $tz->{dst_utc_cache}{$year_min} = $tz->{dst_utc}->intersection( $year_min . "0000Z" , ($year_min + 1) . "0000Z" ) unless exists $tz->{dst_utc_cache}{$year_min};
                    my $year_max = (ref $max) ? $max->year : Date::Set::ICal->new($max)->year;
                    $tz->{dst_utc_cache}{$year_max} = $tz->{dst_utc}->intersection( $year_max . "0000Z" , ($year_max + 1) . "0000Z" ) unless exists $tz->{dst_utc_cache}{$year_max};
                    # warn "cache $year = ". $tz->{dst_utc_cache}{$year};

                    # TODO: ++/-- is a bug - we don't have 'integer' sets
                    $min++ if $subset->{open_begin};  # open-begin integer set
                    $max-- if $subset->{open_end};  # open-end integer set
                    my $ofs_min = $tz->{dst_utc_cache}{$year_min}->intersects( $min ) ? 
                        $tz->{offset}[1] : $tz->{offset}[0];
                    my $ofs_max = $tz->{dst_utc_cache}{$year_max}->intersects( $max ) ? 
                        $tz->{offset}[1] : $tz->{offset}[0];
                    $interval = { a => $subset->{a} + $ofs_min, 
                                b => $subset->{b} + $ofs_max, 
                                open_begin => $subset->{open_begin}, 
                                open_end => $subset->{open_end} };
            }
            if ($new_tz) {
                    # warn "new_tz subset ". $interval->{a} . " .. " . $interval->{b} . " ref=" . ref ($new_tz->{dst}) . " ref=" . ref ($new_tz->{dst_utc})  . " ofs=@{$new_tz->{offset}}";
                    my $min = $interval->{a};
                    my $max = $interval->{b};
                    my $year_min = (ref $min) ? $min->year : Date::Set::ICal->new($min)->year;
                    $new_tz->{dst_cache}{$year_min} = $new_tz->{dst}->intersection( $year_min . "0000Z" , ($year_min + 1) . "0000Z" ) unless exists $new_tz->{dst_cache}{$year_min};
                    my $year_max = (ref $max) ? $max->year : Date::Set::ICal->new($max)->year;
                    $new_tz->{dst_cache}{$year_max} = $new_tz->{dst}->intersection( $year_max . "0000Z" , ($year_max + 1) . "0000Z" ) unless exists $new_tz->{dst_cache}{$year_max};
                    # TODO: ++/-- is a bug - we don't have 'integer' sets
                    $min++ if $interval->{open_begin};  # open-begin integer set
                    $max-- if $interval->{open_end};  # open-end integer set
                    my $ofs_min = $new_tz->{dst_cache}{$year_min}->intersects( $min ) ?
                        $new_tz->{offset}[1] : $new_tz->{offset}[0];
                    my $ofs_max = $new_tz->{dst_cache}{$year_max}->intersects( $max ) ?
                        $new_tz->{offset}[1] : $new_tz->{offset}[0];
                    $interval = { a => $interval->{a} - $ofs_min,
                                b => $interval->{b} - $ofs_max,
                                open_begin => $interval->{open_begin},
                                open_end => $interval->{open_end} };
            }
            push @{$result->{list}}, $interval; 
    }
    # $result->{tz} = $new_tz;  # if defined $new_tz;

    # warn "/_tz_change"; # got ". $result->SUPER::as_string ." from ". $self->SUPER::as_string;

    return $result;
}

sub _tz_normalize {
    my $tz = shift;
    return unless $tz;
    return if exists $tz->{id};
    carp "invalid timezone" unless _valid_tz( $tz );
    # TODO: check for repeated ids
    $tz->{id} = rand;

    # moves DST definition to UTC
    # unless ( exists $tz->{dst_utc} ) {
        # warn "creating {dst_utc}";
        # print "tz is undef\n" unless defined $tz;
        # print "tz is ",join(" ", %$tz)," =", ref($tz),"\n";
        $tz->{dst_utc} = $tz->{dst}->offset( unit=>'seconds', value=> [-$tz->{offset}[0], -$tz->{offset}[1]] );
        ## $tz->{dst_utc}{tz} = $utc_tz;
        # $tz->{dst_utc} = $tz->{dst_utc}->tz( undef );
        # print "created tz->dst_utc ", $tz->{dst_utc},"\n";
        # warn "/creating";
    # }
}

# ------------ Set::Infinite "INHERITED" METHODS --------------

# we call this section DATE::SET METHODS because we actually
# inherit Date::Set first.

=head1 DATE::SET METHODS

=head2 new

new() behaves differently from Date::Set::new() in that:

    $new_set = $set->new();

$new_set receives $set timezone info.

=cut

# new() parameters always need a 'Z' at the end!
# use tz() to redefine the timezone
sub new {
    my $class = shift;
    my $class_name = ref( $class ) || $class;
    my $self;
    if ( defined $_[0] && UNIVERSAL::isa( $_[0], $class_name ) ) {
        $self = $_[0]->copy;
    }
    else {
        $self = $class->SUPER::new(@_);
        bless $self, ( ref( $class ) || $class );
        $self->{tz} = undef;  # default is floating time
    }
    # 'translate' the timezone to parent's $tz
    if ( ref( $class ) ) {
        # warn "new from object, with timezone" if defined $class->{tz};
        # warn "new from object, floating time" unless defined $class->{tz};

        $self = $self->tz_change( $class->{tz} ) if defined $class->{tz};
    }
    else {
        # default timezone is... ?  
        # ...floating time.

        # warn "new from class, floating time";
        # $self->{tz} = undef;
    }

    return $self;
}

=head2 as_string

as_string() behaves differently from Date::Set::as_string() in that
it prints timezone/DST info.

=cut

# (removed) If supplied with a timezone argument, as_string() stringifies the times under that timezone. 
# (removed) as_string(undef) stringifies the set as floating times. 

# returns a stringified set with timezones/dst
# as_string accepts a timezone as parameter.
# default timezone is self->{tz}
# 'undef' timezone is 'local time'
## our $in_string = 0;

sub as_string {
    # warn "as_string";
    # return if $in_string;
    # $in_string++;
    my ($self) = @_;
    my $tz;
    my $s;
    $tz = $self->{tz};
    $tz = $null_tz unless defined $tz;
    # print " $#_ - $_[-1] - tz is " . ( $tz ? $tz : 'undef' ) . "\n";

    # unless (defined $tz) {
    #    # print "* no tz \n";
    #    return Set::Infinite::as_string($self);
    # }

    # print "* tz \n";

    # we need to move our DST definition to UTC
    _tz_normalize($tz);

    # warn "as_string: super is ". $self->SUPER::as_string;

    return ( $Date::Set::PRETTY_PRINT ? $self->_pretty_print : $Date::Set::too_complex ) if $self->{too_complex};
    $self->cleanup;
    # warn "LIST = @{$self->{list}}";
    $s = join( Set::Infinite->separators(5), map { _simple_as_string($_, $tz) } @{$self->{list}} );
    # warn "/as_string";
    return $s;
 }

sub _format_tz {
    my ($datetime, $tzname) = @_;
    $datetime =~ s/Z$//;
    if ($tzname) {
        $datetime .= ';' unless length($tzname) == 1;
        $datetime .= $tzname;
    }
    return $datetime;
}

sub _simple_as_string {
    my ($self, $tz) = @_;
    my $s;
    # print " [simple:string] ";

    return "" unless defined $self;

    unless ( ref($self) eq 'HASH' ) {
        warn "ERROR stringify needs a hashref, got ". ref($self). " = $self";
        return "ERROR";
    }

    $self->{open_begin} = 1 if ($self->{a} == -$Date::Set::inf );
    $self->{open_end}   = 1 if ($self->{b} == $Date::Set::inf );

    my $tmp1 = $self->{a};
    my $s1;
    if (($tmp1 == $inf) || ($tmp1 == -$inf)) {
        $s1 = "$tmp1";
    }
    else {
        my $year_min = (ref $tmp1) ? $tmp1->year : Date::Set::ICal->new($tmp1)->year;
        $tz->{dst_utc_cache}{$year_min} = $tz->{dst_utc}->intersection( $year_min . "0000Z" , ($year_min + 1) . "0000Z" ) unless exists $tz->{dst_utc_cache}{$year_min};
        my $dst1 = $tz->{dst_utc_cache}{$year_min}->intersects( $tmp1 ) ? 1 : 0;
        $s1 = _format_tz( Date::Set::ICal->new( $tmp1 + $tz->{offset}[$dst1] ), $tz->{name}[$dst1] );
    }

    my $tmp2 = $self->{b};
    if ($tmp1 == $tmp2) {
        return $s1;
    }
    # $tmp1 = "$tmp1";
    # $tmp2 = "$tmp2";
    my $s2;
    # warn "print $tmp2 -- $inf";
    if (($tmp2 == $inf) || ($tmp2 == -$inf)) {
        $s2 = "$tmp2";
    }
    else {
        my $year_max = (ref $tmp2) ? $tmp2->year : Date::Set::ICal->new($tmp2)->year;
        $tz->{dst_utc_cache}{$year_max} = $tz->{dst_utc}->intersection( $year_max . "0000Z", ($year_max + 1) . "0000Z" ) unless exists $tz->{dst_utc_cache}{$year_max};
        my $dst2 = $tz->{dst_utc_cache}{$year_max}->intersects( $tmp2 ) ? 1 : 0;
        $s2 = _format_tz( Date::Set::ICal->new( $tmp2 + $tz->{offset}[$dst2] ), $tz->{name}[$dst2] );
    }
    $s = $self->{open_begin} ? Set::Infinite->separators(2) : Set::Infinite->separators(0);
    $s .= $s1 . Set::Infinite->separators(4) . $s2 ;
    $s .= $self->{open_end} ? Set::Infinite->separators(3) : Set::Infinite->separators(1);
    return $s;
}

=head2 offset

offset() behaves differently from Date::Set::offset() in that
times are adjusted for timezone/DST.

offset() operates in 'local time' mode. If you need 'UTC time'
you should move the set to UTC using tz_change(), then offset() it.

=cut

# REMOVED:
# Parameter 'utc' specifies how the offset should be 
# calculated:
#    utc => 1  # uses UTC time
#    utc => 0  # (default) uses clock time (local time); adjusts for timezone/DST

# units that default to 'utc'=>0
# my %_utc_offset = ( years => 0, months => 0, days => 0, weeks => 0, hours => 0, weekdays => 0 );

sub offset {
    my ($self, %param) = @_;
    # duration of days or bigger across a DST change needs a UTC translation
    my $utc = 0;  # $param{utc};
    # $utc = $_utc_offset{$param{unit}} if exists $param{unit} && ! defined $utc;
    # $utc = 1 unless defined $utc;
    my $translated = 0;
    # warn " offset utc=>$utc";
    my $tz = $self->{tz};
    # warn "    tz is @{$tz->{name}}" if $tz; 
    if ( defined( $tz ) && $utc == 0 ) {
    # if ( $utc == 0 ) {
        $translated = 1;
        # warn "    translate";
        $self = $self->tz ( undef );  # translate time to 'local time' value
        # warn "    translate - done";
    }
    else {
        # warn "    UTC time";
    }
    # warn "    offsetting ".$self->SUPER::as_string;
    $self = $self->SUPER::offset( %param );
    # warn "    got ".$self->SUPER::as_string;
    if ($translated) {
        # warn "    translate back";
        $self = $self->tz( $tz );
        # warn "    /translate";
    }
    # $self = $self->tz( $tz );
    # warn " /offset ";
    return $self;
}

=head2 quantize

quantize() behaves differently from Date::Set::quantize() in that
times are adjusted for timezone/DST.

quantize() operates in 'local time' mode. If you need 'UTC time'
you should move the set to UTC using tz_change(), then quantize() it.

=cut

# REMOVED:
# Parameter 'utc' specifies how the offset should be calculated:
#    utc => 1  # uses UTC time
#    utc => 0  # (default) uses clock time (local time); adjusts for timezone/DST

sub quantize {
    my ($self, %param) = @_;
    # duration of days or bigger across a DST change needs a UTC translation
    my $utc = 0;  # $param{utc};
    # $utc = $_utc_offset{$param{unit}} if exists $param{unit} && ! defined $utc;
    # $utc = 1 unless defined $utc;
    my $translated = 0;
    # warn " quantize utc=>$utc";
    # print " offset: @_ \n";
    my $tz = $self->{tz};
    if ( defined( $tz ) && $utc == 0 ) {
    # if ( $utc == 0 ) {
        $translated = 1;
        $self = $self->tz ( undef );  # translate time to 'local time' value
    }
    # warn "quantize UTC=". $self->SUPER::as_string;
    $self = $self->SUPER::quantize( %param );
    # warn "quantize got UTC=". $self->SUPER::as_string;
    if ($translated) {
        $self = $self->tz( $tz );
        # warn "    /translate";
    }
    # $self = $self->tz( $tz );
    # warn " /quantize";
    return $self;
}

=head2 union, intersection, complement, until, contains, intersects

These methods behave differently from Date::Set in that
resulting times are adjusted for timezone/DST.

=cut

# NOTE: complement() -- no correction needed!
# NOTE: contains() -- no correction needed!

sub union {
    my $a1 = shift;
    my $b1 = UNIVERSAL::isa( $_[0], ref $a1 ) ? $_[0] : $a1->new( @_ );
    $b1 = $b1->tz_change( $a1->{tz} ); 
    return $a1->SUPER::union($b1);
}

sub intersection {
    my $a1 = shift;
    my $b1 = UNIVERSAL::isa( $_[0], ref $a1 ) ? $_[0] : $a1->new( @_ );
    $b1 = $b1->tz_change( $a1->{tz} );
    return $a1->SUPER::intersection($b1);
}

sub intersects {
    my $a1 = shift;
    my $b1 = UNIVERSAL::isa( $_[0], ref $a1 ) ? $_[0] : $a1->new( @_ );
    $b1 = $b1->tz_change( $a1->{tz} );
    return $a1->SUPER::intersects($b1);
}

sub until {
    my $a1 = shift;
    my $b1 = UNIVERSAL::isa( $_[0], ref $a1 ) ? $_[0] : $a1->new( @_ );
    $b1 = $b1->tz_change( $a1->{tz} );
    return $a1->SUPER::until($b1);
}

# ------------ Date::Set "INHERITED" METHODS --------------

# none.

#---------------

# define DESTROY so we don't call AUTOLOAD
sub DESTROY {}

# This is experimental code, originally developed for DateTime::Set:
#
# If I can't do something, I check if the first 'leaf' can do it.
# For example:
#   $set_10 = $set->add( seconds => 10 );
# is a shortcut to:
#   $set_10 = $set->new( $set->min->add( seconds => 10 ) );
#

my %Is_Leaf_Subroutine = (
    add => 1,
    # clone() is a function
    # ical() is a function
);

sub AUTOLOAD {
    if ( $AUTOLOAD =~ /.*::(.*?)$/ ) {
        my $sub = $1;
        my $self = shift;
        my $leaf = $self->min;  # get first leaf

        # get over the memoization
        $leaf = $leaf->date_ical if UNIVERSAL::can( $leaf, 'date_ical');
        # warn "leaf is a '". ref( $leaf ) . "'";

        # warn "leaf value is ". $leaf->ical ." is a '". ref( $leaf ). "' sub is '". $sub. "' param @_";
        if ( UNIVERSAL::can( $leaf, $sub ) ) {
            # we have different calling modes in leaf class - that's bad.
            if (exists $Is_Leaf_Subroutine{$sub} ) {
                # calling mode is 'subroutine'
                $leaf = $leaf->clone;
                $leaf->$sub(@_);
                # warn "sub result is ". $leaf->ical ." ";
            }
            else {
                # calling mode is 'function'
                $leaf = $leaf->$sub(@_);
                # warn "function result is ". $leaf;
            }
            # warn "result is a '". ref( $leaf ) . "'";
            $leaf = $self->new($leaf) if ref($leaf) eq 'Date::ICal';
            return $leaf;
        }
        Carp::croak( __PACKAGE__ . $AUTOLOAD . " is malformed in AUTOLOAD" );
    } 
    else {
        Carp::croak( __PACKAGE__ . $AUTOLOAD . " is malformed in AUTOLOAD" );
    }
    # warn "no autoloading for $AUTOLOAD";
}

#---------------

=head1 AUTHOR

Flavio Soibelmann Glock <fglock@pucrs.br> 

Thanks to Martijn van Beers for help with testing, examples, and API discussions.

=cut

1;

__END__

