File Coverage

blib/lib/Calendar/Any/Chinese.pm

Criterion	Covered	Total	%
statement	63	166	37.9
branch	18	46	39.1
condition	5	18	27.7
subroutine	16	38	42.1
pod	13	25	52.0
total	115	293	39.2

package Calendar::Any::Chinese;
{
  $Calendar::Any::Chinese::VERSION = '0.5';
}
use base 'Calendar::Any';
use Carp;
use Calendar::Any::Gregorian;
use Calendar::Any::Util::Lunar;

sub new {
    my $_class = shift;
    my $class = ref $_class || $_class;
    my $self = {};
    bless $self, $class;
    if ( @_ ) {
        my %arg;
        if ( $_[0] =~ /-\D/ ) {
            %arg = @_;
        } else {
            if ( $#_ > 0 ) {
                $arg{$_} = shift for qw(-cycle -year -month -day);
            } else {
                return $self->from_absolute(@_);
            }
        }
        foreach ( qw(-cycle -year -month -day) ) {
            $self->{substr($_, 1)} = $arg{$_} if exists $arg{$_};
        }
        $self->absolute_date();
    }
    return $self;
}

sub from_absolute {
    my $self = shift;
    my $absdate = shift;
    $self->{absolute} = $absdate;
    my $date = Calendar::Any::Gregorian->new($absdate);
    $self->{gdate} = $date;
    my $cyear = $date->year+2695;
    my @list = (@{_year($date->year-1)},
                @{_year($date->year)},
                @{_year($date->year+1)});
    foreach ( 0..$#list ) {
        if ( $list[$_]->[0] == 1 ) {
            $cyear++;
        }
        if ( $list[$_+1]->[1] > $absdate ) {
            $date = $list[$_];
            last;
        }
    }
    $self->{cycle} = int(($cyear-1)/60);
    $self->{year} = _mod($cyear, 60);
    $self->{month} = $date->[0];
    $self->{day} = $absdate - $date->[1] + 1;
    return $self;
}

sub absolute_date {
    my $self = shift;
    if (exists $self->{absolute} ) {
        return $self->{absolute};
    }
    my ($cycle, $year, $month, $day) = ($self->{cycle}, $self->{year}, $self->{month}, $self->{day});
    my $gyear = 60*($cycle-1)+$year-1-2636;
    my $monthday = _assoc_month($month, [_memq_month(1, _year($gyear)), @{_year($gyear+1)}]);
    $self->{absolute} = $day-1+$monthday->[1];
    $self->assert_date();
    return $self->{absolute};
}

sub cycle { shift->{cycle}; }

sub is_leap_year {
    my $self = shift;
    my $list = _year_month_list($self->cycle, $self->year);
    return $#{$list} == 12;
}

sub gyear { shift->gdate->year; }

sub gmonth { shift->gdate->month; }

sub gday { shift->gdate->day; }

sub gdate {
    my $self = shift;
    if ( !exists $self->{gdate} ) {
        $self->{gdate} = Calendar::Any::Gregorian->new($self->absolute_date);
    }
    return $self->{gdate};
}

sub last_day_of_month {
    my $self = shift;
    my $date = Calendar::Any::Util::Lunar::new_moon_date
        ( $self->day==1 ? $self->absolute_date+1 : $self,
          timezone(Calendar::Any::Gregorian->new($self->absolute_date)->year));
    return int($date-1-$self->absolute_date + $self->day);
}

sub year_month_list {
    my $self = shift;
    return _year_month_list($self->cycle, $self->year);
}

sub timezone {
    my $year = shift;
    return ((defined $year && $year >= 1928) ? 480 : 465 + 40.0/60.0 );
}

sub next_jieqi_date {
    Calendar::Any::Util::Solar::next_longitude_date($_[0], 15, $_[1]);
}

sub assert_date {
    my $self = shift;
    if ( $self->year < 1 || $self->year > 60 ) {
        confess('Not a valid year: should not from 1 to 60 for ' . ref $self);
    }
    if ( $self->month < 1 || $self->month > 12 ) {
        confess(sprintf('Not a valid month %d: should from 1 to 12 for %s', $self->month, ref $self));
    }
    if ( $self->day < 1 || $self->day > $self->last_day_of_month() ) {
        confess(sprintf('Not a valid day %d: should from 1 to %d in %d, %d for %s',
                        $self->day, $self->last_day_of_month, $self->month, $self->year, ref $self));
    }
}

#==========================================================
# Format calendar
#==========================================================
our @celestial_stem = qw(甲 乙 丙 丁 戊 已 庚 辛 壬 癸);
our @terrestrial_branch = qw(子 丑 寅 卯 辰 巳 午 未 申 酉 戌 亥);
our @weekday_name = qw(日 一 二 三 四 五 六);
our @month_name =
    qw(正月 二月 三月 四月 五月 六月 七月 八月 九月 十月 十一月 腊月);
our @day_name = qw
  (初一 初二 初三 初四 初五 初六 初七 初八 初九 初十
   十一 十二 十三 十四 十五 十六 十七 十八 十九 二十
   廿一 廿二 廿三 廿四 廿五 廿六 廿七 廿八 廿九 三十
   卅一);
our @zodiac_name = qw(鼠 牛 虎 兔 龙 蛇 马 羊 猴 鸡 狗 猪);
our @jieqi_name = qw
  (小寒 大寒 立春 雨水 惊蛰 春分
   清明 谷雨 立夏 小满 芒种 夏至
   小暑 大暑 立秋 处暑 白露 秋分
   寒露 霜降 立冬 小雪 大雪 冬至);

sub day_name {
    return $day_name[shift->day-1];
}

sub month_name {
    my $self = shift;
    my $month = $self->month;
    if ( _is_int($month)  ) {
        $month_name[$month-1];
    } else {
        return "闰".$month_name[$month-1];
    }
}

sub weekday_name {
    return "星期".$weekday_name[shift->weekday];
}

sub sexagesimal_name {
    my $self = shift;
    my $year = $self->year-1;
    return $celestial_stem[$year%10] . $terrestrial_branch[$year%12];
}

sub zodiac_name {
    my $self = shift;
    my $year = $self->year-1;
    return $zodiac_name[$year%12];
}

sub format_Y { shift->gyear }
sub format_S { shift->sexagesimal_name }
sub format_D { shift->day_name }
sub format_Z { shift->zodiac_name }
sub format_m { sprintf("%02d", shift->gmonth) }
sub format_d { sprintf("%02d", shift->gday) }
our $default_format = "%Y年%m月%d日 %W %S%Z年%M%D";

#==========================================================
# Private functions
#==========================================================
#==========================================================
# Input  : chinese year cycle, year
# Output : the array of month in the chinese year
# Desc   :
#==========================================================
sub _year_month_list {
    my ($cycle, $year) = @_;
    my $date = __PACKAGE__->new($cycle, $year, 1, 1);
    $year = $date->gyear;
    my $list1 = _year($year);
    my $list2 = _year($year+1);
    my @list = _memq_month(1, $list1);
    foreach ( @$list2 ) {
        last if $_->[0]==1;
        push @list, $_;
    }
    return \@list;
}

#==========================================================
# Input  : x, y
# Output : x modulo y, range from 1-y
# Desc   : like operator %, but instead of 0, return the exclusive y
#==========================================================
sub _mod {
    $_[0] % $_[1] || $_[1];
}

sub _is_int {
    $_[0]-int($_[0])==0;
}

#==========================================================
# Input  : month, an array of month list
# Output : the month list from month
# Desc   : eg, _memq_month(2, [[12, 726464], [1, 726494], [2, 726523], [3, 726553], ...])
#          return [[2, 726523], [3, 726553], ...]
#==========================================================
sub _memq_month {
    my ($month, $list) = @_;
    my $i = 0;
    for ( ; $i<=$#$list; $i++ ) {
        last if ($list->[$i][0] == $month);
    }
    return @{$list}[$i..$#$list];
}

#==========================================================
# Input  : month, an array of month list
# Output : the month in the list
# Desc   : eg, _assoc_month(2, [[12, 726464], [1, 726494], [2, 726523], [3, 726553], ...])
#          return [2, 726523]
#==========================================================
sub _assoc_month {
    my ($month, $list) = @_;
    foreach ( @$list ) {
        return $_ if $_->[0] == $month;
    }
}

#==========================================================
# Input  : Gregorian year
# Output : the chinese month list of the year
# Desc   : The month list always range from winter solstice day in year-1
#          to winter in solstice day. Usually, the month list is start
#          chinese month 12 in last year, but possible start from 11.5.
#          The month with .5 indicate that is a leap month.
#==========================================================
my %year_cache = (
'2000' => [
    [12, 730126],[1, 730155],[2, 730185],[3, 730215],[4, 730244],[5, 730273],
    [6, 730303],[7, 730332],[8, 730361],[9, 730391],[10, 730420],[11, 730450]
  ],
'2001' => [
    [12, 730480],[1, 730509],[2, 730539],[3, 730569],[4, 730598],[4.5, 730628],
    [5, 730657],[6, 730687],[7, 730716],[8, 730745],[9, 730775],[10, 730804],
    [11, 730834]
  ],
'2002' => [
    [12, 730863],[1, 730893],[2, 730923],[3, 730953],[4, 730982],[5, 731012],
    [6, 731041],[7, 731071],[8, 731100],[9, 731129],[10, 731159],[11, 731188]
  ],
'2003' => [
    [12, 731218],[1, 731247],[2, 731277],[3, 731307],[4, 731336],[5, 731366],
    [6, 731396],[7, 731425],[8, 731455],[9, 731484],[10, 731513],[11, 731543]
  ],
'2004' => [
    [12, 731572],[1, 731602],[2, 731631],[2.5, 731661],[3, 731690],[4, 731720],
    [5, 731750],[6, 731779],[7, 731809],[8, 731838],[9, 731868],[10, 731897],
    [11, 731927]
  ],
'2005' => [
    [12, 731956],[1, 731986],[2, 732015],[3, 732045],[4, 732074],[5, 732104],
    [6, 732133],[7, 732163],[8, 732193],[9, 732222],[10, 732252],[11, 732281]
  ],
'2006' => [
    [12, 732311],[1, 732340],[2, 732370],[3, 732399],[4, 732429],[5, 732458],
    [6, 732488],[7, 732517],[7.5, 732547],[8, 732576],[9, 732606],[10, 732636],
    [11, 732665]
  ],
'2007' => [
    [12, 732695],[1, 732725],[2, 732754],[3, 732783],[4, 732813],[5, 732842],
    [6, 732871],[7, 732901],[8, 732930],[9, 732960],[10, 732990],[11, 733020]
  ],
'2008' => [
    [12, 733049],[1, 733079],[2, 733109],[3, 733138],[4, 733167],[5, 733197],
    [6, 733226],[7, 733255],[8, 733285],[9, 733314],[10, 733344],[11, 733374]
  ],
'2009' => [
    [12, 733403],[1, 733433],[2, 733463],[3, 733493],[4, 733522],[5, 733551],
    [5.5, 733581],[6, 733610],[7, 733639],[8, 733669],[9, 733698],[10, 733728],
    [11, 733757]
  ],
'2010' => [
    [12, 733787],[1, 733817],[2, 733847],[3, 733876],[4, 733906],[5, 733935],
    [6, 733965],[7, 733994],[8, 734023],[9, 734053],[10, 734082],[11, 734112]
  ],
'2011' => [
    [12, 734141],[1, 734171],[2, 734201],[3, 734230],[4, 734260],[5, 734290],
    [6, 734319],[7, 734349],[8, 734378],[9, 734407],[10, 734437],[11, 734466]
  ],
'2012' => [
    [12, 734496],[1, 734525],[2, 734555],[3, 734584],[4, 734614],[4.5, 734644],
    [5, 734673],[6, 734703],[7, 734732],[8, 734762],[9, 734791],[10, 734821],
    [11, 734850]
  ],
'2013' => [
    [12, 734880],[1, 734909],[2, 734939],[3, 734968],[4, 734998],[5, 735027],
    [6, 735057],[7, 735087],[8, 735116],[9, 735146],[10, 735175],[11, 735205]
  ],
'2014' => [
    [12, 735234],[1, 735264],[2, 735293],[3, 735323],[4, 735352],[5, 735382],
    [6, 735411],[7, 735441],[8, 735470],[9, 735500],[9.5, 735530],[10, 735559],
    [11, 735589]
  ],
'2015' => [
    [12, 735618],[1, 735648],[2, 735677],[3, 735707],[4, 735736],[5, 735765],
    [6, 735795],[7, 735824],[8, 735854],[9, 735884],[10, 735914],[11, 735943]
  ],
'2016' => [
    [12, 735973],[1, 736002],[2, 736032],[3, 736061],[4, 736091],[5, 736120],
    [6, 736149],[7, 736179],[8, 736208],[9, 736238],[10, 736268],[11, 736297]
  ],
'2017' => [
    [12, 736327],[1, 736357],[2, 736386],[3, 736416],[4, 736445],[5, 736475],
    [6, 736504],[6.5, 736533],[7, 736563],[8, 736592],[9, 736622],[10, 736651],
    [11, 736681]
  ],
'2018' => [
    [12, 736711],[1, 736741],[2, 736770],[3, 736800],[4, 736829],[5, 736859],
    [6, 736888],[7, 736917],[8, 736947],[9, 736976],[10, 737006],[11, 737035]
  ],
'2019' => [
    [12, 737065],[1, 737095],[2, 737125],[3, 737154],[4, 737184],[5, 737213],
    [6, 737243],[7, 737272],[8, 737301],[9, 737331],[10, 737360],[11, 737389]
  ],
'2020' => [
    [12, 737419],[1, 737449],[2, 737478],[3, 737508],[4, 737538],[4.5, 737568],
    [5, 737597],[6, 737627],[7, 737656],[8, 737685],[9, 737715],[10, 737744],
    [11, 737774]
  ],
);

sub _year {
    my $y = shift;
    if ( !exists $year_cache{$y} ) {
        $year_cache{$y} = _compute_chinese_year($y);
    }
    return $year_cache{$y};
}

sub _compute_chinese_year {
    my $y = shift;
    my $oldtz = $Calendar::Any::Util::Solar::timezone;
    $Calendar::Any::Util::Solar::timezone = timezone($y);
    my $next_solstice = _zodiac_sign(Calendar::Any::Gregorian->new(12, 15, $y));
    my $months = _month_list(_zodiac_sign(Calendar::Any::Gregorian->new(12, 15, $y-1))+1,
                             $next_solstice);
    my $list;
    if ( scalar(@$months) == 12 ) {
        $list = [[12, $months->[0]], map { [ $_, $months->[$_] ]} 1..11];
    } else {
        my $next_sign = _zodiac_sign($months->[0]);
        if ( $months->[0]>$next_sign || $next_sign >= $months->[1] ) {
            $list = [[11.5, $months->[0]], [12, $months->[1]],
                     map { [ $_, $months->[$_+1] ] } 1..11];
        } else {
            my @list = ([12, $months->[0]]);
            if ( _zodiac_sign($months->[1]) >= _zodiac_sign($months->[2]) ) {
                push @list, [12.5, $months->[1]],
                    map { [ $_, $months->[$_+1] ] } 1..11;
            } else {
                push @list, [1, $months->[1]];
                my $i = 2;
                while ( $months->[$i+1] > _zodiac_sign($months->[$i]) ) {
                    push @list, [$i, $months->[$i]];
                    $i++;
                }
                push @list, [$i-0.5, $months->[$i]];
                foreach ( $i..11 ) {
                    push @list, [$_, $months->[$_+1]];
                }
            }
            $list = \@list;
        }
    }
    $Calendar::Any::Util::Solar::timezone = $oldtz;
    return $list;
}

sub _zodiac_sign {
    int(Calendar::Any::Util::Solar::next_longitude_date(shift, 30));
}

#==========================================================
# Input  : start, end, timezone
# Output : the array of new moon date between start and end
# Desc   : start and end should be Calendar object or absolute date
#==========================================================
sub _month_list {
    my ($start, $end) = @_;
    my @list;
    while ( $start <= $end ) {
        $start = int(Calendar::Any::Util::Lunar::new_moon_date($start));
        push @list, $start;
        $start++;
    }
    pop @list if $list[-1]>$end;
    return \@list;
}

1;

__END__