view release on metacpan or  search on metacpan

lib/Date/Pcalendar/Year.pm  view on Meta::CPAN

###############################################################################
##                                                                           ##
##    Copyright (c) 2000 - 2009 by Steffen Beyer.                            ##
##    All rights reserved.                                                   ##
##                                                                           ##
##    This package is free software; you can redistribute it                 ##
##    and/or modify it under the same terms as Perl itself.                  ##
##                                                                           ##
###############################################################################

package Date::Pcalendar::Year;

BEGIN { eval { require bytes; }; }
use strict;
use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION );

require Exporter;

@ISA = qw(Exporter);

@EXPORT = qw();

@EXPORT_OK = qw( check_year empty_period );

%EXPORT_TAGS = (all => [@EXPORT_OK]);

$VERSION = '6.1';

use Bit::Vector;
use Carp::Clan qw(^Date::);
use Date::Pcalc::Object qw(:ALL);

sub check_year
{
    my($year) = shift_year(\@_);

    if (($year < 1583) || ($year > 2299))
    {
        croak("given year ($year) out of range [1583..2299]");
    }
}

sub empty_period
{
    carp("dates interval is empty") if ($^W);
}

sub _invalid_
{
    my($item,$name) = @_;

    croak("date '$item' for day '$name' is invalid");
}

sub _check_init_date_
{
    my($item,$name,$year,$yy,$mm,$dd) = @_;

    &_invalid_($item,$name)
        unless (($year == $yy) && (check_date($yy,$mm,$dd)));
}

sub _check_callback_date_
{
    my($name,$year,$yy,$mm,$dd) = @_;

    croak("callback function for day '$name' returned invalid date")
        unless (($year == $yy) && (check_date($yy,$mm,$dd)));
}

sub _set_date_

lib/Date/Pcalendar/Year.pm  view on Meta::CPAN

    my($lang) = shift || 0;

    if ($_[1] =~ /^[a-zA-Z]+$/)
    {
        &_invalid_($item,$name) unless ($_[1] = Decode_Month($_[1]),$lang);
    }
    &_check_init_date_($item,$name,$year,@_);
    &_set_date_($self,$name,@_);
}

sub date2index
{
    my($self)       = shift;
    my($yy,$mm,$dd) = shift_date(\@_);
    my($year,$index);

    $year = ${$self}{'YEAR'};
    if ($yy != $year)
    {
        croak("given year ($yy) != object's year ($year)");
    }
    if ((check_date($yy,$mm,$dd)) &&
        (($index = (Date_to_Days($yy,$mm,$dd) - ${$self}{'BASE'})) >= 0) &&
        ($index < ${$self}{'DAYS'}))
    {
        return $index;
    }
    else { croak("invalid date ($yy,$mm,$dd)"); }
}

sub index2date
{
    my($self,$index) = @_;
    my($year,$yy,$mm,$dd);

    $year = ${$self}{'YEAR'};
    $yy = $year;
    $mm = 1;
    $dd = 1;
    if (($index == 0) ||
        (($index > 0) &&
         ($index < ${$self}{'DAYS'}) &&
         (($yy,$mm,$dd) = Add_Delta_Days($year,1,1, $index)) &&
         ($yy == $year)))
    {
        return Date::Pcalc->new($yy,$mm,$dd);
    }
    else { croak("invalid index ($index)"); }
}

sub new
{
    my($class)    = shift;
    my($year)     = shift_year(\@_);
    my($profile)  = shift;
    my($lang)     = shift || 0;
    my($self);

    &check_year($year);
    $self = { };
    $class = ref($class) || $class || 'Date::Pcalendar::Year';
    bless($self, $class);
    $self->init($year,$profile,$lang,@_);
    return $self;
}

sub init
{
    my($self)     = shift;
    my($year)     = shift_year(\@_);
    my($profile)  = shift;
    my($lang)     = shift || 0;
    my($days,$dow,$name,$item,$flag,$temp,$n);
    my(@weekend,@easter,@date);

    if (@_ > 0) { @weekend = @_; }
    else        { @weekend = (6,7); } # Mon=1 Tue=2 Wed=3 Thu=4 Fri=5 Sat=6 Sun=7
    &check_year($year);
    croak("given profile is not a HASH ref") unless (ref($profile) eq 'HASH');
    $days = Days_in_Year($year,12);
    ${$self}{'YEAR'} = $year;
    ${$self}{'DAYS'} = $days;
    ${$self}{'BASE'} = Date_to_Days($year,1,1);
    ${$self}{'TAGS'} = { };
    ${$self}{'HALF'} = Bit::Vector->new($days);
    ${$self}{'FULL'} = Bit::Vector->new($days);
    ${$self}{'WORK'} = Bit::Vector->new($days);
    $dow = Day_of_Week($year,1,1); # Mon=1 Tue=2 Wed=3 Thu=4 Fri=5 Sat=6 Sun=7
    foreach $item (@weekend)
    {
        $n = $item || 0;
        if (($n >= 1) and ($n <= 7))
        {
            $n -= $dow;
            while ($n < 0)                                     { $n += 7; }
            while ($n < $days) { ${$self}{'FULL'}->Bit_On( $n ); $n += 7; }
        }
    }
    @easter = Easter_Sunday($year);
    $lang = Decode_Language($lang) unless ($lang =~ /^\d+$/);
    $lang = Language() unless (($lang >= 1) and ($lang <= Languages()));
    foreach $name (keys %{$profile})
    {
        @date = ();
        $item = ${$profile}{$name};
        if (ref($item))
        {
            if (ref($item) eq 'CODE')
            {
                if (@date = &$item($year,$name))
                {
                    &_check_callback_date_($name,$year,@date);
                    &_set_date_($self,$name,@date);
                }
            }
            else { croak("value for day '$name' is not a CODE ref"); }
        }
        elsif ($item =~ /^ ([#:]?) ([+-]\d+) $/x)
        {
            $flag = $1;
            $temp = $2;