File Coverage

blib/lib/Date/Tolkien/Shire.pm

Criterion	Covered	Total	%
statement	132	162	81.4
branch	30	56	53.5
condition	6	13	46.1
subroutine	28	36	77.7
pod	22	22	100.0
total	218	289	75.4

package Date::Tolkien::Shire;

use strict;
use warnings;

use Date::Tolkien::Shire::Data qw{
    __date_to_day_of_year
    __day_of_week
    __day_of_year_to_date
    __format
    __holiday_name
    __is_leap_year
    __month_name
    __on_date
    __rata_die_to_year_day
    __trad_weekday_name
    __weekday_name
    __year_day_to_rata_die
    GREGORIAN_RATA_DIE_TO_SHIRE
};
use Time::Local;

our $ERROR;
our $VERSION = '1.903_01';

sub new {
    my ( $class, $date, %arg ) = @_;
    my $self = {};
    $ERROR = '';
    bless($self, $class);
    $self->set_date($date) if defined($date);
    $self->set_accented( $arg{accented} );
    $self->set_traditional( $arg{traditional} );
    return $self;
}

sub error {
    return $ERROR;
}

sub today {
    my ( $class, %arg ) = @_;
    # TODO If I ever do time-of-day support, this will have to change.
    my $self = $class->new( time );
    $self->set_accented( $arg{accented} );
    $self->set_traditional( $arg{traditional} );
    return $self;
}

sub from_shire {
    my ( $class, %arg ) = @_;
    my $accented = delete $arg{accented};
    my $traditional = delete $arg{traditional};
    my $self = $class->new()->set_shire( %arg );
    $self->set_accented( $accented );
    $self->set_traditional( $traditional );
    return $self;
}

sub set_date {
    my ( $self, $date ) = @_;
    $ERROR = '';

    if ( ! defined $date ) {
	$ERROR = 'You must pass in a date to set me equal to';
	return $self;
    }

    my $ref = ref $date;

    if ( __PACKAGE__ eq $ref ) {

	# Shallow clone
	%{ $self } = %{ $date };

    } elsif ( ! $ref ) {

	# TODO this will throw warnings if the date is not a number.
	my ( $greg_year, $greg_day_of_year ) = ( localtime $date )[5,7];

	my $greg_rata_die = __year_day_to_rata_die(
	    $greg_year + 1900,
	    $greg_day_of_year + 1,
	);

	$self->set_rata_die( $greg_rata_die );

    } else {
	$ERROR .= 'The date you gave is invalid';
    }
    return $self;
}

sub set_rata_die {
    my ( $self, $greg_rata_die ) = @_;

    my $shire_rata_die = $greg_rata_die + GREGORIAN_RATA_DIE_TO_SHIRE;

    my ( $shire_year, $shire_day_of_year ) = __rata_die_to_year_day(
	$shire_rata_die );

    my ( $shire_month, $shire_day ) = __day_of_year_to_date(
	$shire_year,
	$shire_day_of_year,
    );

    $self->{year} = $shire_year;
    $self->{month} = $shire_month;
    if ( $shire_month ) {
	$self->{holiday} = 0;
	$self->{monthday} = $shire_day;
    } else {
	$self->{holiday} = $shire_day;
	$self->{monthday} = 0;
    }
    $self->{weekday} = __day_of_week( $shire_month, $shire_day );

    return $self;
}

{
    my %legal = map { $_ => 1 } qw{ year month day holiday };

    sub set_shire {
	my ( $self, %arg ) = @_;

	foreach my $key ( keys %arg ) {
	    $legal{$key}
		or return _error_out( $self,
		"No such argument as '$key'" );
	    $arg{$key} =~ m/ \A [0-9]+ \z /smx
		or return _error_out( $self,
		"Argument '$key' must be an unsigned integer" );
	}

	defined $arg{year}
	    or return _error_out( $self, 'Year must be specified' );

	if ( $arg{month} ) {
	    $arg{holiday}
		and return _error_out( $self,
		'Month and holiday must not both be specified' );
	    if ( $arg{month} ) {
		$arg{holiday} = 0;
		$arg{day} ||= 1;
	    } else {
		$arg{holiday} = $arg{day};
		$arg{day} = 0;
	    }
	} else {
	    $arg{holiday} ||= 1;
	    $arg{month} = $arg{day} = 0;
	}

	$ERROR = '';
	$arg{weekday} = __day_of_week( $arg{month}, $arg{day} ||
	    $arg{holiday} );
	$arg{monthday} = delete $arg{day};
	%{ $self } = %arg;
	return $self;
    }
}

sub set_accented {
    my ( $self, $value ) = @_;
    $self->{accented} = $value;
    return $self;
}

sub set_traditional {
    my ( $self, $value ) = @_;
    $self->{traditional} = $value;
    return $self;
}

sub time_in_seconds {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    my $shire_day_of_year = __date_to_day_of_year(
	$self->{year},
	$self->{month},
	$self->{monthday} || $self->{holiday},
    );

    my $shire_rata_die = __year_day_to_rata_die(
	$self->{year},
	$shire_day_of_year,
    );

    my $greg_rata_die = $shire_rata_die - GREGORIAN_RATA_DIE_TO_SHIRE;

    my ( $greg_year, $greg_day_of_year ) = __rata_die_to_year_day(
	$greg_rata_die );

    my @monthlen = ( 31, 28 + __is_leap_year( $greg_year ),
	31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );

    my $greg_day = $greg_day_of_year;
    for ( my $greg_month = 0; $greg_month < @monthlen; $greg_month++ ) {
	$greg_day <= $monthlen[$greg_month]
	    and return timelocal(
	    0, 0, 0, $greg_day, $greg_month, $greg_year );
	$greg_day -= $monthlen[$greg_month];
    }

    $ERROR = "Programming error: computed day $greg_day_of_year in Gregorian year $greg_year";
    return 0;
}

# TODO if I do time of day, epoch() will return it, whereas
# time_in_seconds will not.
*epoch = \&time_in_seconds;	# sub epoch;

sub weekday {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return __weekday_name( $self->{weekday} );
}

sub weekday_number {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return $self->{weekday};
}

sub trad_weekday {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return __trad_weekday_name( $self->{weekday} );
}

sub month {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return __month_name( $self->{month} );
}

sub day {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return $self->{monthday};
}

sub holiday {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return __holiday_name( $self->{holiday} );
}

sub year {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return $self->{year};
}

use overload
    '<=>' => \&_space_ship,
    'cmp' => \&_space_ship,
    '""'  => \&as_string,
    ;

#All the other operators come automatically once this one is defined

sub _space_ship {
    my ($date1, $date2) = @_;
    my $time1 = $date1->time_in_seconds();
    $ERROR .= " on left operand" if $ERROR;
    my $time2 = $date2->time_in_seconds();
    $ERROR .= " on right operand" if $ERROR;
    return $time1 <=> $time2;
} #end sub _space_ship

sub accented { return $_[0]->{accented} }

sub as_string {
    # I can not just assign to $_[1] because it is an alias for the
    # argument, thus the possibility of spooky action at a distance.
    splice @_, 1, $#_, '%Ex';
    goto &strftime;
}

sub on_date {
    # I can not just assign to $_[1] because it is an alias for the
    # argument, thus the possibility of spooky action at a distance.
    splice @_, 1, $#_, '%Ex%n%En%Ed';
    goto &strftime;
}

sub strftime {
    my ( $self, @fmt ) = @_;

    $self->_has_date()
	or return 0;

    return wantarray ?
	( map { __format( $self, $_ ) } @fmt ) :
	__format( $self, $fmt[0] );
}

sub traditional { return $_[0]->{traditional} }

# Date::Tolkien::Shire::Data::__format() date object interface

*__fmt_shire_year = \&year;	# sub __fmt_shire_year;

sub __fmt_shire_month {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return $self->{month};
}

sub __fmt_shire_day {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return $self->{monthday} || $self->{holiday};
}

sub __fmt_shire_day_of_week {
    my ( $self ) = @_;

    $self->_has_date()
	or return 0;

    return $self->{weekday};
}

# sub __fmt_shire_hour; sub __fmt_shire_minute; sub __fmt_shire_second;
# sub __fmt_shire_nanosecond;
*__fmt_shire_hour = *__fmt_shire_minute = *__fmt_shire_second =
    *__fmt_shire_nanosecond = sub { 0 };

# The interface definition requires this to return undef, since the zone
# is undefined. See Date::Tolkien::Shire::Data.
sub __fmt_shire_zone_offset { return undef }	## no critic (ProhibitExplicitReturnUndef)
sub __fmt_shire_zone_name { return '' }

*__fmt_shire_epoch = \&epoch;			# sub __fmt_shire_epoch;
*__fmt_shire_accented = \&accented;	# sub __fmt_shire_accented;
*__fmt_shire_traditional = \&traditional;	# sub __fmt_shire_traditional;

sub _error_out {
    my ( $return, @msg ) = @_;
    $ERROR = join ' ', @msg;
    return $return;
}

sub _has_date {
    my ( $self ) = @_;
    if ( grep { ! defined $self->{$_} }
	qw{ holiday month monthday weekday year } ) {
	$ERROR = 'You must set a date first';
	return 0;
    } else {
	$ERROR = '';
	return 1;
    }
}

1;

__END__