# $Id: ICal.pm,v 1.72 2003/01/18 20:09:42 rbowen Exp $
package Date::ICal;
use strict;
use vars qw($VERSION $localzone $localoffset @months @leapmonths %add_units);
$VERSION = (qw'$Revision: 1.72 $')[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 {{{
=head1 NAME
Date::ICal - Perl extension for ICalendar date objects.
=head1 VERSION
$Revision: 1.72 $
=head1 SYNOPSIS
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;
(Where $duration is either a duration string, like 'P2W3DT7H9M', or a
Date::ICal::Duration (qv) object.
$ical += 'P6DT12H';
$duration = $ical1 - $ical2;
$ical3 = $ical1 - $duration;
=head1 DESCRIPTION
Date::ICal talks the ICal date format, and is intended to be a base class for
other date/calendar modules that know about ICal time format also.
See http://dates.rcbowen.com/unified.txt for details
=head1 AUTHOR
Rich Bowen, and the Reefknot team (www.reefknot)
Last touched by $Author: rbowen $
=head1 METHODS
Date::ICal has the following methods available:
=head2 new
A new Date::ICal object can be created with any valid ICal string:
my $ical = Date::ICal->new( ical => '19971024T120000' );
# will default to the timezone specified in $TZ, see below
Or with any epoch time:
my $ical = Date::ICal->new( epoch => time );
Or, better still, create it with components
my $date = Date::ICal->new(
day => 25,
month => 10,
year => 1066,
hour => 7,
min => 15,
sec => 47
);
If you call new without any arguments, you'll get a Date::ICal object that is
set to the time right now.
my $ical = Date::ICal->new();
If you already have an object in Date::ICal, or some other subclass
thereof, you can create a new Date::ICal (or subclass) object using
that object to start with. This is particularly useful for converting
from one calendar to another:
# 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;
new() handles timezones. It defaults times to UTC (Greenwich
Mean Time, also called Zulu). If you want to set up a time
that's in the US "Pacific" timezone, which is GMT-8, use something
like:
my $ical = Date::ICal->new( ical => '19971024T120000',
offset => "-0800");
Note that as of version 1.44, new() tries to be intelligent
about figuring out your local time zone. If you enter
a time that's not *explicitly* in UTC, it looks at
the environment variable $TZ, if it exists, to determine
your local offset. If $TZ isn't set, new() will complain.
=cut
#}}}
#{{{ 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
=head2 ical
$ical_string = $ical->ical;
Retrieves, or sets, the date on the object, using any valid ICal date/time
string. Output is in UTC (ends with a "Z") by default. To get
output in localtime relative to the current machine, do:
$ical_string = $ical->ical( localtime => 1 );
To get output relative to an arbitrary offset, do:
$ical_string = $ical->ical( offset => '+0545' );
=cut
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
=head2 epoch
$epoch_time = $ical->epoch;
$ical->epoch( 98687431 );
Sets, or retrieves, the epoch time represented by the object, if it is
representable as such. (Dates before 1971 or after 2038 will not have an epoch
representation.)
Internals note: The ICal representation of the date is considered the only
authoritative one. This means that we may need to reconstruct the epoch time
from the ICal representation if we are not sure that they are in synch. We'll
need to do clever things to keep track of when the two may not be in synch.
And, of course, the same will go for any subclasses of this class.
=cut
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
=head2 offset_to_seconds
$seconds_plus_or_minus = offset_to_seconds($offset);
Changes -0600 to -21600. Not object method, no side-effects.
=cut
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
=head2 offset_from_seconds
$seconds_plus_or_minus = offset_from_seconds($offset_in_seconds);
Changes -18000 (seconds) to -0600 (hours, minutes).
Not object method, no side-effects.
=cut
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
=head2 offset
$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
Sets or retrieves the offset from UTC for this time. This allows
timezone support, assuming you know what your local (or non-local)
UTC offset is. Defaults to 0.
Internals note: all times are internally stored in UTC, even though they
may have some offset information. Offsets are internally stored in
signed integer seconds.
BE CAREFUL about using this function on objects that were initialized
with an offset. If you started an object with:
my $d = new(ical=>'19700101120000', offset=>'+0100');
and you then call:
$d->offset('+0200');
you'll be saying "Yeah, I know I *said* it was in +0100, but really I
want it to be in +0200 now and forever." Which may be your intention,
if you're trying to transpose a whole set of dates to another timezone---
but you can also do that at the presentation level, with
the ical() method. Either way will work.
=cut
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 {{{
=head2 add
$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
Adds a duration to a Date::ICal object.
Supported paraters are: duration, eom_mode, year, month, week, day,
hour, min, sec or seconds.
'duration' is a ICalendar duration string (see duration_value).
If a value is undefined or omitted, 1 is assumed:
$ical->add( 'minute' ); # add a minute
The result will be normalized. That is, the output time will have
meaningful values, rather than being 48:73 pm on the 34th of
hexadecember.
Adding months or years can be done via three different methods,
specified by the eom_mode parameter, which then applies to all
additions (or subtractions) of months or years following it in the
parameter list.
The default, eom_mode => 'wrap', means adding months or years that
result in days beyond the end of the new month will roll over into the
following month. For instance, adding one year to Feb 29 will result
in Mar 1.
If you specify eom_mode => 'limit', the end of the month is never
crossed. Thus, adding one year to Feb 29, 2000 will result in Feb 28,
2001. However, adding three more years will result in Feb 28, 2004,
not Feb 29.
If you specify eom_mode => 'preserve', the same calculation is done as
for 'limit' except that if the original date is at the end of the
month the new date will also be. For instance, adding one month to
Feb 29, 2000 will result in Mar 31, 2000.
All additions are performed in the order specified. For instance,
with the default setting of eom_mode => 'wrap', adding one day and one
month to Feb 29 will result in Apr 1, while adding one month and one
day will result in Mar 30.
=cut
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 {{{
=begin internal
Add (or subtract) to a date/time. First two parameters are
the jd and secs of the day. For the rest, see the add method.
Returns the adjusted jd and secs.
=end internal
=cut
# 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 {{{
=head2 add_overload
$date = $date1 + $duration;
Where $duration is either a duration string, or a Date::ICal::Duration
object.
$date += 'P2DT4H7M';
Adds a duration to a date object. Returns a new object, or, in the case
of +=, modifies the existing object.
=cut
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 {{{
=begin internal
($jd, $secs) = _normalize_seconds( $jd, $secs );
Corrects seconds that have gone into following or previous day(s).
Adjusts the passed days and seconds as well as returning them.
=end internal
=cut
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 {{{
=head2 duration_value
Given a duration string, this function returns the number of days,
seconds, and months represented by that duration. In that order. Seems
odd to me. This should be considered an internal function, and you
should expect the API to change in the very near future.
=cut
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 {{{
=head2 subtract
$duration = $date1 - $date2;
Subtract one Date::ICal object from another to give a duration - the
length of the interval between the two dates. The return value is a
Date::ICal::Duration object (qv) and allows you to get at each of the
individual components, or the entire duration string:
$d = $date1 - $X;
Note that $X can be any of the following:
If $X is another Date::ICal object (or subclass thereof) then $d will be
a Date::ICal::Duration object.
$week = $d->weeks; # how many weeks apart?
$days = $d->as_days; # How many days apart?
If $X is a duration string, or a Date::ICal::Diration object, then $d
will be an object in the same class as $date1;
$newdate = $date - $duration;
=cut
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 {{{
=head2 clone
$copy = $date->clone;
Returns a replica of the date object, including all attributes.
=cut
sub clone {
my $self = shift;
my $class = ref $self;
my %hash = %$self;
my $new = \%hash;
bless $new, $class;
return $new;
} # }}}
# sub compare {{{
=head2 compare
$cmp = $date1->compare($date2);
@dates = sort {$a->compare($b)} @dates;
Compare two Date::ICal objects. Semantics are compatible with
sort; returns -1 if $a < $b, 0 if $a == $b, 1 if $a > $b.
=cut
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 {{{
=begin internal
@months = months($year);
Returns the Julian day at the end of a month, correct for that year.
=end internal
=cut
# 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;
}
=begin internal
time_as_seconds( $args{hour}, $args{min}, $args{sec} );
Returns the time of day as the number of seconds in the day.
=end internal
=cut
# }}}
# 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 {{{
=head2 day
my $day = $date->day;
Returns the day of the month.
Day is in the range 1..31
=cut
sub day {
my $self = shift;
return ( jd2greg( $self->{julian} ) )[2];
} # }}}
# sub month {{{
=head2 month
my $month = $date->month;
Returns the month of the year.
Month is returned as a number in the range 1..12
=cut
sub month {
my $self = shift;
return ( jd2greg( $self->{julian} ) )[1];
} # }}}
# sub mon {{{
sub mon { return month(@_); }
#}}}
# sub year {{{
=head2 year
my $year = $date->year;
Returns the year.
=cut
sub year {
my $self = shift;
return ( jd2greg( $self->{julian} ) )[0];
} # }}}
# sub jd2greg {{{
=head2 jd2greg
($year, $month, $day) = jd2greg( $jd );
Convert number of days on or after Jan 1, 1 CE (Gregorian) to
gregorian year,month,day.
=cut
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 {{{
=head2 greg2jd
$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.
=cut
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 {{{
=head2 days_this_year
$yday = Date::ICal::days_this_year($day, $month, $year);
Returns the number of days so far this year. Analogous to the yday
attribute of gmtime (or localtime) except that it works outside of the
epoch.
=cut
sub days_this_year {
my ( $d, $m, $y ) = @_;
my @mlist = &months($y);
return $mlist[$m - 1] + $d - 1;
} #}}}
# sub day_of_week {{{
=head2 day_of_week
my $day_of_week = $date->day_of_week
Returns the day of week as 0..6 (0 is Sunday, 6 is Saturday).
=cut
sub day_of_week {
my $self = shift;
return $self->{julian} % 7;
} #}}}
# sub hour {{{
=head2 hour
my $hour = $date->hour
Returns the hour of the day.
Hour is in the range 0..23
=cut
sub hour {
my $self = shift;
return ( $self->parsetime )[2];
} # }}}
# sub min {{{
=head2 min
my $min = $date->min;
Returns the minute.
Minute is in the range 0..59
=cut
sub min {
my $self = shift;
return ( $self->parsetime )[1];
}
sub minute { return min(@_); }
# }}}
# sub sec {{{
=head2 sec
my $sec = $date->sec;
Returns the second.
Second is in the range 0..60. The value of 60 is (maybe) needed for
leap seconds. But I'm not sure if we're going to go there.
=cut
sub sec {
my $self = shift;
return ( $self->parsetime )[0];
}
sub second { return sec(@_); }
# }}}
# sub parsetime {{{
=begin internal
( $sec, $min, $hour ) = parsetime( $seconds );
Given the number of seconds so far today, returns the seconds,
minutes, and hours of the current time.
=end internal
=cut
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 #{{{
=head2 julian
my $jd = $date->jd;
Returns a listref, containing two elements. The date as a julian day,
and the time as the number of seconds since midnight. This should not
be thought of as a real julian day, because it's not. The module is
internally consistent, and that's enough.
This method really only is here for compatibility with previous
versions, as the jd method is now thrown over for plain hash references.
See the file INTERNALS for more information about this internal
format.
=cut
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 {{{
=head1 TODO
=over 4
=item - add gmtime and localtime methods, perhaps?
=item - Fix the INTERNALS file so that it actually reflects reality
=back
=head1 INTERNALS
Please see the file INTERNALS for discussion on the internals.
=head1 AUTHOR
Rich Bowen (DrBacchus) rbowen@rcbowen.com
And the rest of the Reefknot team. See the source for a full
list of patch contributors and version-by-version notes.
=head1 SEE ALSO
datetime@perl.org mailing list
http://reefknot.org/
http://dates.rcbowen.com/
Time::Local
Net::ICal
=cut
#}}}