File Coverage

blib/lib/DateTime/Event/NameDay.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package DateTime::Event::NameDay;

use strict;

use vars qw ($VERSION);

$VERSION = '0.02';

use Carp;
use Params::Validate qw( validate SCALAR OBJECT HASHREF );

use DateTime;
use DateTime::Set;
use DateTime::Calendar::Christian;


my %namedays = ();


sub new {
    my $class = shift;
    my %p = validate( @_,
		      { country   => { type      => SCALAR,
				       default   => undef,
				       # Leave the heavy validation to set
				     },
			date_args => { type      => HASHREF,
				       default   => {},
				     },
		       },
		      );
    my $self = { };
    bless $self, $class;
    $self->set( %p );

    return $self;
}

sub set {
    my $self = shift;

    my %p = validate( @_,
                      { country   => { type      => SCALAR,
				       optional  => 1,
				       callbacks =>
				           {'known day mapping' => \&_check_country }
				     },
			date_args => { type      => HASHREF,
				       default   => {},
				     },
		      }
		      );

    if (defined $p{country}) {
	$self->{country} = lc $p{country};
    }

    if (defined $p{date_args}) {
	$self->{date_args} = $p{date_args};
    }

    return $self;
}

sub country {
    my ($self) = @_;
    return undef unless ref $self;
    return $self->{country};
}


sub date_args {
    my ($self) = @_;
    return {} unless ref $self;
    return $self->{date_args};
}

sub get_daynames
{
    my $self = shift;
    my %p = validate( @_,
                      { country => { type      => SCALAR,
				     optional  => 1,
				     callbacks =>
				           {'known day mapping' => \&_check_country }
				     },
			date    => { type      => OBJECT,
				     can       => 'utc_rd_values',
				     },
		      }
		      );

    # Work out our country
    my $country = lc $p{country};
    if (not defined $country) {
	$country = $self->country();

	croak "Unable to determine the correct country"
	    unless defined $country;
    }

    # Get the namedays for the given date
    # - Find our section
    my $nameday_info =
	$self->_init_nameday_country(namedays => \%namedays,
				     country  => $country);

    # - Convert to the Julian calendar
    my $adj_dt = DateTime::Calendar::Christian->from_object
	(object      => $p{date},
	 reform_date => $nameday_info->{reform_date},
	 %{ $self->date_args() },
	 );

    # - Get the appropriate nameday based on month number and day
    my $names = $nameday_info->{names}{ $adj_dt->month() }{ $adj_dt->day() };
    my @names = defined $names ? @$names : ();

    return @names;
}

sub get_namedays {
    my $self = shift;
    my %p = validate( @_,
                      { country => { type      => SCALAR,
				     optional  => 1,
				     callbacks =>
				           {'known day mapping' => \&_check_country }
				     },
			date_args => { type      => HASHREF,
				       default   => undef,
				     },
			name    => { type      => SCALAR,
				     },
		      }
		      );

    # Work out our country
    my $country = lc $p{country};
    if (not defined $country) {
	$country = $self->country();

	croak "Unable to determine the correct country"
	    unless defined $country;
    }

    # Work out the date args
    my $date_args = $p{date_args};
    if (not defined $date_args) {
	$date_args = ref $self ? $self->date_args() : {};
    }

    # Get the canonical name
    my $name = _clean_name( $p{name} );

    # Find the month and day for the given name
    my $nameday_info =
	$self->_init_nameday_country(namedays => \%namedays,
				     country  => $country);
    croak "Unknown name '$p{name}' for country '$p{country}'"
	unless exists $nameday_info->{reverse_names}{$name};
    my ($month, $day) = @{ $nameday_info->{reverse_names}{$name} };

    # Build a set of all of the days that the given name is for
    my $set = DateTime::Set->from_recurrence
	(next =>
	     sub { _make_recurrence($_[0], $nameday_info->{reform_date},
					   $month, $day, 1, $date_args);
	     },
	 previous =>
	     sub { _make_recurrence($_[0], $nameday_info->{reform_date},
					   $month, $day, -1, $date_args);
	     },
	 );

    return $set;
}

sub _make_recurrence {
    my ($last, $reform_date, $month, $day, $direction, $date_args) = @_;

    my $dt = DateTime::Calendar::Christian->from_object
	(object      => $last,
	 reform_date => $reform_date,
	 %$date_args,
	 );
    $dt->truncate(to => 'day');
    my $target = $dt->clone();
    $target->set( month => $month,
		  day   => $day,
		  );

    if ($direction == 1) {
	if ($dt >= $target) {
	    $target->add( years => 1);
	}
    } else {
	if ($dt <= $target) {
	    $target->subtract( years => 1);
	}
    }

    $target->set( month => $month,
		  day   => $day,
		  );

    return DateTime->from_object(object => $target, %$date_args);
}

sub _init_nameday_country {
    my $self = shift;
    my %args = @_;
    my $country  = $args{country};
    my $namedays = $args{namedays};


    return $namedays->{$country}
        if exists $namedays->{$country};

    # Okay, load the nameday info from the sub item
    my $package = "DateTime::Event::NameDay::$country";
    eval "require $package;";

    my ($reform_date, $data) = $package->nameday_data();
    my @data = split /\n/, $data;
    undef $data;

    $namedays->{$country} =
        {reform_date   => $reform_date,
	 names         => {},
	 reverse_names => {},
	 };
    my $forward = $namedays->{$country}{names};
    my $reverse = $namedays->{$country}{reverse_names};


    # Format of files:
    # - #s are comments, blank lines are ignored
    # - leading whitespace and trailing whitespace is ignorred
    # - months occur by number on their own line followed by a : (i.e. 1:)
    # - name days are given by number followed by a space then a , separated list of names
    #   surrounding whitespace is trimmed
    # - names starting with * are immovable holidays
    #
    # e.g.:
    # # Nameday file
    # # Source: www.whatever.com
    #
    # 1: # January
    #   1 *New Year's Day
    #   2 Svea
    #   3 Alfred, Alfrida
    #   ...
    #
    # 2: # February
    #   ...

    my $month = undef;
    foreach my $line (@data) {
	$line =~ s/\s*\#.*//;
	next if $line =~ /^\s*$/;

	if ($line =~ /^\s*(\d+)\s+(.*)/) {
	    my ($day, $names) = ($1, $2);

	    # We have a day
	    croak "Malformed nameday file for '$package': Missing month before line '$line'"
		unless defined $month;

	    # Split the names apart and store the forward mapping
	    # For the moment remove the * indicating holidays
	    $names =~ s/\s+$//;
	    my @names = map { s/^*//; $_ } split /\s*,\s*/, $names;
	    $forward->{$month}{$day} = \@names;

	    # Store the reverse mapping
	    foreach my $name (@names) {
		my $n = _clean_name($name);
		croak "Duplicate name '$name' (cleaned '$n')"
		    if exists $reverse->{$n};
		$reverse->{$n} = [$month, $day];
	    }
	}
	elsif ($line =~ /^\s*(\d+):\s*$/) {
	    # Change the month
	    $month = $1;
	}
    }
    @data = ();

    return $namedays->{$country};
}

# Get the canonical sort string for the name... all lowercase
# I would like to make it insensitive to accents too, but there
# is no good way to do that yet
sub _clean_name {
    my $name = shift;

    $name = lc $name;
#    $name = NFD( lc($name) );
#    $name =~ s/\pM//g;

    return $name;
}

# See if the given country is one we support
sub _check_country {
    my $country = lc shift;

    # See if we can load the module
    my $package = "DateTime::Event::NameDay::$country";
    eval "require $package;";

    return $@ ? 0 : 1;
}

1;

__END__