File Coverage

blib/lib/DateTime/Fiscal/Retail454.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# $Id: Retail454.pm 24 2012-07-05 23:48:48Z jim $

package DateTime::Fiscal::Retail454;

use strict;
use warnings;

our $VERSION = '0.02';

our $R454DEBUG = 0;

use Carp;

use DateTime;
use base qw(DateTime);

my $pkg = __PACKAGE__;

my @periodmonths = qw(
  February
  March
  April
  May
  June
  July
  August
  September
  October
  November
  December
  January
);

# This code ref builds a cache that can be used as long as the value in
# the _R454_basedate attribute remains unchanged.
my $_r454_build_periods = sub {
    my $self = shift;

    return
      if ref($self->{_R454_periods}) && $self->{_R454_basedate} eq $self->ymd;

    my @pweeks = (0, 4, 5, 4, 4, 5, 4, 4, 5, 4, 4, 5, 4);
    $pweeks[$#pweeks] = 5 if $self->is_r454_leap_year;

    my $pdata  = {};
    my $pstart = $pkg->_454_start($self->r454_year);

    for (1 .. 12) {
        $pdata->{$_} = {
            pstart   => $pstart->clone,
            weeks    => $pweeks[$_],
            r454year => $self->r454_year,
            month    => $periodmonths[$_ - 1]
        };
        my $pend =
          $pstart->clone->add(weeks => $pweeks[$_])->subtract(seconds => 1);
        $pdata->{$_}->{pend} = $pend;
        my $ppub = $pend->clone->truncate(to => 'day')->add(days => 5);
        $pdata->{$_}->{ppub} = $ppub;

        $pstart = $pstart->clone->add(weeks => $pweeks[$_]);
    }

    $self->{_R454_periods}  = $pdata;
    $self->{_R454_basedate} = $self->ymd;

};

# this code ref is used with versions of DateTime prior to 0.64
my $_454_allocate = sub {
    my $self = shift;

    $self->{_R454_year}    = undef;
    $self->{_R454_periods} = undef;

    return;
};

# this override is required for versions of DateTime starting with 0.64
# and serves the same purpose as the above code reference, but in a
# much nicer way.
sub _new
{
    my $proto  = shift;
    my %params = @_;

    my $class = ref($proto) || $proto;

    my $self = $class->SUPER::_new(%params);
    $self->{_R454_year}    = undef;
    $self->{_R454_periods} = undef;

    return $self;
}

sub _454_start
{
    my $proto = shift;
    my $cyr   = shift;

    my ($package, $filename, $line) = caller;
    confess "FORBIDDEN private method call" unless $package->isa($pkg);

    my $class = ref($proto) || $proto;

    #  my $r454tmp = $pkg->SUPER::new( year => $cyr, month => 1, day => 31 );
    my $r454tmp = $class->SUPER::new(year => $cyr, month => 1, day => 31);
    my $jan31dow = $r454tmp->dow;
    if ($jan31dow < 3) {
        $r454tmp->subtract(days => $jan31dow);
    } elsif ($jan31dow < 7) {
        $r454tmp->add(days => (7 - $jan31dow));
    }

    return $r454tmp;
}

sub from_r454year
{
    my $proto  = shift;
    my %params = @_;

    croak "Mandatory parameter 'r454year' missing"
      unless defined($params{r454year});

    my $class = ref($proto) || $proto;

    #return( bless $pkg->_454_start($params{r454year}), $proto )
    return $class->_454_start($params{r454year});
}

# These have to be overloaded here in order to properly setup any attributes
# used by this module.  In addition, 'from_day_of_year' has to be here
# because it does not ever call the normal 'new' constructor.
#
# NOTE!!!
# It appears that DateTime calls new any time a change is made to the object's
# value, through actions such as date math or the 'set' functions.
# OTOH, the object is left alone for any of the 'get' functions.
#
# Because of this, care must be taken to ensure a recursive loop isn't
# created, hence the need for a seperate constructor for 'from_r454year'.
#
# NOTE!!!
# The internals of DateTime have changed in version 0.64 which makes
# sub-classing much easier. This code has been changed accordingly to
# try to pick up which style is being used in DateTime.
#
# Even so, I am poking around under the hood and can be bit in the future.

sub new
{
    my $proto  = shift;
    my %params = @_;

    my $class = ref($proto) || $proto;

    my $self = $class->SUPER::new(%params);

    #  &{$_454_allocate}($self);
    &{$_454_allocate}($self) unless exists($self->{_R454_year});

    return ($self);
}

# this override is needed because the constructor in earlier versions of
# DateTime did not propagate sub-classing.
sub from_day_of_year
{
    my $proto  = shift;
    my %params = @_;

    my $class = ref($proto) || $proto;

    #  my $self = bless $pkg->SUPER::from_day_of_year(%params), $proto;
    my $self = $class->SUPER::from_day_of_year(%params);
    bless $self, $class unless ref($self) eq $class;

    #  &{$_454_allocate}($self);
    &{$_454_allocate}($self) unless exists($self->{_R454_year});

    return ($self);
}

sub r454_year
{
    my $self = shift;

    if (!defined($self->{_R454_year})) {
        my $r454tmp = $pkg->_454_start($self->year);
        $self->{_R454_year} =
          $r454tmp > $self ? $self->year - 1 : $r454tmp->year;
    }

    return ($self->{_R454_year});
}

sub is_r454_leap_year
{
    my $self = shift;

    my $tmpnext = $pkg->_454_start($self->r454_year)->add(days => 364);
    my $realnext = $pkg->_454_start($self->r454_year + 1);

    return ($realnext > $tmpnext ? 1 : 0);
}

sub r454_start
{
    my $self   = shift;
    my %params = @_;

    my $asobj = (defined($params{as_obj}) ? $params{as_obj} : 0);

    my $r454start = $pkg->_454_start($self->r454_year);

    return ($asobj ? $r454start : "" . $r454start);
}

sub r454_end
{
    my $self   = shift;
    my %params = @_;

    my $asobj = (defined($params{as_obj}) ? $params{as_obj} : 0);

    my $r454end =
      $pkg->_454_start($self->r454_year + 1)->subtract(seconds => 1);

    return ($asobj ? $r454end : "" . $r454end);
}

sub r454_period
{
    my $self   = shift;
    my %params = @_;

    my $asobj = defined($params{as_obj}) ? $params{as_obj} : 0;
    carp "objects requested in non-array context" if $asobj && !wantarray;

    my $pnum = defined($params{period}) ? 0 + $params{period} : 0;

    &{$_r454_build_periods}($self);

    if (!$pnum) {
        $pnum = 1;
        while ($self->{_R454_periods}->{$pnum}->{pstart} < $self) {
            last if $self->{_R454_periods}->{$pnum + 1}->{pstart} > $self;
            last if ++$pnum == 12;
        }
    }
    croak "Invalid Period specified" unless $pnum > 0 && $pnum < 13;

    return ($pnum) unless wantarray;

    my $phash = $self->{_R454_periods}->{$pnum};
    my @pdata = (
        $pnum,
        $phash->{weeks},
        ($asobj ? $phash->{pstart}->clone : "" . $phash->{pstart}),
        ($asobj ? $phash->{pend}->clone   : "" . $phash->{pend}),
        ($asobj ? $phash->{ppub}->clone   : "" . $phash->{ppub}),
        $phash->{r454year}
    );

    return (@pdata);
}

sub r454_period_weeks
{
    my $self   = shift;
    my %params = @_;

    my $pnum =
      defined($params{period}) ? 0 + $params{period} : $self->r454_period;
    croak "Invalid Period specified" unless $pnum > 0 && $pnum < 13;

    &{$_r454_build_periods}($self);

    return ($self->{_R454_periods}->{$pnum}->{weeks});
}

sub r454_period_start
{
    my $self   = shift;
    my %params = @_;

    my $asobj = defined($params{as_obj}) ? $params{as_obj} : 0;
    my $pnum =
      defined($params{period}) ? 0 + $params{period} : $self->r454_period;
    croak "Invalid Period specified" unless $pnum > 0 && $pnum < 13;

    &{$_r454_build_periods}($self);
    my $pobj = $self->{_R454_periods}->{$pnum}->{pstart};

    return ($asobj ? $pobj : "" . $pobj);
}

sub r454_period_end
{
    my $self   = shift;
    my %params = @_;

    my $asobj = defined($params{as_obj}) ? $params{as_obj} : 0;
    my $pnum =
      defined($params{period}) ? 0 + $params{period} : $self->r454_period;
    croak "Invalid Period specified" unless $pnum > 0 && $pnum < 13;

    &{$_r454_build_periods}($self);
    my $pobj = $self->{_R454_periods}->{$pnum}->{pend}->clone;

    return ($asobj ? $pobj : "" . $pobj);
}

sub r454_period_publish
{
    my $self   = shift;
    my %params = @_;

    my $asobj = defined($params{as_obj}) ? $params{as_obj} : 0;
    my $pnum =
      defined($params{period}) ? 0 + $params{period} : $self->r454_period;
    croak "Invalid Period specified" unless $pnum > 0 && $pnum < 13;

    &{$_r454_build_periods}($self);
    my $pobj = $self->{_R454_periods}->{$pnum}->{ppub}->clone;

    return ($asobj ? $pobj : "" . $pobj);
}

sub r454_period_month
{
    my $self   = shift;
    my %params = @_;

    my $pnum =
      defined($params{period}) ? 0 + $params{period} : $self->r454_period;
    croak "Invalid Period specified" unless $pnum > 0 && $pnum < 13;

    &{$_r454_build_periods}($self);

    return ($self->{_R454_periods}->{$pnum}->{month});
}

sub truncate
{
    my $self   = shift;
    my %params = @_;

    if ($params{to} eq 'r454year') {
        my $tmp = $self->r454_start(as_obj => 1);
        %{$self} = %{$tmp};
    } elsif ($params{to} eq 'period') {
        my $tmp = $self->r454_period_start(as_obj => 1);
        %{$self} = %{$tmp};
    } else {
        $self->SUPER::truncate(%params);
    }

    return ($self);
}

1;

__END__