Date::ICal - Perl extension for ICalendar date objects.

    use Date::ICal;

    $ical = Date::ICal->new( ical => '19971024T120000' );
    $ical = Date::ICal->new( epoch => time );
    $ical = Date::ICal->new( year => 1964,
        month => 10, day => 16, hour => 16,
        min => 12, sec => 47 );

    $hour = $ical->hour;
    $year = $ical->year;

    $ical_string = $ical->ical;
    $epoch_time = $ical->epoch;

    $ical2 = $ical + $duration;

    $ical += 'P6DT12H';

    $duration = $ical1 - $ical2;
    $ical3 = $ical1 - $duration;

    my $ical = Date::ICal->new( ical => '19971024T120000' );
    # will default to the timezone specified in $TZ, see below

    my $ical = Date::ICal->new( epoch => time );

    my $date = Date::ICal->new( 
                           day => 25, 
                           month => 10, 
                           year => 1066,
                           hour => 7,
                           min => 15,
                           sec => 47
                           );

    my $ical = Date::ICal->new();

   # Direct conversion from Discordian to ISO dates
   my $disco = Date::Discordian->new( disco => '12 Chaos, YOLD 3177' );
   my $iso = Date::ISO->new( $disco );
   print $iso->iso;

    my $ical = Date::ICal->new( ical => '19971024T120000',
                                offset => "-0800");

    $ical_string = $ical->ical;

    $ical_string = $ical->ical( localtime => 1 );

    $ical_string = $ical->ical( offset => '+0545' );

    $epoch_time = $ical->epoch;

    $ical->epoch( 98687431 );

    $seconds_plus_or_minus = offset_to_seconds($offset);

    $seconds_plus_or_minus = offset_from_seconds($offset_in_seconds);

    $offset = $ical->offset;

    # We need tests for these.  
    $ical->offset( '+1100' ); # a number of hours and minutes: UTC+11
    $ical->offset( 0 );       # reset to UTC

    my $d = new(ical=>'19700101120000', offset=>'+0100'); 

    $d->offset('+0200'); 

    $self->add( year => 3, month => 2, week => 1, day => 12,
                hour => 1, minute => 34, sec => 59 );
    $date->add( duration => 'P1WT1H1M1S' ); # add 1 wk, 1 hr, 1 min, and 1 sec

    $ical->add( 'minute' ); # add a minute

    $date = $date1 + $duration;

    $date += 'P2DT4H7M';

  $duration = $date1 - $date2;

    $d = $date1 - $X;

    $week = $d->weeks; # how many weeks apart?
    $days = $d->as_days; # How many days apart?

    $newdate = $date - $duration; 

    $copy = $date->clone;

    $cmp = $date1->compare($date2);

    @dates = sort {$a->compare($b)} @dates;

    my $day = $date->day;

    my $month = $date->month;

    my $year = $date->year;

    ($year, $month, $day) = jd2greg( $jd );

    Convert number of days on or after Jan 1, 1 CE (Gregorian) to
    gregorian year,month,day.

    $jd = greg2jd( $year, $month, $day );

    Convert gregorian year,month,day to days on or after Jan 1, 1 CE
    (Gregorian).  Normalization is performed (e.g. month of 28 means
    April two years after given year) for month < 1 or > 12 or day < 1
    or > last day of month.

  $yday = Date::ICal::days_this_year($day, $month, $year);

    my $day_of_week = $date->day_of_week

    my $hour = $date->hour

    my $min = $date->min;

    my $sec = $date->sec;

  my $jd = $date->jd;

# $Rev: 649 $
package Date::ICal;
use strict;

use vars qw($VERSION $localzone $localoffset @months @leapmonths %add_units);
$VERSION = '2.'.(qw'$Rev: 649 $')[1];
use Carp;
use Time::Local;
use Date::Leapyear qw();
use Date::ICal::Duration;
use overload '<=>' => 'compare',
             'fallback' => 1,
             '-' => \&subtract,
             '+' => \&add_overload;

$localzone   = $ENV{TZ} || 0;
$localoffset = _calc_local_offset();

# Documentation {{{

#}}}

#{{{ sub new

sub new {
    my $class = shift;
    my ( $self, %args, $sec, $min, $hour, $day, $month, $year, $tz );

    # $zflag indicates whether or not this time is natively in UTC    
    my $zflag = 0;

    # First argument can be a Date::ICal (or subclass thereof) object
    if ( ref $_[0] ) {
        $args{ical} = $_[0]->ical;
      } else {
        %args = @_;
    }

    $self = {};

    # Date is specified as epoch#{{{
    if ( defined( $args{epoch} ) ) {

        ( $sec, $min, $hour, $day, $month, $year ) =
          ( gmtime( $args{epoch} ) )[ 0, 1, 2, 3, 4, 5 ];
        $year += 1900;
        $month++;

        $zflag = 1;    # epoch times are by definition in GMT
    }    #}}}

    # Date is specified as ical string#{{{
    elsif ( defined( $args{ical} ) ) {

        # Timezone, if any
        $args{ical} =~ s/^(?:TZID=([^:]+):)?//;
        $tz = $1;

        # Split up ical string
        ( $year, $month, $day, $hour, $min, $sec, $zflag ) =
          $args{ical} =~ /^(?:(\d{4})(\d\d)(\d\d))
                              (?:T(\d\d)?(\d\d)?(\d\d)?)?
                                                  (Z)?$/x;

        # TODO: figure out what to do if we get a TZID. 
        # I'd suggest we store it for use by modules that care
        # about TZID names. But we don't want this module
        # to deal with timezone names, only offsets, I think.
        # --srl

    }    #}}}

    # Time specified as components#{{{
    elsif ( defined( $args{day} ) ) {

        # Choke if missing arguments
        foreach my $attrib(qw(day month year )) {
            warn "Attribute $attrib required" unless defined $args{$attrib};
        }
        foreach my $attrib(qw( hour min sec )) {
            $args{$attrib} = 0 unless defined $args{$attrib};
        }

        # And then just use what was passed in
        ( $sec, $min, $hour, $day, $month, $year ) =
          @args{ 'sec', 'min', 'hour', 'day', 'month', 'year' };

    }    #}}}

    else {    # Just use current gmtime#{{{

        # Since we are defaulting, this qualifies as UTC
        $zflag = 1;

        ( $sec, $min, $hour, $day, $month, $year ) = ( gmtime(time) )[ 0 .. 5 ];
        $year += 1900;
        $month++;
    }    #}}}

    $self->{julian} = greg2jd( $year, $month, $day );
    $self->{julsec} = time_as_seconds( $hour, $min, $sec );
    bless $self, $class;

    if ( exists( $args{offset} ) ) {
        # We should complain if they're trying to set a non-UTC
        # offset on a time that's inherently UTC.  -jv
        if ($zflag && ($args{offset} != 0)) {
            carp "Time had conflicting offset and UTC info. Using UTC"
              unless $ENV{HARNESS_ACTIVE};
          } else {

            # Set up the offset for this datetime.
            $self->offset( $args{offset} || 0 );
        }
      } elsif ( !$zflag ) {

        # Check if the timezone has changed since the last time we checked.
        # Apparently this happens on some systems. Patch from Mike
        # Heins. Ask him.
        my $tz  = $ENV{TZ} || '0';
        my $loc = $tz eq $localzone ? $localoffset : _calc_local_offset();
        $self->offset($loc) if defined $self;
    }

    return $self;
}

#}}}

#{{{ sub ical

sub ical {
    my $self = shift;
    if ( 1 & @_ ) {     # odd number of parameters?
        carp "Bad args: expected named parameter list";
        shift;    # avoid warning from %args=@_ assignment
    }
    my %args = @_;
    my $ical;

    if ( exists $args{localtime} ) {
        carp "can't have localtime and offset together, using localtime offset"
          if exists $args{offset};

        # make output in localtime format by setting $args{offset}
        $args{offset} = $self->offset;
    }

    if ( exists $args{offset} ) {

        # make output based on an arbitrary offset
        # No Z on the end!
        my $julian = $self->{julian};
        my $julsec = $self->{julsec};
        my $adjust = offset_to_seconds( $args{offset} );
        $self->add( seconds => $adjust );
        $ical =
          sprintf( '%04d%02d%02dT%02d%02d%02d', $self->year, $self->month,
          $self->day, $self->hour, $self->minute, $self->second, );
        $self->{julian} = $julian;
        $self->{julsec} = $julsec;
      } else {

        # make output in UTC by default
        # if we were originally given this time in offset
        # form, we'll need to adjust it for output
        if ( $self->hour || $self->min || $self->sec ) {
            $ical =
              sprintf( '%04d%02d%02dT%02d%02d%02dZ', $self->year, $self->month,
              $self->day, $self->hour, $self->minute, $self->second );
          } else {
            $ical =
              sprintf( '%04d%02d%02dZ', $self->year, $self->month, $self->day );
        }
    }

    return $ical;
}    #}}}

#{{{ sub epoch

sub epoch {
    my $self  = shift;
    my $class = ref($self);

    my $epoch;

    if ( $epoch = shift ) {    # Passed in a new value

        my $newepoch = $class->new( epoch => $epoch );
        $self->{julian} = $newepoch->{julian};
        $self->{julsec} = $newepoch->{julsec};

    }

    else {    # Calculate epoch from components, if possible

        $epoch =
          timegm( $self->sec, $self->min, $self->hour, $self->day,
          ( $self->month ) - 1, ( $self->year ) - 1900 );
    }

    return $epoch;
}

#}}}

#{{{ sub offset_to_seconds

sub offset_to_seconds {
    my $offset = shift;

    # Relocated from offset for re-use
    my $newoffset;

    if ( $offset eq '0' ) {
        $newoffset = 0;
      } elsif ( $offset =~ /^([+-])(\d\d)(\d\d)\z/ )
    {
        my ( $sign, $hours, $minutes ) = ( $1, $2, $3 );

        # convert to seconds, ignoring the possibility of leap seconds
        # or daylight-savings-time shifts
        $newoffset = $hours * 60 * 60 + $minutes * 60;
        $newoffset *= -1 if $sign eq '-';
      } else {
        carp("You gave an offset, $offset, that makes no sense");
        return undef;
    }
    return $newoffset;
}

#}}}

#{{{ sub offset_from_seconds

sub offset_from_seconds {
    my $secoffset  = shift;
    my $hhmmoffset = 0;

    if ( $secoffset ne '0' ) {
        my ( $sign, $secs ) = ( "", "" );
        ( $sign, $secs ) = $secoffset =~ /([+-])?(\d+)/;

        # throw in a + to make this look like an offset if positive
        $sign = "+" unless $sign;

        # NOTE: the following code will return "+0000" if you give it a number
        # of seconds that are a multiple of a day. However, for speed reasons
        # I'm not going to write in a comparison to reformat that back to 0.
        # 
        my $hours = $secs / ( 60 * 60 );
        $hours = $hours % 24;
        my $mins = ( $secs % ( 60 * 60 ) ) / 60;
        $hhmmoffset = sprintf( '%s%02d%02d', $sign, $hours, $mins );

    }

    return $hhmmoffset;
}

#}}}

#{{{ sub offset

sub offset {
    my ( $self, $offset ) = @_;
    my $newoffset = undef;

    if ( defined($offset) ) {    # Passed in a new value
        $newoffset = offset_to_seconds($offset);

        unless ( defined $newoffset ) { return undef; }

        # since we're internally storing in GMT, we need to
        # adjust the time we were given by the offset so that
        # the internal date/time will be right.

        if ( $self->{offset} ) {

            # figure out whether there's a difference between
            # the existing offset and the offset we were given.
            # If so, adjust appropriately.
            my $offsetdiff = $self->{offset} - $newoffset;

            if ($offsetdiff) {
                $self->{offset} = $newoffset;
                $self->add( seconds => $offsetdiff );
              } else {

                # leave the offset the way it is
            }
          } else {
            $self->add( seconds => -$newoffset );
            $self->{offset} = $newoffset;
        }

      } else {
        if ( $self->{offset} ) {
            $offset = offset_from_seconds( $self->{offset} );
          } else {
            $offset = 0;
        }
    }

    return $offset;
}

#}}}

# sub add {{{

sub add {
    my $self = shift;
    carp "Date::ICal::add was called without an attribute arg" unless @_;
    ( $self->{julian}, $self->{julsec}) =
        _add($self->{julian}, $self->{julsec}, @_);
    return $self;
}

#}}}

# sub _add {{{

# for each unit, specify what it changes by (0=day, 1=second, 2=month)
# and by what factor

%add_units = (year=>[2,12], month=>[2,1], week=>[0,7], day=>[0,1],
              hour=>[1,3600], min=>[1,60], sec=>[1,1], seconds=>[1,1]);

sub _add {
    my ($jd, $secs) = splice(@_, 0, 2);
    my $eom_mode = 0;
    my ($add, $unit, $count);

    # loop through unit=>count parameters
    while (($unit, $count) = splice(@_, 0, 2)) {

        if ($unit eq 'duration') { # add a duration string
            my %dur;
            @dur{'day','sec','month'} = duration_value($count);

            # pretend these were passed to us as e.g. month=>1, day=>1, sec=>1.
            # since months/years come first in the duration string, we
            # put them first.
            unshift @_, map $dur{$_} ? ($_,$dur{$_}) : (),
                            'month', 'day', 'sec';
            next;
        } elsif ($unit eq 'eom_mode') {
            if ($count eq 'wrap') { $eom_mode = 0 }
            elsif ($count eq 'limit') { $eom_mode = 1 }
            elsif ($count eq 'preserve') { $eom_mode = 2 }
            else { carp "Unrecognized eom_mode, $count, ignored" }
        } else {
            unless ($add = $add_units{$unit}) {
                carp "Unrecognized time unit, $unit, skipped";
                next;
            }

            $count = 1 if !defined $count; # count defaults to 1
            $count *= $add->[1]; # multiply by the factor for this unit

            if ($add->[0] == 0) { # add to days
                $jd += $count;
            } elsif ($add->[0] == 1) { # add to seconds
                $secs += $count;
            } else {            # add to months
                my ($y, $mo, $d);

                _normalize_seconds( $jd, $secs );
                if ($eom_mode == 2) { # sticky eom mode
                    # if it is the last day of the month, make it the 0th
                    # day of the following month (which then will normalize
                    # back to the last day of the new month).
                    ($y, $mo, $d) = jd2greg( $jd+1 );
                    --$d;
                } else {
                    ($y, $mo, $d) = jd2greg( $jd );
                }

                if ($eom_mode && $d > 28) { # limit day to last of new month
                    # find the jd of the last day of our target month
                    $jd = greg2jd( $y, $mo+$count+1, 0 );

                    # what day of the month is it? (discard year and month)
                    my $lastday = scalar jd2greg( $jd );

                    # if our original day was less than the last day,
                    # use that instead
                    $jd -= $lastday - $d if $lastday > $d;
                } else {
                    $jd = greg2jd( $y, $mo+$count, $d );
                }
            }
        }
    }

    _normalize_seconds( $jd, $secs );
}

#}}}

# sub add_overload {{{

sub add_overload {
    my $one = shift;
    my $two = shift;

    my $ret = $one->clone;

    if ( ref $two ) {
        $ret->add( duration => $two->as_ical );
    } else {
        $ret->add( duration => $two );
    }

    return $ret;
} # }}}

# sub _normalize_seconds {{{

sub _normalize_seconds {
    my $adj;

    if ($_[1] < 0) {
        $adj = int( ($_[1]-86399)/86400 );
    } else {
        $adj = int( $_[1]/86400 );
    }
    ($_[0] += $adj), ($_[1] -= $adj*86400);
}

#}}}

# sub duration_value {{{

sub duration_value {
    my $str = shift;

    my @temp = $str =~ m{
                        ([\+\-])?   (?# Sign)
                        (P)     (?# 'P' for period? This is our magic character)
                        (?:
                                (?:(\d+)Y)? (?# Years)
                                (?:(\d+)M)? (?# Months)
                                (?:(\d+)W)? (?# Weeks)
                                (?:(\d+)D)? (?# Days)
                        )?
                        (?:T        (?# Time prefix)
                                (?:(\d+)H)? (?# Hours)
                                (?:(\d+)M)? (?# Minutes)
                                (?:(\d+)S)? (?# Seconds)
                        )?
                                }x;
    my ( $sign, $magic ) = @temp[ 0 .. 1 ];
    my ( $years, $months, $weeks, $days, $hours, $mins, $secs ) =
      map { defined($_) ? $_ : 0 } @temp[ 2 .. $#temp ];

    unless ( defined($magic) ) {
        carp "Invalid duration: $str";
        return undef;
    }
    $sign = ( ( defined($sign) && $sign eq '-' ) ? -1 : 1 );

    my $s = $sign * ( $secs + ( $mins * 60 ) + ( $hours * 3600 ) );
    my $d = $sign * ( $days + ( $weeks * 7 ) );
    my $m = $sign * ( $months + ( $years * 12 ) );
    return ( $d, $s, $m );
}

#}}}

# sub subtract {{{

sub subtract {
    my ( $date1, $date2, $reversed ) = @_;
    my $dur;

    # If the order of the arguments was reversed, overload tells us
    # about it in the third argument.
    if ($reversed) {
        ( $date2, $date1 ) = ( $date1, $date2 );
    }

    if (ref $date1 && ref $date2) {
    # If $date1 is a Date::ICal object, and $date2 is a Duration object,
    # then we should subtract and get a date.
        if ((ref $date2) eq 'Date::ICal::Duration') {
            my $seconds = $date2->as_seconds;
            my $ret = $date1->clone;
            $ret->add( seconds => -1 * $seconds );
            return $ret;

        } else {
    # If $date2 is a Date::ICal object, or some class thereof, we should
    # subtract and get a duration

            my $days = $date1->{julian} - $date2->{julian};
            my $secs = $date1->{julsec} - $date2->{julsec};

            return Date::ICal::Duration->new(
              days    => $days,
              seconds => $secs
            );
        } 
    } elsif ( ref $date1 && 
              ( $dur = Date::ICal::Duration->new( ical => $date2 ) )
            ) {
    # If $date1 is a Date::ICal object, and $date2 is a duration string,
    # we should subtract and get a date
        return $date1 - $dur; # Is that cheating?

    # Otherwise, we should call them nasty names and return undef
    } else {
        warn "Moron";
        return;
    }

} # }}}

# sub clone {{{

sub clone {
    my $self = shift;
    my $class = ref $self;
    my %hash = %$self;
    my $new = \%hash;
    bless $new, $class;
    return $new;
} # }}}

# sub compare {{{

sub compare {
    my ( $self, $otherdate ) = (@_);

    unless ( defined($otherdate) ) { return undef }

    # One or more days different

    if ( $self->{julian} < $otherdate->{julian} ) {
        return -1;
      } elsif ( $self->{julian} > $otherdate->{julian} )
    {
        return 1;

        # They are the same day
      } elsif ( $self->{julsec} < $otherdate->{julsec} )
    {
        return -1;
      } elsif ( $self->{julsec} > $otherdate->{julsec} )
    {
        return 1;
    }

    #    # if we got all this way and haven't yet returned, the units are equal.
    return 0;
}

#}}}

# internal stuff {{{

# precalculate these values at module load time so that we don't
# have to do it repeatedly during runtime. 
# 
BEGIN {

    #           +  31, 28, 31, 30,  31,  30,  31,  31,  30,  31,  30,  31
    @months = ( 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 );
    @leapmonths = @months;

    for ( 2 .. 12 ) {
        $leapmonths[$_] = $months[$_] + 1;
    }
}

sub months {
    return Date::Leapyear::isleap(shift) ? @leapmonths : @months;
}

# }}}

# sub time_as_seconds {{{

sub time_as_seconds {
    my ( $hour, $min, $sec ) = @_;

    $hour ||= 0;
    $min ||= 0;
    $sec ||= 0;

    my $secs = $hour * 3600 + $min * 60 + $sec;
    return $secs;
} #}}}

# sub day {{{

sub day {
    my $self = shift;
    return ( jd2greg( $self->{julian} ) )[2];
} # }}}

# sub month {{{

sub month {
    my $self = shift;
    return ( jd2greg( $self->{julian} ) )[1];
} # }}}

# sub mon {{{

sub mon { return month(@_); }

#}}}

# sub year {{{

sub year {
    my $self = shift;
    return ( jd2greg( $self->{julian} ) )[0];
} # }}}

# sub jd2greg {{{

sub jd2greg {
    use integer;
    my $d = shift;
    my $yadj = 0;
    my ( $c, $y, $m );

    # add 306 days to make relative to Mar 1, 0; also adjust $d to be within
    # a range (1..2**28-1) where our calculations will work with 32bit ints
    if ( $d > 2**28 - 307 ) {

        # avoid overflow if $d close to maxint
        $yadj = ( $d - 146097 + 306 ) / 146097 + 1;
        $d -= $yadj * 146097 - 306;
      } elsif ( ( $d += 306 ) <= 0 )
    {
        $yadj =
          -( -$d / 146097 + 1 );    # avoid ambiguity in C division of negatives
        $d -= $yadj * 146097;
    }

    $c =
      ( $d * 4 - 1 ) / 146097;    # calc # of centuries $d is after 29 Feb of yr 0
    $d -= $c * 146097 / 4;    #     (4 centuries = 146097 days)
    $y = ( $d * 4 - 1 ) / 1461;    # calc number of years into the century,
    $d -= $y * 1461 / 4;    #     again March-based (4 yrs =~ 146[01] days)
    $m =
      ( $d * 12 + 1093 ) / 367;    # get the month (3..14 represent March through
    $d -= ( $m * 367 - 1094 ) / 12;    #     February of following year)
    $y += $c * 100 + $yadj * 400;    # get the real year, which is off by
    ++$y, $m -= 12 if $m > 12;         #     one if month is January or February
    return ( $y, $m, $d );
}    #}}}

# sub greg2jd {{{

sub greg2jd {
    use integer;
    my ( $y, $m, $d ) = @_;
    my $adj;

    # make month in range 3..14 (treat Jan & Feb as months 13..14 of prev year)
    if ( $m <= 2 ) {
        $y -= ( $adj = ( 14 - $m ) / 12 );
        $m += 12 * $adj;
      } elsif ( $m > 14 )
    {
        $y += ( $adj = ( $m - 3 ) / 12 );
        $m -= 12 * $adj;
    }

    # make year positive (oh, for a use integer 'sane_div'!)
    if ( $y < 0 ) {
        $d -= 146097 * ( $adj = ( 399 - $y ) / 400 );
        $y += 400 * $adj;
    }

    # add: day of month, days of previous 0-11 month period that began w/March,
    # days of previous 0-399 year period that began w/March of a 400-multiple
    # year), days of any 400-year periods before that, and 306 days to adjust
    # from Mar 1, year 0-relative to Jan 1, year 1-relative (whew)

    $d += ( $m * 367 - 1094 ) / 12 + $y % 100 * 1461 / 4 +
      ( $y / 100 * 36524 + $y / 400 ) - 306;
}    # }}}

# sub days_this_year {{{

sub days_this_year {
    my ( $d, $m, $y ) = @_;
    my @mlist = &months($y);
    return $mlist[$m - 1] + $d - 1;
}    #}}}

# sub day_of_week {{{

sub day_of_week {
    my $self = shift;
    return $self->{julian} % 7;
}    #}}}

# sub hour {{{

sub hour {
    my $self = shift;
    return ( $self->parsetime )[2];
} # }}}

# sub min {{{

sub min {
    my $self = shift;
    return ( $self->parsetime )[1];
}

sub minute { return min(@_); }

# }}}

# sub sec {{{

sub sec {
    my $self = shift;
    return ( $self->parsetime )[0];
}

sub second { return sec(@_); }

# }}}

# sub parsetime {{{

sub parsetime {
    my $self = shift;
    my $time = $self->{julsec};

    my $hour = int( $time / 3600 );
    $time -= $hour * 3600;

    my $min = int( $time / 60 );
    $time -= $min * 60;

    return ( int($time), $min, $hour );
} # }}}

# sub julian/jd #{{{

sub jd {
    my $self = shift;

    if ( my $jd = shift ) {
        ( $self->{julian}, $self->{julsec} ) = @$jd;
    }

    return [ $self->{julian}, $self->{julsec} ];
}

sub julian { return jd(@_) }

# INTERNAL ONLY: figures out what the UTC offset (in HHMM) is
# is for the current machine.
sub _calc_local_offset {

    use Time::Local;
    my @t = gmtime;

    my $local = timelocal(@t);
    my $gm    = timegm(@t);

    my $secdiff = $gm - $local;
    return offset_from_seconds($secdiff);
}

#}}}

1;

# More docs {{{

#}}}