File Coverage

blib/lib/DateTime/Event/Easter.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

#
#     Perl DateTime extension for computing the dates for Easter and related feasts
#     Copyright (C) 2003-2004, 2015 Rick Measham and Jean Forget
#
#     See the license in the embedded documentation below.
#
package DateTime::Event::Easter;
use DateTime;
use DateTime::Set;
use Carp;
use Params::Validate qw( validate SCALAR BOOLEAN OBJECT );

use strict;
use warnings;
use vars qw(
    $VERSION @ISA @EXPORT @EXPORT_OK
);

require Exporter;

@ISA = qw(Exporter);

@EXPORT_OK = qw(easter);
$VERSION = '1.05';

sub new {
    my $class = shift;
    my %args  = validate( @_,
                    {   easter  => { type => SCALAR, default=>'western', optional=>1, regex => qr/^(western|eastern)$/i },
                        day     => { type => SCALAR, default=>'sunday', optional=>1 },
                        as      => { type => SCALAR, default=>'point', optional=>1 },
                    }
                );

    my %self;
    my $offset;
    if ($args{day} =~/^fat/i) {
        $offset = -47;
    }
    elsif ($args{day} =~/^ash/i) {
        # First day of lent. Lent lasts for 40 days, excluding sundays.
        # This translates to a 46-day duration, including sundays.
        $offset = -46;
    }
    elsif ($args{day} =~/^ascension/i) {
        $offset = 39;
    }
    elsif ($args{day} =~/^pentecost/i) {
        $offset = 49;
    }
    elsif ($args{day} =~/^trinity/i) {
        $offset = 56;
    }
    elsif ($args{day} =~/^palm/i) {
        $offset = -7;
    } elsif ($args{day} =~/saturday/i) {
        $offset = -1;
    } elsif ($args{day} =~/friday/i) {
        $offset = -2;
    } elsif ($args{day} =~/thursday/i) {
        $offset = -3;
    } elsif ($args{day} =~/^\-?\d+$/i) {
        $offset = $args{day};
    } else {
        $offset = 0;
    }
    $self{offset} = DateTime::Duration->new(days=>$offset);
    $self{easter} = lc $args{easter};

    if ($self{easter} eq 'eastern') {
        require DateTime::Calendar::Julian;
    }

    # Set to return points or spans
    die("Argument 'as' must be 'point' or 'span'.") unless $args{as}=~/^(point|span)s?$/i;
    $self{as} = lc $1;

    return bless \%self, $class;

}


sub following {
    my $self = shift;
    my $dt = shift;

    my $class = ref($dt);
    if ($self->{easter} eq 'eastern' && $class ne 'DateTime::Calendar::Julian') {
        croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
        $dt = DateTime::Calendar::Julian->from_object(object=>$dt);
    } elsif ($class ne 'DateTime') {
        croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
        $dt = DateTime->from_object(object=>$dt);
    }

    my $easter_this_year = $self->_easter($dt->year)+$self->{offset};

    my $easter = ($easter_this_year > $dt)
        ? $easter_this_year
        : $self->_easter($dt->year+1)+$self->{offset};

    $easter = $class->from_object(object=>$easter) if (ref($easter) ne $class);
    return ($self->{as} eq 'span')
        ? _tospan($easter)
        : $easter;
}

sub previous {
    my $self = shift;
    my $dt = shift;

    my $class = ref($dt);
    if ($self->{easter} eq 'eastern' && $class ne 'DateTime::Calendar::Julian') {
        croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
        $dt = DateTime::Calendar::Julian->from_object(object=>$dt);
    } elsif ($class ne 'DateTime') {
        croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
        $dt = DateTime->from_object(object=>$dt);
    }

    my $easter_this_year = $self->_easter($dt->year)+$self->{offset};

    my $easter = ($easter_this_year->ymd lt $dt->ymd)
       ? $easter_this_year
       : $self->_easter($dt->year-1)+$self->{offset};


    $easter = $class->from_object(object=>$easter) if (ref($easter) ne $class);
    return ($self->{as} eq 'span')
        ? _tospan($easter)
        : $easter;
}

sub closest {
    my $self = shift;
    my $dt = shift;

    my $class = ref($dt);
    if ($class 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)) {
		my $easter = $dt->clone->truncate(to=>'day');
	    $easter = $class->from_object(object=>$easter) if (ref($easter) ne $class);
		return ($self->{as} eq 'span')
			? _tospan($easter)
			: $easter;
    }
    my $following_easter = $self->following($dt);
    my $following_delta  = $following_easter - $dt;
    my $previous_easter  = $self->previous($dt);

    my $easter = ($previous_easter + $following_delta < $dt)
        ? $following_easter
        : $previous_easter;
    $easter = $class->from_object(object=>$easter) if (ref($easter) ne $class);
    return ($self->{as} eq 'span')
        ? _tospan($easter)
        : $easter;
}

sub is {
    my $self = shift;
    my $dt = shift;

    my $class = ref($dt);
    if ($class ne 'DateTime') {
        croak ("Dates need to be datetime objects") unless ($dt->can('utc_rd_values'));
        $dt = DateTime->from_object(object=>$dt);
    }

    if ($self->{easter} eq 'eastern') {
        $dt = DateTime::Calendar::Julian->from_object(object=>$dt)
    }

    my $easter_this_year = $self->_easter($dt->year)+$self->{offset};

    return ($easter_this_year->ymd eq $dt->ymd) ? 1 : 0;
}

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_old_set {
    my $self = shift;
    return DateTime::Set->from_datetimes( dates => [ $self->as_list(@_) ] );
}
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
	);
}

sub as_span {
    my $self = shift;
    $self->{as} = 'span';
    return $self;
}

sub as_point {
    my $self = shift;
    $self->{as} = 'point';
    return $self;
}

sub _tospan {
   return DateTime::Span->from_datetime_and_duration(
		start => $_[0],
		hours => 24,
   );
}

sub _easter {
    my $self = shift;
    my $year = shift;
    return ($self->{easter} eq 'eastern')
        ? eastern_easter($year)
        : western_easter($year);
}

sub western_easter {
    my $year = shift;
    croak "Year value '$year' should be numeric." if $year!~/^\-?\d+$/;

    my $golden_number = $year % 19;
    #quasicentury is so named because its a century, only its
    # the number of full centuries rather than the current century
    my $quasicentury = int($year / 100);
    my $epact = ($quasicentury - int($quasicentury/4) - int(($quasicentury * 8 + 13)/25) + ($golden_number*19) + 15) % 30;
    my $interval = $epact - int($epact/28)*(1 - int(29/($epact+1)) * int((21 - $golden_number)/11) );
    my $weekday = ($year + int($year/4) + $interval + 2 - $quasicentury + int($quasicentury/4)) % 7;

    my $offset = $interval - $weekday;
    my $month = 3 + int(($offset+40)/44);
    my $day = $offset + 28 - 31* int($month/4);

    return DateTime->new(year=>$year, month=>$month, day=>$day);
}
*easter = \&western_easter; #alias so people can call 'easter($year)' externally

sub eastern_easter {
    my $year = shift;
    croak "Year value '$year' should be numeric." if $year!~/^\-?\d+$/;

    my $golden_number = $year % 19;

    my $interval = ($golden_number * 19 + 15) % 30;
    my $weekday = ($year + int($year/4) + $interval) % 7;

    my $offset = $interval - $weekday;
    my $month = 3 + int(($offset+40)/44);
    my $day = $offset + 28 - 31* int($month/4);

    return DateTime::Calendar::Julian->new(year=>$year, month=>$month, day=>$day);
}

# Ending a module with an unspecified number, which could be zero, is wrong.
# Therefore the custom of ending a module with a boring "1".
# Instead of that, end it with some verse.
q{
Il reviendra à Pâques, mironton mironton mirontaine,
Il reviendra à Pâques
Ou à la Trinité.
Ou à la Trinité...
};
__END__