File Coverage

blib/lib/Date/Gregorian/Business.pm

Criterion	Covered	Total	%
statement	252	252	100.0
branch	84	86	97.6
condition	54	58	93.1
subroutine	38	38	100.0
pod	13	14	92.8
total	441	448	98.4

# Copyright (c) 2005-2007 Martin Becker.  All rights reserved.
# This package is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# $Id: Business.pm,v 1.5 2007/06/18 06:11:56 martin Stab $

package Date::Gregorian::Business;

use strict;
use integer;
use Date::Gregorian;
use base qw(Date::Gregorian);
use vars qw($VERSION);

# ----- object definition -----

# ............. index ..............      # .......... value ..........
use constant F_OFFSET    => Date::Gregorian::NFIELDS;
use constant F_ALIGNMENT => F_OFFSET+0;  # 0 = morning, 1 = evening
use constant F_MAKE_CAL  => F_OFFSET+1;  # sub (date, year) => [calendar]
use constant F_YEAR      => F_OFFSET+2;  # currently initialized year
use constant F_CALENDAR  => F_OFFSET+3;  # list of: 1 = biz, 0 = holiday
use constant NFIELDS     => F_OFFSET+4;

# ----- predefined variables -----

$VERSION = 0.04;

# elements of default biz calendars
my $skip_weekend    = [ 0,  0,  0,  0,  0,  2,  1];  # Sat, Sun -> Mon
my $avoid_weekend   = [ 0,  0,  0,  0,  0, -1,  1];  # Sat -> Fri, Sun -> Mon
my $next_monday     = [ 0,  6,  5,  4,  3,  2,  1];  # set_weekday(Mon, ">=")
my $prev_monday     = [-7, -1, -2, -3, -4, -5, -6];  # set_weekday(Mon, "<")
my $next_wednesday  = [ 2,  1,  0,  6,  5,  4,  3];  # set_weekday(Wed, ">=")
my $next_thursday   = [ 3,  2,  1,  0,  6,  5,  4];  # set_weekday(Thu, ">=")
my $saturday_sunday = [ 5,  6];

# some biz calendars known by default
my %samples = (
    'us' => [
	$saturday_sunday,
	[
	    [ 1,  1, $skip_weekend],	# New Year's day
	    [ 1, 15, $next_monday],	# Martin Luther King
	    [ 2, 15, $next_monday],	# President's day
	    [ 6,  1, $prev_monday],	# Memorial day
	    [ 7,  4, $avoid_weekend],	# Independence day
	    [ 9,  1, $next_monday],	# Labor day
	    [10,  8, $next_monday],	# Columbus day
	    [11, 11, $avoid_weekend],	# Veteran's day
	    [11, 22, $next_thursday],	# Thanksgiving day
	    [12, 25, $skip_weekend],	# Christmas day
	],
    ],
    'de' => [
	$saturday_sunday,
	[
	    [ 1,  1],					# New Year's day
	    [ 0, -2],					# Good Friday
	    [ 0,  1],					# Easter Monday
	    [ 5,  1],					# Labour day
	    [ 0, 50],					# Pentecost Monday
	    [ 6, 17, undef,           [1954,  1989]],	# German Unity
	    [10,  3, undef,           [1990, undef]],	# German Unity
	    [11, 16, $next_wednesday, [undef, 1994]],	# Penitence day
	    [12, 25],					# Christmas day
	    [12, 26],					# 2nd day of Christmas
	],
    ],
);
$samples{'de_BW'} = [
    $saturday_sunday,
    [
	@{$samples{'de'}->[1]},
	[ 1,  6],					# Epiphany
	[ 0, 39],					# Ascension day
	[ 0, 60],					# Corpus Christi
	[11,  1],					# All Saints day
    ]
];
$samples{'de_BY'} = [
    $saturday_sunday,
    [
	@{$samples{'de_BW'}->[1]},
	[ 8, 15],					# Assumption day
    ]
];
$samples{'de_BW2'} = _more_xmas(@{$samples{'de_BW'}});
$samples{'de_BY2'} = _more_xmas(@{$samples{'de_BY'}});

my $default_configuration = 'us';

# ----- private functions and methods -----

# check whether a given year is in a range or general selection
sub _select_year {
    my ($self, $day, $year) = @_;
    my $selection = $day->[3];
    if (!ref $selection) {
	return $year == $selection;
    }
    if ('CODE' eq ref $selection) {
	return $selection->($self, $year, @{$day}[0, 1]);
    }
    return
	(!defined($selection->[0]) || $selection->[0] <= $year) &&
	(!defined($selection->[1]) || $year <= $selection->[1]);
}

# make_cal factory, generating a calendar generator enclosing a configuration
sub _make_make_cal {
    my ($weekly, $yearly) = @_;

    return sub {
	my ($date, $year) = @_;
	my $firstday = $date->new->set_yd($year, 1, 1);
	my $first_wd = $firstday->get_weekday;
	my $someday  = @$yearly && $firstday->new;
	my $easter   = undef;
	my $index;
	my $calendar = $firstday->get_empty_calendar($year, $weekly);
	foreach my $day (@$yearly) {
	    if (!defined($day->[3]) || _select_year($someday, $day, $year)) {
		if ($day->[0]) {
		    $index =
			$someday->set_ymd($year, @{$day}[0, 1])
			->get_days_since($firstday);
		    $index += $day->[2]->[$someday->get_weekday] if $day->[2];
		}
		else {
		    if (!defined $easter) {
			$easter =
			    $someday->set_easter($year)
			    ->get_days_since($firstday);
		    }
		    $index = $easter + $day->[1];
		    $index += $day->[2]->[(496 + $day->[1]) % 7] if $day->[2];
		}
		$calendar->[$index] = 0 if 0 <= $index && $index < @$calendar;
	    }
	}
	return $calendar;
    };
}

# experimental feature: half business days on Dec 24 and 31, if not weekend
sub _more_xmas {
    my $make_cal = _make_make_cal(@_);
    return sub {
	my $calendar = $make_cal->(@_);
	if (8 <= @$calendar && $calendar->[-1]) {
	    @{$calendar}[-8, -1] = (0.5, 0.5);
	}
	return $calendar;
    }
}

# fetch biz calendar for given year, initializing it if necessary
sub _calendar {
    my ($self, $year) = @_;

    if (!defined($self->[F_YEAR]) || $year != $self->[F_YEAR]) {
	$self->[F_YEAR] = $year;
	$self->[F_CALENDAR] = $self->[F_MAKE_CAL]->($self, $year);
    }
    return $self->[F_CALENDAR];
}

# ----- public methods -----

sub get_empty_calendar {
    my ($date, $year, $weekly_nonbiz) = @_;

    my $firstday = $date->new->set_yd($year, 1);
    my $days     = $firstday->get_days_in_year($year);
    my $first_wd = $firstday->get_weekday;

    my @week = (1) x 7;
    foreach my $day (@$weekly_nonbiz) {
	$week[$day] = 0;
    }
    @week = @week[$first_wd .. 6, 0 .. $first_wd-1] if $first_wd;

    my @calendar = ((@week) x ($days / 7), @week[0 .. ($days % 7)-1]);
    return \@calendar;
}

sub define_configuration {
    my ($class, $name, $configuration) = @_;
    my $type = defined($configuration)? ref($configuration): '!';

    if (!$type) {
	return undef if !exists $samples{$configuration};
	$configuration = $samples{$configuration};
    }
    elsif ('ARRAY' ne $type && 'CODE' ne $type) {
	return undef;
    }
    $samples{$name} = $configuration;
    return $class;
}

sub configure_business {
    my ($self, $configuration) = @_;
    my $type = defined($configuration)? ref($configuration): '!';

    if (!$type) {
	return undef if !exists $samples{$configuration};
	$configuration = $samples{$configuration};
	$type = ref $configuration;
    }
    if (ref $self) {
	# instance method: configure this object
	if ('CODE' eq $type) {
	    $self->[F_MAKE_CAL] = $configuration;
	}
	elsif ('ARRAY' eq $type) {
	    $self->[F_MAKE_CAL] = _make_make_cal(@$configuration);
	}
	else {
	    return undef;
	}
	$self->[F_YEAR] = $self->[F_CALENDAR] = undef;
    }
    else {
	# class method: configure default
	if ('ARRAY' ne $type && 'CODE' ne $type) {
	    return undef;
	}
	$default_configuration = $configuration;
    }

    return $self;
}

sub new {
    my ($class_or_object, $configuration) = @_;
    my $self = $class_or_object->SUPER::new;

    if (!ref $class_or_object) {
	$self->[F_ALIGNMENT] = 0;
    }
    if (defined $configuration) {
	return $self->configure_business($configuration);
    }
    elsif (!ref $class_or_object) {
	return $self->configure_business($default_configuration);
    }
    return $self;
}

sub align {
    my ($self, $alignment) = @_;
    $self->[F_ALIGNMENT] = $alignment? 1: 0;
    return $self;
}

sub get_alignment {
    my $self = $_[0];
    return $self->[F_ALIGNMENT];
}

# tweak super class to provide default alignment
sub Date::Gregorian::get_alignment {
    return 0;
}

sub is_businessday {
    my ($self) = @_;
    my ($year, $day) = $self->get_yd;

    return $self->_calendar($year)->[$day-1];
}

# count business days, proceeding into the future
# $days gives the interval measured in real days (positive)
# alignment tells where to start: 0 = at current day, 1 = the day after
# 0 <= result <= $days
sub _count_businessdays_up {
    my ($self, $days) = @_;
    my ($year, $day) = $self->get_yd;
    my $calendar = $self->_calendar($year);
    my $result = 0;

    --$day if !$self->[F_ALIGNMENT];
    while (0 < $days) {
	while (@$calendar <= $day) {
	    $calendar = $self->_calendar(++$year);
	    $day = 0;
	}
	do {
	    no integer;
	    $result += $calendar->[$day];
	};
	++$day;
	--$days;
    }
    return $result;
}

# count business days, proceeding into the past
# $days gives the interval measured in real days (positive)
# alignment tells where to start: 1 = at current day, 0 = the day before
# 0 <= result <= $days
sub _count_businessdays_down {
    my ($self, $days) = @_;
    my ($year, $day) = $self->get_yd;
    my $calendar = $self->_calendar($year);
    my $result = 0;

    --$day if !$self->[F_ALIGNMENT];
    while (0 < $days) {
	--$day;
	--$days;
	while ($day < 0) {
	    $calendar = $self->_calendar(--$year);
	    $day = $#$calendar;
	}
	do {
	    no integer;
	    $result += $calendar->[$day];
	};
    }
    return $result;
}

#   Alignments and results             Now:0   Now:1   Now:0   Now:1
#   b--(H)--b---b---b--(H)--b---b      Then:0  Then:1  Then:1  Then:0
#      Then            Now              3       3       3       3
#          Then        Now              3       2       2       3
#      Then                Now          3       4       3       4
#          Then            Now          3       3       2       4
#   b--(H)--b---b---b--(H)--b---b
#      Now             Then            -3      -3      -3      -3
#      Now                 Then        -3      -4      -4      -3
#          Now         Then            -3      -2      -3      -2
#          Now             Then        -3      -3      -4      -2
#   b--(H)--b---b---b--(H)--b---b

sub get_businessdays_since {
    my ($self, $then) = @_;
    my $delta =
	$self->get_days_since($then) +
	$self->[F_ALIGNMENT] - $then->get_alignment;
    if ($delta > 0) {
	return $self->_count_businessdays_down($delta);
    }
    if ($delta < 0) {
	return -$self->_count_businessdays_up(-$delta);
    }
    return 0;
}

sub get_businessdays_until {
    my ($self, $then) = @_;
    my $delta =
	$self->get_days_since($then) +
	$self->[F_ALIGNMENT] - $then->get_alignment;
    if ($delta > 0) {
	return -$self->_count_businessdays_down($delta);
    }
    if ($delta < 0) {
	return $self->_count_businessdays_up(-$delta);
    }
    return 0;
}

sub set_next_businessday {
    my ($self, $relation) = @_;
    my ($year, $day) = $self->get_yd;
    my $calendar = $self->_calendar($year);

    --$day;
    return $self if '<' ne $relation && '>' ne $relation && $calendar->[$day];
    if ('<' eq $relation || '<=' eq $relation) {
	do {
	    --$day;
	    while ($day < 0) {
		$calendar = $self->_calendar(--$year);
		$day = $#$calendar;
	    }
	}
	while (!$calendar->[$day]);
    }
    else {
	do {
	    ++$day;
	    while (@$calendar <= $day) {
		$calendar = $self->_calendar(++$year);
		$day = 0;
	    }
	}
	while (!$calendar->[$day]);
    }
    return $self->set_yd($year, $day+1);
}

sub iterate_businessdays_upto {
    my ($self, $limit, $rel) = @_;
    my $days = ($rel eq '<=') - $self->get_days_since($limit);
    my ($year, $day, $calendar);
    if (0 < $days) {
	($year, $day) = $self->get_yd;
	--$day;
	$calendar = $self->_calendar($year);
    }
    return sub {
	while (0 < $days) {
	    while (@$calendar <= $day) {
		$calendar = $self->_calendar(++$year);
		$day = 0;
	    }
	    --$days;
	    if ($calendar->[$day++]) {
		return $self->set_yd($year, $day);
	    }
	}
	return undef;
    };
}

sub iterate_businessdays_downto {
    my ($self, $limit, $rel) = @_;
    my $days = $self->get_days_since($limit) + ($rel ne '>');
    my ($year, $day, $calendar);
    if (0 < $days) {
	($year, $day) = $self->get_yd;
	--$day;
	$calendar = $self->_calendar($year);
    }
    return sub {
	while (0 < $days) {
	    while ($day < 0) {
		$calendar = $self->_calendar(--$year);
		$day = $#$calendar;
	    }
	    --$days;
	    if ($calendar->[$day--]) {
		return $self->set_yd($year, $day+2);
	    }
	}
	return undef;
    };
}

#   -b----H----b----b----H----b-
#     ^  ^ ^  ^
#     0       0 1  1 2       2

sub add_businessdays {
    no integer;
    my ($self, $days, $new_alignment) = @_;
    my ($year, $day) = $self->get_yd;
    -- $day;
    my $calendar = $self->_calendar($year);
    my $alignment = $self->[F_ALIGNMENT];

    # handle alignment change
    if (defined($new_alignment) && ($alignment xor $new_alignment)) {
	if ($new_alignment) {
	    $alignment = $self->[F_ALIGNMENT] = 1;
	    $days -= $calendar->[$day];
	}
	else {
	    $alignment = $self->[F_ALIGNMENT] = 0;
	    $days += $calendar->[$day];
	}
    }

    if (0 < $days || !$days && !$alignment) {
	# move forward in time
	$days -= $calendar->[$day] if !$alignment;
	while (0 < $days || !$days && !$alignment) {
	    ++$day;
	    while (@$calendar <= $day) {
		$calendar = $self->_calendar(++$year);
		$day = 0;
	    }
	    $days -= $calendar->[$day];
	}
    }
    else {
	# move backwards in time
	$days += $calendar->[$day] if $alignment;
	while ($days < 0 || !$days && $alignment) {
	    --$day;
	    while ($day < 0) {
		$calendar = $self->_calendar(--$year);
		$day = $#$calendar;
	    }
	    $days += $calendar->[$day];
	}
    }

    return $self->set_yd($year, $day+1);
}

1;

__END__