DateTime::Event::NameDay - Perl DateTime extension to work with namedays from various countries.

DateTime-Event-NameDay documentation Contained in the DateTime-Event-NameDay distribution.

Index

Code Index:

NAME

Top

DateTime::Event::NameDay - Perl DateTime extension to work with namedays from various countries.

SYNOPSIS

Top

  use DateTime::Event::NameDay;

  $nd = DateTime::Event::NameDay->new
    (country => "Sweden" , 
     date_args => {reform_date => $ref_dt} );

  @names = $nd->get_daynames( date => $dt);
  # Returns an array of the matching names

  $set = $nd->get_namedays(name => "Alfred");
  # Returns a DateTime::Set object that represents all of the 
  # namedays for Alfred

  # Alternately you can call it without using an object, but
  # now you must specify the country rather than using the
  # one (optionally) passed to the constructor
  @names = DateTime::Event::NameDay->get_daynames
               ( country => "France", date => $dt);
  $set   = DateTime::Event::NameDay->get_namedays
               ( country => "France", name => "Basile");

DESCRIPTION

Top

DateTime::Event::NameDay is a class that knows the name days for various countries. In some countries a person's nameday is more important than their birthday and gifts may be exchanged.

There are two major functions of the class, the first takes a DateTime object (of any kind) and works out the names that are associated with that day. The second takes a given name and returns a DateTime::Set object that can be used to work out what dates are for the given name.

Please note that the calculations are done using the DateTime::Calendar::Christian module to deal with dates that fall before the calendar reforms.

USAGE

Top

TODO

AUTHOR

Top

Ben Bennett <fiji at limey dot net>

COPYRIGHT

Top

Copyright (c) 2003 Ben Bennett. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Portions of the code in this distribution are derived from other works. Please see the CREDITS file for more details.

The full text of the license can be found in the LICENSE file included with this module.

SEE ALSO

Top

datetime@perl.org mailing list

http://datetime.perl.org/

DateTime-Event-NameDay documentation Contained in the DateTime-Event-NameDay distribution. 
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__