view release on metacpan or  search on metacpan

lib/DateTimeX/Fiscal/Fiscal5253.pm  view on Meta::CPAN

    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;