Re: [rt.cpan.org #34912] Constants for months/weekdays?

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 - [email protected].

Bugs should be reported through rt.cpan.org.

=head2 AUTHOR

Rick Measham <[email protected]>

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.

#!/usr/bin/perl

use lib '../lib';

use DateTime;
use DateTime::Event::DayOfWeek qw/:daynames_en/;

my $now = DateTime->now( time_zone => 'Australia/Melbourne' );

#my $wednesday = new DateTime::Event::DayOfWeek( WEDNESDAY );
my $wednesday = DateTime::Event::DayOfWeek::Wednesday;

printf("%9s => %s\n" x 4,
	Following => $wednesday->following( $now )->datetime,
	Previous  => $wednesday->previous( $now )->datetime,
	Closest   => $wednesday->closest( $now )->datetime,
	Is        => $wednesday->is( $now ),
);

#======================================================================
print "As list:\n";
#----------------------------------------------------------------------

my @list = $wednesday->as_list(
	from => $now,
	to   => $now->clone->add( months => 2 )
);
print $_->datetime, "\n" for @list;

#======================================================================
print "As set:\n";
#----------------------------------------------------------------------
my $set = $wednesday->as_set(
	from => $now,
	to   => $now->clone->add( months => 2 )
);
$iter = $set->iterator;
while ( $dt = $iter->next ) {
	print $dt->datetime, "\n";
};