File Coverage

blib/lib/Date/Japanese/Era.pm

Criterion	Covered	Total	%
statement	83	87	95.4
branch	28	34	82.3
condition	6	9	66.6
subroutine	16	16	100.0
pod	5	5	100.0
total	138	151	91.3

package Date::Japanese::Era;

use strict;
our $VERSION = '0.08';

use Carp;
use constant END_OF_LUNAR => 1872;

our(%ERA_TABLE, %ERA_JA2ASCII, %ERA_ASCII2JA);

sub import {
    my $self = shift;
    if (@_) {
	my $table = shift;
	eval qq{use Date::Japanese::Era::Table::$table};
	die $@ if $@;
    }
    else {
	require Date::Japanese::Era::Table;
	import Date::Japanese::Era::Table;
    }
}

sub new {
    my($class, @args) = @_;
    my $self = bless {
	name => undef,
	year => undef,
	gregorian_year => undef,
    }, $class;

    if (@args == 3) {
	$self->_from_ymd(@args);
    }
    elsif (@args == 2) {
	$self->_from_era(@args);
    }
    elsif (@args == 1) {
	$self->_dwim(@args);
    }
    else {
        croak "odd number of arguments: ", scalar(@args);
    }

    return $self;
}

sub _from_ymd {
    my($self, @ymd) = @_;

    if ($ymd[0] <= END_OF_LUNAR) {
	Carp::carp("In $ymd[0] they didn't use gregorious date.");
    }

    require Date::Calc;

    # XXX can be more efficient
    for my $era (keys %ERA_TABLE) {
	my $data = $ERA_TABLE{$era};
	if (Date::Calc::Delta_Days(@{$data}[1..3], @ymd) >= 0 &&
            Date::Calc::Delta_Days(@ymd, @{$data}[4..6]) >= 0) {
	    $self->{name} = $era;
	    $self->{year} = $ymd[0] - $data->[1] + 1;
	    $self->{gregorian_year} = $ymd[0];
	    return;
	}
    }

    croak "Unsupported date: ", join('-', @ymd);
}

sub _from_era {
    my($self, $era, $year) = @_;
    if ($era =~ /^[a-zA-Z]+$/) {
	$era = $self->_ascii2ja($era);
    }

    unless (utf8::is_utf8($era)) {
        croak "Era needs to be Unicode string";
    }

    my $data = $ERA_TABLE{$era}
        or croak "Unknown era name: $era";

    my $g_year = $data->[1] + $year - 1;
    if ($g_year > $data->[4]) {
	croak "Invalid combination of era and year: $era-$year";
    }

    $self->{name} = $era;
    $self->{year} = $year;
    $self->{gregorian_year} = $g_year;
}

sub _dwim {
    my($self, $str) = @_;

    unless (utf8::is_utf8($str)) {
        croak "Era should be in Unicode";
    }

    my $gengou_re = join "|", keys %ERA_JA2ASCII;

    $str =~ s/^($gengou_re)//
        or croak "Can't extract Era from $str";

    my $era = $1;

    $str =~ s/\x{5E74}$//; # nen
    my $year = _number($str);

    unless (defined $year) {
        croak "Can't parse year from $str";
    }

    $self->_from_era($era, $year);
}

sub _number {
    my $str = shift;

    $str = "1" if $str eq "\x{5143}"; # gan
    $str =~ s/([\x{FF10}-\x{FF19}])/;ord($1)-0xff10/eg;

    if ($str =~ /^\d+$/) {
        return $str;
    } else {
        eval { require Lingua::JA::Numbers };
        if ($@) {
            croak "require Lingua::JA::Numbers to read Japanized numbers";
        }

        return Lingua::JA::Numbers::ja2num($str);
    }
}

sub _ascii2ja {
    my($self, $ascii) = @_;
    return $ERA_ASCII2JA{$ascii} || croak "Unknown era name: $ascii";
}

sub _ja2ascii {
    my($self, $ja) = @_;
    return $ERA_JA2ASCII{$ja} || croak "Unknown era name: $ja";
}

sub name {
    my $self = shift;
    return $self->{name};
}

*gengou = \&name;

sub name_ascii {
    my $self = shift;
    return $self->_ja2ascii($self->name);
}

sub year {
    my $self = shift;
    return $self->{year};
}

sub gregorian_year {
    my $self = shift;
    return $self->{gregorian_year};
}

1;
__END__