package DateTime::Event::DayOfWeek;
use strict;
use warnings;
use vars qw(
$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
);
$VERSION = '0.01';
BEGIN {
sub SUNDAY() { 0 }
sub MONDAY() { 1 }
sub TUESDAY() { 2 }
sub WEDNESDAY(){ 3 }
sub THURSDAY() { 4 }
sub FRIDAY() { 5 }
sub SATURDAY() { 6 }
};
use Params::Validate qw/validate OBJECT SCALAR/;
use DateTime::Set;
use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY);
%EXPORT_TAGS = (
'daynames_en' => [qw(SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY)],
);
sub new {
my $class = shift;
my $current_dow = shift;
return bless { dow => $current_dow || 0 }, $class;
}
sub Sunday { __PACKAGE__->new(0) }
sub Monday { __PACKAGE__->new(1) }
sub Tuesday { __PACKAGE__->new(2) }
sub Wednesday { __PACKAGE__->new(3) }
sub Thursday { __PACKAGE__->new(4) }
sub Friday { __PACKAGE__->new(5) }
sub Saturday { __PACKAGE__->new(6) }
sub _calculate_dow {
my $self = shift;
my %arg = @_;
my $current_dow = $arg{dt}->day_of_week();
return $arg{dt}->clone->truncate( to => 'day' )
if $current_dow == $arg{dow} and not $arg{always_differ};
my $delta = ( $arg{dow} - $current_dow + 7 ) % 7;
$delta -= 7 if $arg{past};
$delta += ($arg{past} ? -7 : 7) if ($delta == 0 && $arg{always_differ});
return $arg{dt}->clone->add( days => $delta )->truncate( to => 'day' );
};
sub next {
my ($self, $dt) = @_;
if (ref($dt) ne 'DateTime') {
croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
$dt = DateTime->from_object(object=>$dt);
}
return $self->_calculate_dow(
dt => $dt,
dow => $self->{dow}
)
}
sub last {
my ($self, $dt) = @_;
if (ref($dt) ne 'DateTime') {
croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
$dt = DateTime->from_object(object=>$dt);
}
return $self->_calculate_dow(
dt => $dt,
dow => $self->{dow},
past => 1
)
}
sub following {
my ($self, $dt) = @_;
if (ref($dt) ne 'DateTime') {
croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
$dt = DateTime->from_object(object=>$dt);
}
return $self->_calculate_dow(
dt => $dt,
dow => $self->{dow},
always_differ => 1
)
}
sub previous {
my ($self, $dt) = @_;
if (ref($dt) ne 'DateTime') {
croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
$dt = DateTime->from_object(object=>$dt);
}
return $self->_calculate_dow(
dt => $dt,
dow => $self->{dow},
always_differ => 1,
past => 1
)
}
sub is {
my ($self, $dt) = @_;
if (ref($dt) ne 'DateTime') {
croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
$dt = DateTime->from_object(object=>$dt);
}
return ($self->{dow} % 7 == $dt->day_of_week() % 7) ? 1 : 0;
}
sub closest {
my ($self, $dt) = @_;
if (ref($dt) ne 'DateTime') {
croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
$dt = DateTime->from_object(object=>$dt);
}
if( $self->is( $dt ) ){
return $dt->clone->truncate( to => 'day' );
}
my $following = $self->following( $dt );
my $previous = $self->previous( $dt );
return ( abs($dt->epoch - $following->epoch) < abs($dt->epoch - $previous->epoch) )
? $following
: $previous
}
sub as_list {
my $self = shift;
my %args = validate( @_,
{ from => { type => OBJECT },
to => { type => OBJECT },
inclusive => { type => SCALAR, default=>0 },
}
);
# Make sure our args are in the right order
($args{from}, $args{to}) = sort ($args{from}, $args{to});
my @set = ();
if ($args{inclusive}) {
if ($self->is($args{from})) {
push(@set,$args{from});
}
if ($self->is($args{to})) {
push(@set,$args{to});
}
}
my $checkdate = $args{from};
while ($checkdate < $args{to}) {
$checkdate = $self->following($checkdate);
push(@set,$checkdate) if ($checkdate < $args{to});
}
return sort @set;
}
sub as_set {
my $self = shift;
my %args = @_;
if (exists $args{inclusive}) {
croak("You must specify both a 'from' and a 'to' datetime") unless
ref($args{to})=~/DateTime/ and
ref($args{from})=~/DateTime/;
if ($args{inclusive}) {
$args{start} = delete $args{from};
$args{end} = delete $args{to};
} else {
$args{after} = delete $args{from};
$args{before} = delete $args{to};
}
delete $args{inclusive};
} elsif (exists $args{from} or exists $args{to}) {
croak("You must specify both a 'from' and a 'to' datetime") unless
ref($args{to})=~/DateTime/ and
ref($args{from})=~/DateTime/;
$args{after} = delete $args{from};
$args{before} = delete $args{to};
}
return DateTime::Set->from_recurrence(
next => sub { return $_[0] if $_[0]->is_infinite; $self->following( $_[0] ) },
previous => sub { return $_[0] if $_[0]->is_infinite; $self->previous( $_[0] ) },
%args
);
}
1;
__END__
=head1 NAME
DateTime::Event::DayOfWeek - Returns Day-of-Week events for DateTime objects
=head1 SYNOPSIS
use DateTime::Event::DayOfWeek;
$dt = DateTime->new( year => 2008,
month => 4,
day => 13,
);
$wednesday = DateTime::Event::DayOfWeek->wednesday();
# or $wednesday = new DateTime::Event::DayOfWeek( WEDNESDAY );
$previous_wednesday = $wednesday->previous($dt);
# Wed, 9 Apr 2008 00:00:00
$following_wednesday = $wednesday->following($dt);
# Wed, 16 Apr 2008 00:00:00
$closest_wednesday = $wednesday->closest($dt);
# Wed, 16 Apr 2008 00:00:00
$is_wednesday = $wednesday->is($dt);
# 0
$dt2 = $dt->clone->add( months => 1 );
@set = $wednesday->as_list(from=>$dt, to=>$dt2);
# Wed, 16 Apr 2008 00:00:00
# Wed, 23 Apr 2008 00:00:00
# Wed, 30 Apr 2008 00:00:00
# Sun, 07 May 2008 00:00:00
$every_wednesday = $wednesday->as_set;
# A set of every wednesday ever. See C<DateTime::Set> for more information.
=head1 DESCRIPTION
The DateTime::Event::DayOfWeek module returns events that occur on the
day-of-week required where an event is the occurrence of that day of
the week.
=head1 CONSTRUCTORS
The main 'new' constructor takes one argument: A day of the week
expressed as an integer where Sunday is zero (0).
$wednesday = new DateTime::Event::DayOfWeek( 3 );
Constants are available for SUNDAY, MONDAY, .., SATURDAY
$wednesday = new DateTime::Event::DayOfWeek( WEDNESDAY );
You can also use the English day names as constructors:
$wednesday = DateTime::Event::DayOfWeek::Wednesday;
# or
$wednesday = DateTime::Event::DayOfWeek->Wednesday;
=head1 METHODS
For all these methods, unless otherwise noted, $dt is a plain vanila
DateTime object or a DateTime object from any DateTime::Calendar module
that can handle calls to from_object and utc_rd_values (which should be
all of them, but there's nothing stopping someone making a bad egg).
This class offers the following methods.
=over 4
=item * following($dt)
Returns the DateTime object for the Day of the Week after $dt. This will
not return $dt.
=item * previous($dt)
Returns the DateTime object for the Day of the Week before $dt. This will
not return $dt.
=item * closest($dt)
Returns the DateTime object for the Day of the Week closest to $dt. This
will return midnight of $dt if $dt is the Day of the Week.
=item * is($dt)
Return positive (1) if $dt is the Day of the Week, otherwise returns false
(0)
=item * as_list(from => $dt, to => $dt2, inclusive=>I<([0]|1)>)
Returns a list of Day-of-the-Weeks between I<to> and I<from>.
If the optional I<inclusive> parameter is true (non-zero), the to and
from dates will be included if they are the Day of the Week.
If you do not include an I<inclusive> parameter, we assume you do not
want to include these dates (the same behaviour as supplying a false
value)
=item * as_set()
Returns a DateTime::Set of Day-of-the-Weeks.
In the past this method used the same syntax as 'as_list' above. However
we now allow both the above syntax as well as the full options allowable
when creating sets with C<DateTime::Set>. This means you can call
C<$datetime_set = $sunday->as_set;> and it will return a
C<DateTime::Set> of all Sundays. See C<DateTime::Set> for more information.
=back
=head1 EXPORTS
This class does not export anything by default, however the following
exports are supported.
=over 4
=item * SUNDAY, MONDAY, .., SATURDAY
These constants map to the integer value of that day of the week.
=item * :daynames_en
Exports all the day names at once
=back
=head1 THE SMALL PRINT
=head2 REFERENCES
=over 4
=item *
http://datetime.perl.org - The official home of the DateTime
project
=back
=head2 SUPPORT
Support for this module, and for all DateTime modules will be given
through the DateTime mailing list - datetime@perl.org.
Bugs should be reported through rt.cpan.org.
=head2 AUTHOR
Rick Measham <rickm@cpan.org>
Aristotle Pagaltzis
=head2 CREDITS
B<Aristotle Pagaltzis> - whose journal post
(
http://use.perl.org/~Aristotle/journal/36022) inspired the module and
whose code started the ball rolling
=head2 COPYRIGHT
(c) Copyright 2008 Rick Measham. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
The full text of the license can be found in the LICENSE file included
with this module.
=head2 SEE ALSO
L<DateTime>, L<DateTime::Set>, perl(1),
http://datetime.perl.org.
RT for rt.cpan.org