File Coverage

blib/lib/DateTimeX/Fiscal/Fiscal5253.pm

Criterion	Covered	Total	%
statement	155	165	93.9
branch	59	72	81.9
condition	20	26	76.9
subroutine	20	21	95.2
pod	5	6	83.3
total	259	290	89.3

package DateTimeX::Fiscal::Fiscal5253;

our $VERSION = '2.01';

use Carp;
use DateTime;
use POSIX qw( strftime );

use Moo;
use MooX::StrictConstructor;

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

# Figure out if the epoch is a 32- or 64-bit value and use DT if needed
my $_use_dt = sub {
    my $year = shift;

    # test for 32- or 64-bit time values. This is in an eval because there
    # is apparently a bug in Perl 5.10.0 on a Win32 v5 build that causes
    # gmtime to return undefs when the epoch rolls over. This of course
    # will throw an uninitialized error with "use warnings FATAL => 'all'"
    # in effect.
    my $is_32 = eval {
        my @tdata = gmtime(2147483651);    # This is 4 sec past the rollover
        return ( $tdata[5] == 138 );
    };

    return $is_32 && ( $year < 1903 || $year > 2037 );
};

# Utility function to convert a date string to a DT object
my $_str2dt = sub {
    my $date = shift;

    return $date if ref($date);

    # convert date param to DT object
    my ( $y, $m, $d );
    if ( $date =~ m{^(\d{4})-(\d{1,2})-(\d{1,2})(?:$|\D+)} ) {
        $y = $1, $m = $2, $d = $3;
    }
    elsif ( $date =~ m{^(\d{1,2})/(\d{1,2})/(\d{4})(?:$|\D+)} ) {
        $y = $3, $m = $1, $d = $2;
    }
    else {
        croak "Unable to parse date string: $date";
    }
    eval { $date = DateTime->new( year => $y, month => $m, day => $d ); }
      or croak "Invalid date: $date";

    return $date;
};

# Utility function to validate values supplied as a calendar style.
my $_valid_cal_style = sub {
    my $style = shift || 'fiscal';

    $style =~ tr/A-Z/a-z/;
    croak "Invalid calendar style specified: $style"
      unless $style =~ /^(fiscal|restated|truncated)$/;

    return $style;
};

# Define attributes and psuedo-attributes
has end_month => (
    is  => 'ro',
    isa => sub {
        croak "Invalid value for param end_month: $_[0]"
          unless $_[0] =~ /^(?:1[0-2]|[1-9])\z/;
    },
    default => 12,
);

has end_dow => (
    is  => 'ro',
    isa => sub {
        croak "Invalid value for param end_dow: $_[0]"
          unless $_[0] =~ /^[1-7]\z/;
    },
    default => 6,
);

has end_type => (
    is     => 'ro',
    coerce => sub { my $tmp = $_[0]; $tmp =~ tr[A-Z][a-z]; return $tmp; },
    isa    => sub {
        croak "Invalid value for param end_type: $_[0]"
          unless $_[0] =~ /^(?:last|closest)$/;
    },
    default => 'last',
);

has leap_period => (
    is     => 'ro',
    coerce => sub { my $tmp = $_[0]; $tmp =~ tr[A-Z][a-z]; return $tmp; },
    isa    => sub {
        croak "Invalid value for param leap_period: $_[0]"
          unless $_[0] =~ /^(?:first|last)$/;
    },
    default => 'last',
);

has year => (
    is      => 'rwp',
    builder => 1,
    lazy    => 1,
);

has _date => (
    is       => 'rw',
    init_arg => 'date',
    coerce   => $_str2dt,
    isa      => sub {
        croak 'Object in "date" parameter is not a member of DateTime'
          unless $_[0]->isa('DateTime');
    },
);

has _start_ymd => (
    is       => 'rw',
    init_arg => undef,
    reader   => 'start',
);

has _end_ymd => (
    is       => 'rw',
    init_arg => undef,
    reader   => 'end',
);

has _weeks => (
    is       => 'rw',
    init_arg => undef,
    reader   => 'weeks',
);

has style => (
    is       => 'rw',
    init_arg => undef,
    coerce   => sub { my $tmp = $_[0]; $tmp =~ tr[A-Z][a-z]; return $tmp; },
    isa      => $_valid_cal_style,
    default  => 'fiscal',
);

around BUILDARGS => sub {
    my $orig  = shift;
    my $class = shift;
    my %args  = @_;

    # which one would be correct?
    croak 'Mutually exclusive parameters "year" and "date" are present'
      if $args{year} && $args{date};

    # clone the DT object if present
    $args{date} = $args{date}->clone
      if ref( $args{date} ) && $args{date}->isa('DateTime');

    # supply a default date if needed
    $args{date} = DateTime->today() unless $args{date} || $args{year};

    return $class->$orig(%args);
};

# One of the few cases where modifying "new" is the right thing to do.
# NOTE! testing reveals that this B come before "BUILDARGS".
before new => sub {
    croak 'Must be called as a class method only' if ref( $_[0] );
};

# Initialize the internal structures now that we know our params are good.
sub BUILD {
    my $self = shift;

    $self->{_fiscal}    = undef;
    $self->{_restated}  = undef;
    $self->{_truncated} = undef;

    $self->{_start}     = $self->_start5253;
    $self->{_start_ymd} = $self->{_start}->ymd;
    $self->{_end}       = $self->_end5253;
    $self->{_end_ymd}   = $self->{_end}->ymd;

    $self->{_weeks} =
      $self->{_start}->clone->add( days => 367 ) > $self->{_end} ? 52 : 53;

    $self->_build_weeks;
    $self->_build_periods('fiscal');

    if ( $self->{_weeks} == 53 ) {
        $self->_build_periods('restated');
        $self->_build_periods('truncated');
    }

    return;
}

sub _build_year {
    my $self = shift;

    # we *should be* guaranteed that _date contains a DateTime object
    # if this is reached because no value was supplied for 'year'.
    $self->{_date}->truncate( to => 'day' )->set_time_zone('floating');

    return $self->_find5253;
}

# Build the week array once, then manipulate as needed.
# Using epoch math is more than an order of magnitude faster
# than DT, but the size of the epoch value must be tested.
sub _build_weeks {
    my $self = shift;

    my $weeks = {};
    if ( &{$_use_dt}( $self->{year} ) ) {
        my $wstart = $self->{_start}->clone;
        my $wend = $self->{_start}->clone->add( days => 6 );

        for ( 1 .. $self->{_weeks} ) {
            $weeks->{$_} = {
                start => $wstart->ymd,
                end   => $wend->ymd,
            };

            # skip the last step so the ending values are preserved
            # if needed for something else in the future.
            last if $_ == $self->{_weeks};

            $wstart->add( days => 7 );
            $wend->add( days => 7 );
        }
    }
    else {
        my $daysecs  = ( 60 * 60 * 24 );
        my $weeksecs = $daysecs * 7;

        my $wstart = $self->{_start}->epoch + ( $daysecs / 2 );
        my $wend = $wstart + ( $daysecs * 6 );

        for ( 1 .. $self->{_weeks} ) {
            $weeks->{$_} = {
                start => strftime( '%Y-%m-%d', localtime($wstart) ),
                end   => strftime( '%Y-%m-%d', localtime($wend) ),
            };

            # skip the last step so the ending values are preserved
            # if needed for something else in the future.
            last if $_ == $self->{_weeks};

            $wstart += $weeksecs;
            $wend   += $weeksecs;
        }
    }

    $self->{_weeks_raw} = $weeks;

    return;
}

# Build the basic calendar structures as needed.
sub _build_periods {
    my $self = shift;
    my $style = shift || $self->{style};

    # not strictly needed, but makes for easier to read code
    my $restate  = $style eq 'restated'  ? 1 : 0;
    my $truncate = $style eq 'truncated' ? 1 : 0;

    # Avoid re-builds when possible.
    return if $restate  && defined( $self->{_restated} );
    return if $truncate && defined( $self->{_truncated} );

    # Disabled this for now, becomes problematic for various
    # methods such as "contains" in normal years.
    # return if ($restate || $truncate) && $self->{_weeks} == 52;

    my $pstart = $self->{_start}->clone;

    # This value is confusing only because it is 0-based unlike
    # the other month values.
    my $p1month = $self->{end_month} == 12 ? 0 : $self->{end_month};
    my @pweeks = ( 4, 4, 5, 4, 4, 5, 4, 4, 5, 4, 4, 5 );
    my $wkcnt = 52;

    # a truncated structure ignores the last week in a 53 week year
    if ( $self->{_weeks} == 53 && !$truncate ) {
        if ($restate) {

            # ignore the fist week and treat as any other 52 week year
            $pstart->add( days => 7 );
        }
        elsif ( $self->{leap_period} eq 'first' ) {
            $pweeks[$p1month] += 1;
            $wkcnt = 53;
        }
        else {
            $pweeks[ $self->{end_month} - 1 ] += 1;
            $wkcnt = 53;
        }
    }

    my $pdata = {
        summary => {
            style       => $style,
            year        => $self->{year},
            end_month   => $self->{end_month},
            end_dow     => $self->{end_dow},
            end_type    => $self->{end_type},
            leap_period => $self->{leap_period},
            weeks       => $wkcnt,
            start       => $pstart->ymd,
            end => undef,    # this is set after the cache is built
        }
    };

    my $wdata  = {};
    my $wkcntr = 1;
    for ( 0 .. 11 ) {
        my $p_index = ( $p1month + $_ ) % 12;

        my $pinfo = {
            period => $_ + 1,
            weeks  => $pweeks[$p_index],
            month  => $periodmonths[$p_index]
        };

        for my $pw ( 1 .. $pweeks[$p_index] ) {
            my $wksrc = $restate ? $wkcntr + 1 : $wkcntr;
            my $winfo = {
                week        => $wkcntr,
                period      => $_ + 1,
                period_week => $pw,
                start       => $self->{_weeks_raw}->{$wksrc}->{start},
                end         => $self->{_weeks_raw}->{$wksrc}->{end},
            };
            $pinfo->{start} = $winfo->{start} if $pw == 1;
            $pinfo->{end}   = $winfo->{end}   if $pw == $pweeks[$p_index];
            $wdata->{$wkcntr} = $winfo;
            $wkcntr++;
        }

        $pdata->{ $_ + 1 } = $pinfo;
    }
    $pdata->{summary}->{end} = $pdata->{12}->{end};

    if ( $self->{_weeks} == 52 ) {

        # Set style to 'fiscal' and assign the structure to all
        # three calendar types in a normal year to save time and space.
        $pdata->{summary}->{style} = 'fiscal';
        $self->{_fiscal} = $self->{_restated} = $self->{_truncated} = $pdata;
        $self->{_fiscal_weeks}    = $wdata;
        $self->{_restated_weeks}  = $wdata;
        $self->{_truncated_weeks} = $wdata;
    }
    else {
        $self->{"_$style"}         = $pdata;
        $self->{"_${style}_weeks"} = $wdata;
    }

    return;
}

# The end day for a specified year is trivial to determine. In normal
# accounting use, a fiscal year is named for the calendar year it ends in,
# not the year it begins.
sub _end5253 {
    my $self = shift;

    my $dt = DateTime->last_day_of_month(
        year      => $self->{year},
        month     => $self->{end_month},
        time_zone => 'floating'
    );

    my $eom_day = $dt->day;
    my $dt_dow  = $dt->dow;

    if ( $dt_dow > $self->{end_dow} ) {
        $dt->subtract( days => $dt_dow - $self->{end_dow} );
    }
    elsif ( $dt_dow < $self->{end_dow} ) {
        $dt->subtract( days => ( $dt_dow + 7 ) - $self->{end_dow} );
    }
    $dt->add( weeks => 1 )
      if $self->{end_type} eq 'closest' && $eom_day - $dt->day > 3;

    return $dt;
}

# Finding the starting day for a specified year is easy. Simply find
# the last day of the preceding year since the year is defined by
# the ending day and add 1 day to that. This avoids calendar year and month
# boundary issues.
sub _start5253 {
    my $self = shift;

    # do not assume it is safe to change the year attribute
    local $self->{year} = $self->year - 1;
    my $dt = $self->_end5253->add( days => 1 );

    return $dt;
}

# Determine the correct fiscal year for any given date
sub _find5253 {
    my $self = shift;

    my $y1 = $self->{_date}->year;

    # do not assume it is safe to change the year attribute
    local $self->{year} = $y1;

    my $e1 = $self->_end5253;
    return $y1 + 1 if $e1 < $self->{_date};

    my $s1 = $self->_start5253;
    return $y1 - 1 if $s1 > $self->{_date};

    return $y1;
}

sub has_leap_week {
    my $self = shift;

    return ( $self->{_weeks} == 53 ? 1 : 0 );
}

# return summary data about a calendar.
sub summary {
    my $self = shift;
    my %args = @_ == 1 ? ( style => shift ) : @_;

    $args{style} ||= $self->{style};
    croak 'Unknown parameter present' if scalar( keys(%args) ) > 1;

    my $cal = &{$_valid_cal_style}( $args{style} );

    my %cdata;
    for (qw( style year start end weeks )) {
        $cdata{$_} = $self->{"_$cal"}->{summary}->{$_};
    }

    return wantarray ? %cdata : \%cdata;
}

sub contains {
    my $self = shift;
    my %args = @_ == 1 ? ( date => shift ) : @_;

    $args{date}  ||= 'today';
    $args{style} ||= $self->{style};

    croak 'Unknown parameter present' if scalar( keys(%args) ) > 2;

    my $cal = &{$_valid_cal_style}( $args{style} );

    # Yes, a DT object set to "today" would work, but this is faster.
    # NOTE! This will break in 2038 on 32-bit builds!
    $args{date} = strftime( "%Y-%m-%d", localtime() )
      if ( lc( $args{date} ) eq 'today' );

    # _str2dt will croak on error
    my $date = &{$_str2dt}( $args{date} )->ymd;

    my $whash = $self->{"_${cal}_weeks"};
    my $cdata = $self->{"_$cal"}->{summary};

    # it is NOT an error if the date isn't in the calendar,
    # so return undef to differentiate this from an error condition
    return if $date lt $cdata->{start} || $date gt $cdata->{end};

    # since the date is in the calendar, let's return it's week,
    # and optionally, a structure with period and week number.

    my $w;
    for ( $w = 1 ; $date gt $whash->{$w}->{end} ; $w++ ) {

        # this should NEVER fire!
        croak 'FATAL ERROR! RAN OUT OF WEEKS' if $w > $cdata->{weeks};
    }
    my $p = $whash->{$w}->{period};

    return wantarray ? ( period => $p, week => $w ) : $w;
}

# Utiliy routine, hidden from public use, to prevent duplicate code in
# the period attribute accessors.
my $_period_attr = sub {
    my $self = shift;
    my $attr = shift;
    my %args = @_ == 1 ? ( period => shift ) : @_;

    $args{period} ||= 0;
    $args{style}  ||= $self->{style};

    croak 'Unknown parameter present' if scalar( keys(%args) ) > 2;

    my $cal = &{$_valid_cal_style}( $args{style} );

    if ( $args{period} < 1 || $args{period} > 12 ) {
        croak "Invalid period specified: $args{period}";
    }

    # return a copy so the guts hopefully can't be changed
    my %phash = %{ $self->{"_$cal"}->{ $args{period} } };

    return $attr eq 'period' ? %phash : $phash{$attr};
};

# Automate creating period attribute mehtods
for my $p_attr (qw( month start end weeks )) {
    my $method = join( '::', __PACKAGE__, "period_${p_attr}" );
    {
        no strict 'refs';
        *$method = sub {
            my $self = shift;

            return $self->$_period_attr( $p_attr, @_ );
          }
    }
}

sub period {
    my $self = shift;
    my %args = @_ == 1 ? ( period => shift ) : @_;

    my %phash = $self->$_period_attr( 'period', %args );

    return wantarray ? %phash : \%phash;
}

# Utiliy routine, hidden from public use, to prevent duplicate code in
# the week attribute accessors.
my $_week_attr = sub {
    my $self = shift;
    my $attr = shift;
    my %args = @_ == 1 ? ( week => shift ) : @_;

    $args{week}  ||= 0;
    $args{style} ||= $self->{style};

    croak 'Unknown parameter present' if scalar( keys(%args) ) > 2;

    my $cal = &{$_valid_cal_style}( $args{style} );

    if (   $args{week} < 1
        || $args{week} > $self->{"_$cal"}->{summary}->{weeks} )
    {
        croak "Invalid week specified: $args{week}";
    }

    # make a copy so the outside (hopefully) won't change the guts
    my %whash = %{ $self->{"_${cal}_weeks"}->{ $args{week} } };

    return $attr eq 'week' ? %whash : $whash{$attr};
};

sub week {
    my $self = shift;
    my %args = @_ == 1 ? ( week => shift ) : @_;

    my %whash = $self->$_week_attr( 'week', %args );

    return wantarray ? %whash : \%whash;
}

# Automate creating week attribute mehtods
for my $w_attr (qw( period period_week start end )) {
    my $method = join( '::', __PACKAGE__, "week_${w_attr}" );
    {
        no strict 'refs';
        *$method = sub {
            my $self = shift;

            return $self->$_week_attr( $w_attr, @_ );
          }
    }
}

1;

__END__