File Coverage

blib/lib/DateTime/Format/Japanese.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

# $Id: /mirror/datetime/DateTime-Format-Japanese/trunk/lib/DateTime/Format/Japanese.pm 69499 2008-08-24T16:17:57.045540Z lestrrat  $

package DateTime::Format::Japanese;
use strict;
use warnings;

use Params::Validate qw( validate validate_pos SCALAR BOOLEAN );
use Encode();
use Exporter;
use vars qw(@ISA $VERSION %EXPORT_TAGS);
use DateTime::Format::Japanese::Common qw(:constants);
use DateTime::Calendar::Japanese::Era;
BEGIN
{
    $VERSION     = '0.04000';
    @ISA         = qw(Exporter);
    %EXPORT_TAGS = (
        constants => [ qw(
            FORMAT_KANJI_WITH_UNIT FORMAT_KANJI FORMAT_ZENKAKU
            FORMAT_ROMAN FORMAT_ERA FORMAT_GREGORIAN) ]
    );
    Exporter::export_ok_tags('constants');
}

# XXX - OBJECT DEFINITION

my %NewValidate = (
	output_encoding => { default => 'utf8' },
	input_encoding => { default => 'utf8' },
    number_format => {
        type    => SCALAR,
        default => FORMAT_KANJI
    },
    year_format   => {
        type    => SCALAR,
        default => FORMAT_ERA
    },
    with_gregorian_marker => {
        type    => BOOLEAN,
        default => 0
    },
    with_bc_marker => {
        type    => BOOLEAN,
        default => 0
    },
    with_ampm_marker => {
        type    => BOOLEAN,
        default => 0
    },
    with_day_of_week => {
        type    => BOOLEAN,
        default => 0
    }
);

sub new
{
    my $class = shift;
    my %hash  = validate(@_, \%NewValidate);
    my $self  = bless \%hash, $class;
}

sub input_encoding
{
	my $self = shift;
	my $ret = $self->{input_encoding};
	if (@_) {
		$self->{input_encoding} = shift;
	}
	return $ret;
}

sub output_encoding
{
	my $self = shift;
	my $ret = $self->{output_encoding};
	if (@_) {
		$self->{output_encoding} = shift;
	}
	return $ret;
}

sub number_format
{
    my $self    = shift;
    my $current = $self->{number_format};
    if (@_) {
        my($val) = validate_pos(@_, {
            type => SCALAR,
            callbacks => {
                'is valid number_format' => \&DateTime::Format::Japanese::Common::_valid_number_format
            }
        });
        $self->{number_format} = $val;
    }
    return $current;
}

sub year_format
{
    my $self    = shift;
    my $current = $self->{year_format};
    if (@_) {
        my($val) = validate_pos(@_, {
            type => SCALAR,
            callbacks => {
                'is valid year_format' => \&DateTime::Format::Japanese::Common::_valid_year_format
            }
        });
        $self->{year_format} = $val;
    }
    return $current;
}

sub with_gregorian_marker
{
    my $self    = shift;
    my $current = $self->{with_gregorian_marker};
    if (@_) {
        my($val) = validate_pos(@_, { type => BOOLEAN });
        $self->{with_gregorian_marker} = $val;
    }
    return $current;
}

sub with_bc_marker
{
    my $self    = shift;
    my $current = $self->{with_bc_marker};
    if (@_) {
        my($val) = validate_pos(@_, { type => BOOLEAN });
        $self->{with_bc_marker} = $val;
    }
    return $current;
}

sub with_ampm_marker
{
    my $self    = shift;
    my $current = $self->{with_ampm_marker};
    if (@_) {
        my($val) = validate_pos(@_, { type => BOOLEAN });
        $self->{with_ampm_marker} = $val;
    }
    return $current;
}

sub with_day_of_week
{
    my $self    = shift;
    my $current = $self->{with_day_of_week};
    if (@_) {
        my($val) = validate_pos(@_, { type => BOOLEAN });
        $self->{with_day_of_week} = $val;
    }
    return $current;
}

# XXX - FORMATTING RELATED STUFF

my @FmtBasicValidate = (
    { isa => 'DateTime' },
);

sub format_year
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    my $year_section = '';

    if ($self->year_format eq DateTime::Format::Japanese::FORMAT_ERA()) {
        $year_section =
            DateTime::Format::Japanese::Common::_format_era($dt, $self->number_format);
    } else {
        my $year = $dt->year;
        if ($year < 0 && $self->with_bc_marker) {
            $year *= -1;
            $year_section .= $DateTime::Format::Japanese::Common::BC_MARKER;
        }

        if ($self->with_gregorian_marker) {
            $year_section .= $DateTime::Format::Japanese::Common::GREGORIAN_MARKER;
        }

        my $restore = undef;
        if ($self->number_format eq FORMAT_KANJI_WITH_UNIT) {
            $restore = $self->number_format(FORMAT_KANJI);
        }

        $year_section .=
            DateTime::Format::Japanese::Common::_format_number($year, $self->number_format);
        $year_section .= $DateTime::Format::Japanese::Common::YEAR_MARKER;

        if ($restore) {
            $self->number_format($restore);
        }
    }

    return Encode::encode($self->{output_encoding}, $year_section);
}

sub format_month
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    return Encode::encode($self->{output_encoding},
        DateTime::Format::Japanese::Common::_format_common_with_marker(
            $DateTime::Format::Japanese::Common::MONTH_MARKER,
            $dt->month,
            $self->number_format));
}

sub format_day
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    return Encode::encode($self->{output_encoding},
        DateTime::Format::Japanese::Common::_format_common_with_marker(
            $DateTime::Format::Japanese::Common::DAY_MARKER,
            $dt->day,
            $self->number_format));
}

sub format_hour
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    my $hour = $dt->hour;
    my $ampm = '';

    if ($self->with_ampm_marker) {
        $hour = $dt->hour <= 12 ? $dt->hour : $dt->hour - 12;
        $ampm = $dt->hour <  12 ?
            $DateTime::Format::Japanese::Common::AM_MARKER :
            $DateTime::Format::Japanese::Common::PM_MARKER;
    }

    return Encode::encode($self->{output_encoding},
        $ampm .
        DateTime::Format::Japanese::Common::_format_common_with_marker(
            $DateTime::Format::Japanese::Common::HOUR_MARKER,
            $hour,
            $self->number_format));
}

sub format_minute
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    return Encode::encode($self->{output_encoding},
        DateTime::Format::Japanese::Common::_format_common_with_marker(
            $DateTime::Format::Japanese::Common::MINUTE_MARKER,
            $dt->minute,
            $self->number_format));
}

sub format_second
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    return Encode::encode($self->{output_encoding},
        DateTime::Format::Japanese::Common::_format_common_with_marker(
            $DateTime::Format::Japanese::Common::SECOND_MARKER,
            $dt->second,
            $self->number_format));
}

sub format_ymd
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

	# format_year, format_month, format_day already takes care of
	# encoding, so don't re-encode
    return
        $self->format_year($dt) .
        $self->format_month($dt) .
        $self->format_day($dt);
}

sub format_time
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

	# format_hour, format_minute, format_second already takes care of
	# encoding, so don't re-encode
    return
        $self->format_hour($dt) .
        $self->format_minute($dt) .
        $self->format_second($dt);
}

sub format_day_of_week
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    return Encode::encode($self->{output_encoding},
        @DateTime::Format::Japanese::Common::DAY_OF_WEEKS[ $dt->day_of_week - 1 ] .
        $DateTime::Format::Japanese::Common::DAY_OF_WEEK_MARKER);
}

sub format_datetime
{
    my $self = shift;
    my ($dt) = validate_pos(@_, @FmtBasicValidate);

    my $rv = $self->format_ymd($dt) .
        $self->format_time($dt);
    if ($self->with_day_of_week) {
        $rv .= $self->format_day_of_week($dt);
    }

	# format_ymd, format_time, format_day_of_week have already
	# fixed our encoding, so don't touch.
    return $rv;
}

# XXX - PARSING RELATED STUFF

my $RE_MODERN_TIME_COMPONENTS = qr(
    (?:
        ($DateTime::Format::Japanese::Common::RE_AM_PM_MARKER)
        ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
        $DateTime::Format::Japanese::Common::RE_HOUR_MARKER
        (?:
            ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
            $DateTime::Format::Japanese::Common::RE_MINUTE_MARKER
            (?:
                ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
                $DateTime::Format::Japanese::Common::RE_SECOND_MARKER
            )?
        )?
    )?
)x;


my $parse_gregorian = {
    regex       => qr<
        ^
        $DateTime::Format::Japanese::Common::RE_GREGORIAN_MARKER?
        ($DateTime::Format::Japanese::Common::RE_GREGORIAN_YEAR)
        $DateTime::Format::Japanese::Common::RE_YEAR_MARKER
        ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
        $DateTime::Format::Japanese::Common::RE_MONTH_MARKER
        ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
        $DateTime::Format::Japanese::Common::RE_DAY_MARKER
        $RE_MODERN_TIME_COMPONENTS
        $DateTime::Format::Japanese::Common::RE_DAY_OF_WEEKS?
        $
    >x,
    params      => [ qw(year month day am_pm hour minute second) ],
    preprocess  => [
        \&DateTime::Format::Japanese::Common::_normalize_utf8, ],
    postprocess => [
        \&DateTime::Format::Japanese::Common::_normalize_numbers,
        \&DateTime::Format::Japanese::Common::_fix_am_pm,
        \&_fix_year ]
};

my $parse_gregorian_bc = {
    regex       => qr<
        ^
        ($DateTime::Format::Japanese::Common::RE_BC_MARKER|\-)
        $DateTime::Format::Japanese::Common::RE_GREGORIAN_MARKER?
        ($DateTime::Format::Japanese::Common::RE_GREGORIAN_YEAR)
        $DateTime::Format::Japanese::Common::RE_YEAR_MARKER
        ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
        $DateTime::Format::Japanese::Common::RE_MONTH_MARKER
        ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
        $DateTime::Format::Japanese::Common::RE_DAY_MARKER
        $RE_MODERN_TIME_COMPONENTS
        $DateTime::Format::Japanese::Common::RE_DAY_OF_WEEKS?
        $
    >x,
    params      => [ qw(is_bc year month day am_pm hour minute second) ],
    preprocess  => [
        \&DateTime::Format::Japanese::Common::_normalize_utf8, ],
    postprocess => [
        \&DateTime::Format::Japanese::Common::_normalize_numbers,
        \&DateTime::Format::Japanese::Common::_fix_am_pm,
        \&_fix_year ]
};

my $parse_with_era  = {
    regex       => qr|
        ^
        ($DateTime::Format::Japanese::Common::RE_ERA_NAME)
        ($DateTime::Format::Japanese::Common::RE_ERA_YEAR)
        $DateTime::Format::Japanese::Common::RE_YEAR_MARKER
        ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
        $DateTime::Format::Japanese::Common::RE_MONTH_MARKER
        ($DateTime::Format::Japanese::Common::RE_TWO_DIGITS)
        $DateTime::Format::Japanese::Common::RE_DAY_MARKER
        $RE_MODERN_TIME_COMPONENTS
        $DateTime::Format::Japanese::Common::RE_DAY_OF_WEEKS?
        $
    |x,
    params      => [ qw(era_name era_year month day am_pm hour minute second) ],
    preprocess  => [
        \&DateTime::Format::Japanese::Common::_normalize_utf8, ],
    postprocess => [
        \&DateTime::Format::Japanese::Common::_fix_era_year,
        \&DateTime::Format::Japanese::Common::_normalize_numbers,
        \&DateTime::Format::Japanese::Common::_fix_am_pm,
        \&_era2year_modern ]
};

sub _fix_year
{
    my %args = @_;
    if (delete $args{parsed}->{is_bc}) {
        $args{parsed}->{year} *= -1;
    }
    1;
}

sub _era2year_modern
{
    my %args = @_;

    my $era_name = delete $args{parsed}->{era_name} ||
        return 0;
    my $era_year = delete $args{parsed}->{era_year};
    if ($era_year <= 0) {
        return 0;
    }

    my $era = DateTime::Calendar::Japanese::Era->lookup_by_name(name => $era_name);

    my $g_year = $era->start->year + $era_year - 1;

    if ($g_year == 1) {
        if ($era->start->month > $args{parsed}->{month}) {
            Carp::croak("Invalid input format: Month " .
                $era->id .
                " is before the beginning of era '$era_name'");
        } elsif ($era->start->day > $args{parsed}->{day}) {
            Carp::croak("Invalid input format: Day " .
                $era->id .
                " is before the beginning of era '$era_name'");
        }
    }

    if ($era->end->is_finite() && $era->end->year < $g_year) {
        Carp::croak("Invalid input format: Year $g_year is after the end of era " . $era->id);
    } elsif ($g_year == $era->end->year) {
        if ($era->start->month < $args{parsed}->{month}) {
            Carp::croak("Invalid input format: Month " .
                $era->id .
                " is after the end of era '$era_name'");
        } elsif ($era->start->day >= $args{parsed}->{day}) {
            Carp::croak("Invalid input format: Day " .
                $era->id .
                " is after the end of era '$era_name'");
        }
    }

    $args{parsed}->{year} = $g_year;

    1;
}

require DateTime::Format::Builder;
DateTime::Format::Builder->create_class(
    parsers => {
        parse_datetime => [
            $parse_with_era, $parse_gregorian, $parse_gregorian_bc
        ]
    }
);

1;

__END__