File Coverage

blib/lib/Lingua/JA/FindDates.pm
Criterion Covered Total %
statement 198 228 86.8
branch 119 148 80.4
condition 33 57 57.8
subroutine 15 17 88.2
pod 9 11 81.8
total 374 461 81.1


line stmt bran cond sub pod time code
1             package Lingua::JA::FindDates;
2 4     4   170267 use warnings;
  4         30  
  4         114  
3 4     4   17 use strict;
  4         6  
  4         96  
4 4     4   25 use Carp qw/carp croak cluck/;
  4         14  
  4         292  
5 4     4   1301 use utf8;
  4         26  
  4         23  
6 4     4   167 use 5.010000;
  4         19  
7              
8             require Exporter;
9             our @ISA = qw(Exporter);
10             our @EXPORT_OK= qw/subsjdate kanji2number seireki_to_nengo nengo_to_seireki
11             regjnums @jdatere $jera %jera2w/;
12             our %EXPORT_TAGS = (
13             all => \@EXPORT_OK,
14             );
15              
16             our $VERSION = '0.029';
17              
18             # Kanji number conversion table.
19              
20             my %kanjinums =
21             (
22             〇 => 0,
23             一 => 1,
24             二 => 2,
25             三 => 3,
26             四 => 4,
27             五 => 5,
28             六 => 6,
29             七 => 7,
30             八 => 8,
31             九 => 9,
32             十 => 10,
33             百 => 100,
34             # Dates shouldn't get any bigger than the following times a digit.
35             千 => 1000,
36             );
37              
38             # The kanji digits.
39              
40             my $kanjidigits = join ('', keys %kanjinums);
41              
42             sub kanji2number
43             {
44 56     56 1 11782 my ($knum) = @_;
45             # Special case of 元日 (ganjitsu), 元年 (gannen), etc.
46 56 100       112 if ($knum eq '元') {
47 1         4 return 1;
48             }
49 55         117 my @kanjis = split '', $knum;
50 55         73 my $value = 0;
51 55         64 my $keta = 1;
52 55         68 while (1) {
53 135         166 my $k = pop @kanjis;
54 135 100       229 if (! defined $k) {
55 48         135 return $value;
56             }
57 87         138 my $val = $kanjinums{$k};
58             # Make sure this kanji is one we know
59 87 100       122 if (! defined $val) {
60 1         11 warn "can't cope with '$k' of input '$knum'";
61 1         7 return 0;
62             }
63             # If the value of the individual kanji is 10 or more.
64 86 100       126 if ($val >= 10) {
65 30         38 $keta = $val;
66 30         41 my $knext = pop @kanjis;
67 30 100       49 if (!$knext) {
68 5         16 return $value + $val;
69             }
70 25         38 my $val_next = $kanjinums{$knext};
71 25 100       40 if (! defined $val_next) {
72             # Kanji is not a numerical one we know of.
73 1         13 warn "can't cope with '$knext' of input '$knum'.\n";
74 1         11 return 0;
75             }
76             # If we have a hundred followed by a thousand, without a
77             # three, four, etc., like "千百".
78 24 100       36 if ($val_next > 10) {
79             # Put it back on the stack
80 2         4 push @kanjis, $knext;
81             # $value += 1*$val, since the digit for $val is
82             # defaulted to one.
83 2         3 $value += $val;
84             }
85             else {
86 22         33 $value += $val_next * $val;
87             }
88             }
89             else {
90             # $k is a kanji digit from 0 to 9, and $val is its value,
91             # as if 一二三 or something, without tens, hundreds,
92             # thousands, etc.
93 56         73 $value += $val * $keta;
94 56         68 $keta *= 10;
95             }
96             }
97             }
98              
99             # ____
100             # | _ \ ___ __ _ _____ _____ ___
101             # | |_) / _ \/ _` |/ _ \ \/ / _ \/ __|
102             # | _ < __/ (_| | __/> < __/\__ \
103             # |_| \_\___|\__, |\___/_/\_\___||___/
104             # |___/
105              
106             my $jdigit = qr/[0-90-9]/;
107              
108             # A regular expression to match Japanese numbers
109              
110             my $jnumber = qr/($jdigit+|[$kanjidigits]+)/x;
111              
112             # A regular expression to match a Western year
113              
114             my $wyear = qr/
115             (
116             $jdigit{4}
117             |
118             [$kanjidigits]?千[$kanjidigits]*
119             |
120             [\']$jdigit{2}
121             )
122             \s*年
123             /x;
124              
125             my $alpha_era = qr/
126             # If the H, S, T, or M is part of a longer
127             # string of romaji, do not match it.
128             (?
129             (?:
130             [H|H|S|S|T|T|M|M|R|R]
131             )
132 4     4   21 /xi;
  4         8  
  4         38  
133              
134             # The recent era names (Reiwa, Heisei, Showa, Taisho, Meiji). These
135             # eras are sometimes written using the letters H, S, T, and
136             # M. Speculatively, add R for "Reiwa".
137              
138             our $jera = qr/($alpha_era|平|昭|大|明|平成|昭和|大正|明治|㍻|㍼|㍽|㍾|令和|令)/;
139              
140             # A map of Japanese eras to Western dates. These are the starting year
141             # of the period minus one, to allow for that the first year is "heisei
142             # one" rather than "heisei zero".
143              
144             our %jera2w = (
145             R => 2018,
146             H => 2018,
147             令和 => 2018,
148             令 => 2018,
149             H => 1988,
150             H => 1988,
151             平成 => 1988,
152             平 => 1988,
153             '㍻' => 1988,
154             S => 1925,
155             S => 1925,
156             昭和 => 1925,
157             昭 => 1925,
158             '㍼' => 1925,
159             T => 1911,
160             T => 1911,
161             大正 => 1911,
162             大 => 1911,
163             '㍽' => 1911,
164             M => 1867,
165             M => 1867,
166             明治 => 1867,
167             明 => 1867,
168             '㍾' => 1867,
169             );
170              
171             # Japanese year, with era like "Heisei" at the beginning.
172              
173             my $jyear = qr/
174             $jera
175             \h*
176             # Only match up to one or two of these digits, to
177             # prevent unlikely matches.
178             (
179             $jdigit{1,2}
180             |
181             [$kanjidigits]{1,2}
182             |
183             # The first year of an era, something like
184             # "昭和元年" (1926, the first year of the Showa era).
185            
186             )
187             \h*
188            
189             /x;
190              
191             # The "jun" or approximately ten day periods (thirds of a month)
192              
193             my %jun = qw/初 1 上 1 中 2 下 3/;
194              
195             # The translations of the "jun" above into English.
196              
197             my @jun2english = (
198             'invalid',
199             'early ',
200             'mid-',
201             'late ',
202             );
203              
204             # Japanese days of the week, from Monday to Sunday.
205              
206             my $weekdays = '月火水木金土日';
207             my @weekdays = split '',$weekdays;
208              
209             # Match a string for a weekday, like 月曜日 or (日)
210             # The long part (?=\W) is to stop it from accidentally matching a
211             # kanji which is part of a different word, like the following:
212             #平成二十年七月一日
213             # 日本論・日本人論は非常に面白いものだ。
214              
215             my $match_weekday =
216             qr/[\((]?
217             ([$weekdays])
218             (?:(?:(?:曜日|曜)[)\)])|[)\)]|(?=\W))
219             /x;
220              
221             # Match a day of the month, like 10日
222              
223             my $match_dom = qr/$jnumber\h*日/;
224              
225             # Match a month
226              
227             my $match_month = qr/$jnumber\h*月/;
228              
229             # Match a "jun" (a third of a month).
230              
231             my $jun_keys = join ('', keys %jun);
232              
233             my $match_jun = qr/([$jun_keys])\h*旬/;
234              
235             # Match a month+jun
236              
237             my $match_month_jun = qr/$match_month\h*$match_jun/;
238              
239             # Match a month and day of month pair
240              
241             my $match_month_day = qr/$match_month\h*$match_dom/;
242              
243             # Match a Japanese year, month, day string
244              
245             my $matchymd = qr/
246             $jyear
247             \h*
248             $match_month_day
249             /x;
250              
251             # Match a Western year, month, day string
252              
253             my $matchwymd = qr/$wyear\h*$match_month_day/;
254              
255             # Match a Japanese year and month only
256              
257             my $match_jyear_month = qr/$jyear\h*$match_month/;
258              
259             # Match a Western year and month only
260              
261             my $match_wyear_month = qr/$wyear\h*$match_month/;
262              
263             # Match a month, day, weekday.
264              
265             my $match_month_day_weekday = qr/$match_month_day\h*$match_weekday/;
266              
267             # Separators used in date strings
268             # Microsoft Word uses Unicode 0xFF5E, the "fullwidth tilde", for nyoro symbol.
269              
270             my $separators = qr/\h*[〜−~]\h*/;
271            
272             # _ _ _ __
273             # | | (_)___| |_ ___ / _| _ __ ___ __ _ _____ _____ ___
274             # | | | / __| __| / _ \| |_ | '__/ _ \/ _` |/ _ \ \/ / _ \/ __|
275             # | |___| \__ \ |_ | (_) | _| | | | __/ (_| | __/> < __/\__ \
276             # |_____|_|___/\__| \___/|_| |_| \___|\__, |\___/_/\_\___||___/
277             # |___/
278              
279             # This a list of date regular expressions.
280              
281             our @jdatere = (
282              
283             # Match an empty string like 平成 月 日 as found on a form etc.
284              
285             [qr/
286             $jyear
287             (\h+)
288            
289             \h+
290            
291             /x,
292             "ejx"],
293              
294             # Add match for dummy strings here!
295              
296             # Match a Japanese era, year, 2 x (month day weekday) combination
297              
298             [qr/
299             $matchymd
300             \h*$match_weekday
301             $separators
302             $matchymd
303             \h*$match_weekday
304             /x,
305             "e1j1m1d1w1e2j2m2d2w2"],
306              
307             # Match 2 x (era, year, month, day) combination
308              
309             [qr/
310             $matchymd
311             $separators
312             $matchymd
313             /x,
314             "e1j1m1d1e2j2m2d2"],
315              
316             # Match a Japanese era, year, month 2 x (day, weekday) combination
317              
318             [qr/
319             $matchymd
320             $match_weekday
321             $separators
322             $match_dom
323             \h*
324             $match_weekday
325             /x,
326             "ejmd1w1d2w2"],
327              
328             # Match a Japanese era, year, month 2 x day combination
329              
330             [qr/
331             $matchymd
332             $separators
333             $match_dom
334             \h*
335             $match_weekday
336             /x,
337             "ejmd1d2"],
338              
339             # Match 2x(Western year, month, day, weekday) combination
340              
341             [qr/
342             $matchwymd
343             \h*
344             $match_weekday
345             $separators
346             $matchwymd
347             $match_weekday
348             /x,
349             "y1m1d1w1y2m2d2w2"],
350              
351             # Match a Western year, 2x(month, day, weekday) combination
352              
353             [qr/
354             $matchwymd
355             \h*
356             $match_weekday
357             $separators
358             $match_month_day_weekday
359             /x,
360             "ym1d1w1m2d2w2"],
361              
362             # Match a Western year, month, 2x(day, weekday) combination
363              
364             [qr/
365             $matchwymd
366             \h*
367             $match_weekday
368             $separators
369             $match_dom
370             \h*
371             $match_weekday
372             /x,
373             "ymd1w1d2w2"],
374              
375             # Match a Western year, month, 2x(day) combination
376              
377             [qr/
378             $matchwymd
379             $separators
380             $match_dom
381             /x,
382             "ymd1d2"],
383              
384             # Match a Japanese era, year, month1 day1 - month 2 day2 combination
385              
386             [qr/
387             $matchymd
388             $separators
389             $match_month_day
390             /x,
391             "ejm1d1m2d2"],
392              
393             # Match 2 x ( Japanese era, year, month) combination
394              
395             [qr/
396             $jyear
397             \h*
398             $jnumber
399             \h*月?
400             $separators
401             $jyear
402             \h*
403             $match_month
404             /x, "e1j1m1e2j2m2"],
405              
406             # Match a Japanese era, year, month1 - month 2 combination
407              
408             [qr/
409             $jyear
410             \h*
411             $jnumber
412             \h*月?
413             $separators
414             $match_month
415             /x, "ejm1m2"],
416              
417             # Match a Japanese era, year, month, day1 - day2 combination
418              
419             [qr/
420             $match_jyear_month
421             \h*
422             $jnumber
423             \h*日?
424             $separators
425             $match_dom
426             /x,
427             "ejmd1d2"],
428              
429             # Match a Japanese era, year, month, day, weekday combination
430              
431             [qr/
432             $matchymd
433             \h*
434             $match_weekday
435             /x,
436             "ejmdw"],
437              
438             # Match a Japanese era, year, month, day
439              
440             [qr/$matchymd/,
441             "ejmd"],
442              
443             # Match a Japanese era, year, month, jun
444              
445             [qr/
446             $match_jyear_month
447             \h*
448             $match_jun
449             /x,
450             "ejmz"],
451              
452             # Match a Western year, month, day, weekday combination
453              
454             [qr/
455             $matchwymd
456             \h*
457             $match_weekday
458             /x,
459             "ymdw"],
460              
461             # Match a Western year, month, day combination
462              
463             [qr/$matchwymd/,
464             "ymd"],
465              
466             # Match a Western year, month, jun combination
467              
468             [qr/
469             $match_wyear_month
470             \h*
471             $match_jun
472             /x,
473             "ymz"],
474              
475             # Match a Japanese era, year, month
476              
477             [qr/
478             $jyear
479             \h*
480             $jnumber
481             \h*
482            
483             /x,
484             "ejm"],
485              
486             # Match a Western year, month
487              
488             [qr/$match_wyear_month/,
489             "ym"],
490              
491             # Match 2 x (month, day, weekday)
492              
493             [qr/
494             $match_month_day_weekday
495             $separators
496             $match_month_day_weekday
497             /x,
498             "m1d1w1m2d2w2"],
499              
500             # Match month, 2 x (day, weekday)
501              
502             [qr/
503             $match_month_day_weekday
504             $separators
505             $match_dom
506             \h*
507             $match_weekday
508             /x,
509             "md1w1d2w2"],
510              
511             # Match month, 2 x (day, weekday)
512              
513             [qr/
514             $match_month_day
515             $separators
516             $match_dom
517             /x,
518             "md1d2"],
519              
520             # Match a month, day, weekday
521              
522             [qr/$match_month_day_weekday/,
523             "mdw"],
524              
525             # Match a month, day
526              
527             [qr/$match_month_day/,
528             "md"],
529              
530             # Match a fiscal year (年度, nendo in Japanese). These usually don't
531             # have months combined with them, so there is nothing to match a
532             # fiscal year with a month.
533              
534             [qr/
535             $jyear
536            
537             /x,
538             "en"],
539              
540             # Match a fiscal year (年度, nendo in Japanese). These usually don't
541             # have months combined with them, so there is nothing to match a
542             # fiscal year with a month.
543              
544             [qr/
545             $wyear
546            
547             /x,
548             "n"],
549              
550             # Match a Japanese era, year
551              
552             [qr/$jyear/,
553             "ej"],
554              
555             # Match a Western year
556              
557             [qr/$wyear/,
558             "y"],
559              
560             # Match a month with a jun
561              
562             [
563             qr/
564             $match_month
565             \h*
566             $match_jun
567             /x,
568             "mz"
569             ],
570              
571             # Match a month
572              
573             [
574             qr/$match_month/,
575             "m"
576             ],
577             );
578              
579             my @months = qw/Invalid
580             January
581             February
582             March
583             April
584             May
585             June
586             July
587             August
588             September
589             October
590             November
591             December
592             MM/;
593              
594             my @days = qw/Invalid
595             Monday
596             Tuesday
597             Wednesday
598             Thursday
599             Friday
600             Saturday
601             Sunday/;
602              
603             # This is a translation table from the Japanese weekday names to the
604             # English ones.
605              
606             my %j2eweekday;
607              
608             @j2eweekday{@weekdays} = (1..7);
609              
610             # This is the default routine for turning a Japanese date into a
611             # foreign-style one.
612              
613             sub make_date
614             {
615 0     0 1 0 goto & default_make_date;
616             }
617              
618             sub make_date_interval
619             {
620 0     0 1 0 goto & default_make_date_interval;
621             }
622              
623             sub default_make_date
624             {
625 46     46 1 73 my ($datehash) = @_;
626             my ($year, $month, $date, $wday, $jun) =
627 46         60 @{$datehash}{qw/year month date wday jun/};
  46         121  
628 46 0 66     95 if (!$year && !$month && !$date && !$jun) {
      33        
      0        
629 0         0 carp "No valid inputs\n";
630 0         0 return;
631             }
632 46         58 my $edate = '';
633 46 100       79 $edate = $days[$wday].", " if $wday;
634 46 100       70 if ($month) {
635 34         50 $month = int ($month); # In case it is 07 etc.
636 34         52 $edate .= $months[$month];
637 34 100       58 if ($jun) {
638 1         3 $edate = $jun2english[$jun] . $edate;
639             }
640             }
641 46 100       75 if ($date) {
    100          
642 29 50       54 $edate .= " " if length ($edate);
643 29         38 $date = int ($date); # In case it is 07 etc.
644 29 100       51 $date = "DD" if $date == 32;
645 29 100       43 if ($year) {
646 25         50 $edate .= "$date, $year";
647             }
648             else {
649 4         8 $edate .= "$date";
650             }
651             }
652             elsif ($year) {
653 14 100       33 if (length ($edate) > 0) {
654 2         4 $edate .= " ";
655             }
656 14         23 $edate .= $year;
657             }
658 46         85 return $edate;
659             }
660              
661             our $date_sep = '-';
662              
663             # This is the default routine for turning a date interval into a
664             # foreign-style one, which is then substituted into the text.
665              
666             sub default_make_date_interval
667             {
668 17     17 1 490 my ($date1, $date2) = @_;
669 17         23 my $einterval = '';
670 17         18 my $usecomma;
671             # The case of an interval with different years doesn't need to be
672             # considered, because each date in that case can be considered a
673             # single date.
674              
675 17 100       37 if ($date2->{month}) {
676 9 50       22 if (!$date1->{month}) {
677 0         0 carp "end month but no starting month";
678 0         0 return;
679             }
680             }
681 17 50       30 if ($date1->{month}) {
682 17 100 66     57 if ($date1->{wday} && $date2->{wday}) {
    100 66        
683 6 50 33     23 if (! $date1->{date} || ! $date2->{date}) {
684 0         0 carp "malformed date has weekdays but not days of month";
685 0         0 return;
686             }
687 6         9 $usecomma = 1;
688             $einterval = $days[$date1->{wday}] . " " . $date1->{date} .
689             ($date2->{month} ? ' '.$months[int ($date1->{month})] : ''). $date_sep .
690             $days[$date2->{wday}] . " " . $date2->{date} . " " .
691 6 100       43 ($date2->{month} ? $months[int ($date2->{month})] : $months[int ($date1->{month})]);
    100          
692             }
693             elsif ($date1->{date} && $date2->{date}) {
694 7         11 $usecomma = 1;
695 7 50 33     22 if ($date1->{wday} || $date2->{wday}) {
696 0         0 carp "malformed date interval: ",
697             "has weekday for one date $date1->{wday} but not the other one $date2->{wday} .";
698 0         0 return;
699             }
700             $einterval = $months[int ($date1->{month})] . ' ' .
701             $date1->{date} . $date_sep .
702             ($date2->{month} ?
703             $months[int ($date2->{month})] . ' ' : '') .
704 7 100       39 $date2->{date};
705             }
706             else { # no dates or weekdays
707 4 50 33     14 if ($date1->{date} || $date2->{date}) {
708 0         0 cluck "malformed date interval: only one day of month";
709 0         0 return;
710             }
711 4 50       8 if (!$date2->{month}) {
712 0         0 carp "start month but no end month or date";
713 0         0 return;
714             }
715             $einterval = $months[int($date1->{month})] . $date_sep .
716 4         14 $months[int($date2->{month})] .
717             $einterval;
718             }
719             }
720             else { # weekday - day / weekday - day case.
721 0 0 0     0 if ($date1->{wday} && $date2->{wday}) {
722 0 0 0     0 if (! $date1->{date} || ! $date2->{date}) {
723 0         0 carp "malformed date has weekdays but not days of month";
724 0         0 return;
725             }
726             $einterval = $date1->{wday} . " " . $date1->{date} . $date_sep .
727 0         0 $date2->{wday} . " " . $date2->{date};
728             }
729             }
730 17 100       42 if ($date1->{year}) {
731 16 100       42 my $year1 = ($usecomma ? ', ': ' ').$date1->{year};
732 16 100 66     40 if (! $date2->{year} || $date2->{year} == $date1->{year}) {
733 14         28 $einterval .= $year1;
734             }
735             else {
736 2         20 $einterval =~ s/\Q$date_sep/$year1$date_sep/;
737 2 50       8 my $year2 = ($usecomma ? ', ': ' ').$date2->{year};
738 2         5 $einterval .= $year2;
739             }
740             }
741 17         52 return $einterval;
742             }
743              
744             our $verbose = 0;
745              
746             sub subsjdate
747             {
748             # $text is the text to substitute. It needs to be in Perl's
749             # internal encoding.
750             # $replace_callback is a routine to call back if we find valid dates.
751             # $data is arbitrary data to pass to the callback routine.
752 58     58 1 9752 my ($text, $c) = @_;
753             # Save doing existence tests.
754 58 100       130 if (! $c) {
755 49         80 $c = {};
756             }
757 58 100       106 if (! $text) {
758 2         10 return $text;
759             }
760             # Loop through all the possible regular expressions.
761 56         100 for my $datere (@jdatere) {
762 1792         5934 my $regex = $datere->[0];
763 1792         8002 my @process = split (/(?=[a-z][12]?)/, $datere->[1]);
764 1792 50       3096 if ($verbose) {
765 0         0 print "Looking for $datere->[1]\n";
766             }
767 1792         158212 while ($text =~ /($regex)/g) {
768 75         2125 my $date1;
769             my $date2;
770             # The matching string is in the following variable.
771 75         190 my $orig = $1;
772 75         324 my @matches = ($2,$3,$4,$5,$6,$7,$8,$9);
773 75 50       147 if ($verbose) {
774 0         0 print "Found '$orig': ";
775             }
776 75         177 for (0..$#matches) {
777 348         502 my $arg = $matches[$_];
778              
779 348 100       536 last if !$arg;
780 274         644 $arg =~ tr/0-9/0-9/;
781 274         1105 $arg =~ s/([$kanjidigits]+|元)/kanji2number($1)/ge;
  47         95  
782 274 50       492 if ($verbose) {
783 0         0 print "Arg $_: $arg ";
784             }
785 274         331 my $argdo = $process[$_];
786 274 100 100     1375 if ($argdo eq 'e1') { # Era name in Japanese
    100 100        
    50 100        
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
787 1         4 $date1->{year} = $jera2w{$arg};
788             }
789             elsif ($argdo eq 'j1') { # Japanese year
790 1         4 $date1->{year} += $arg;
791             }
792             elsif ($argdo eq 'y1') {
793 0         0 $date1->{year} = $arg;
794             }
795             elsif ($argdo eq 'e2') { # Era name in Japanese
796 1         3 $date2->{year} = $jera2w{$arg};
797             }
798             elsif ($argdo eq 'j2') { # Japanese year
799 1         3 $date2->{year} += $arg;
800             }
801             elsif ($argdo eq 'y2') {
802 0         0 $date2->{year} = $arg;
803             }
804             elsif ($argdo eq 'e') { # Era name in Japanese
805 44         149 $date1->{year} = $jera2w{$arg};
806             }
807             elsif ($argdo eq 'j') { # Japanese year
808 43         106 $date1->{year} += $arg;
809             }
810             elsif ($argdo eq 'y') {
811 21         62 $date1->{year} = $arg;
812             }
813             elsif ($argdo eq 'n') {
814 2         6 $date1->{year} += $arg;
815 2         6 $date1->{year} = "fiscal ".$date1->{year};
816             }
817             elsif ($argdo eq 'm' || $argdo eq 'm1') {
818 62         141 $date1->{month} = $arg;
819             }
820             elsif ($argdo eq 'd' || $argdo eq 'd1') {
821 53         119 $date1->{date} = $arg;
822             }
823             elsif ($argdo eq 'm2') {
824 8         20 $date2->{month} = $arg;
825             }
826             elsif ($argdo eq 'd2') {
827 12         27 $date2->{date} = $arg;
828             }
829             elsif ($argdo eq 'w' || $argdo eq 'w1') {
830 18         44 $date1->{wday} = $j2eweekday{$arg};
831             }
832             elsif ($argdo eq 'w2') {
833 5         12 $date2->{wday} = $j2eweekday{$arg};
834             }
835             elsif ($argdo eq 'z') {
836 1         4 $date1->{jun} = $jun{$arg};
837             }
838             elsif ($argdo eq 'x') {
839 1 50       4 if ($verbose) {
840 0         0 print "Dummy date '$orig'.\n";
841             }
842 1         3 $date1->{date} = 32;
843 1         2 $date1->{month} = 13;
844             }
845             }
846 75         102 my $edate;
847 75 100       98 if ($date2) {
848             # Date interval
849 16 50       32 if ($c->{make_date_interval}) {
850 0         0 $edate = &{$c->{make_date_interval}} ($c->{data}, $orig,
  0         0  
851             $date1, $date2);
852             }
853             else {
854 16         36 $edate = default_make_date_interval ($date1, $date2);
855             }
856             }
857             else {
858             # Single date
859 59 100       105 if ($c->{make_date}) {
860 13         20 $edate = &{$c->{make_date}}($c->{data}, $orig, $date1);
  13         35  
861             }
862             else {
863 46         86 $edate = default_make_date ($date1);
864             }
865             }
866 75 50       303 if ($verbose) {
867 0         0 print "-> '$edate'\n";
868             }
869 75         919 $text =~ s/\Q$orig\E/$edate/g;
870 75 100       642 if ($c->{replace}) {
871 13         26 &{$c->{replace}} ($c->{data}, $orig, $edate);
  13         31  
872             }
873             }
874             }
875 56         560 return $text;
876             }
877              
878             sub nengo_to_seireki
879             {
880 1     1 1 11070 my ($text) = @_;
881 1         3 my %data;
882 1         3 $data{count} = 0;
883              
884 1         6 my $out_text = subsjdate (
885             $text, {
886             make_date => \& nengo_to_seireki_make_date,
887             data => \%data,
888             }
889             );
890 1         18 $out_text =~ s/#REPLACEME(\d+)REPLACEME#/$data{$1}/g;
891 1         9 return $out_text;
892             }
893              
894             sub nengo_to_seireki_make_date
895             {
896 6     6 0 12 my ($data, $original, $date) = @_;
897 6 50       11 if ($date->{year}) {
898 6         34 $original =~ s/.*年/$date->{year}年/;
899 6         12 my $count = $data->{count};
900 6         12 $data->{$count} = $original;
901 6         7 $data->{count}++;
902 6         18 return "#REPLACEME${count}REPLACEME#";
903             }
904             else {
905 0         0 return $original;
906             }
907             }
908              
909             sub seireki_to_nengo
910             {
911 4     4 1 10584 my ($text) = @_;
912 4         7 my %data;
913 4         7 $data{count} = 0;
914              
915 4         19 my $out_text = subsjdate (
916             $text, {
917             make_date => \& seireki_to_nengo_make_date,
918             data => \%data,
919             }
920             );
921 4         36 $out_text =~ s/#REPLACEME(\d+)REPLACEME#/$data{$1}/g;
922 4         27 return $out_text;
923             }
924              
925             sub seireki_to_nengo_make_date
926             {
927 4     4 0 10 my ($data, $original, $date) = @_;
928 4         7 my $year = $date->{year};
929 4         20 my @eras = (
930             ['令和', 2019, 5, 1],
931             ['平成', 1989, 1, 8],
932             ['昭和', 1926, 12, 25],
933             ['大正', 1912, 7, 30],
934             ['明治', 1868, 1, 25],
935             );
936 4 50       7 if (defined $year) {
937 4         9 for my $era (@eras) {
938 8         11 my $ename = $era->[0];
939 8         10 my $eyear = $era->[1];
940 8         9 my $emonth = $era->[2];
941 8         10 my $eday = $era->[3];
942 8         14 my $month = $date->{month};
943 8         10 my $date = $date->{date};
944              
945             # This is a flag which says whether to perform a
946             # substitution of the year or not.
947              
948 8         8 my $subs;
949              
950             # If the year is greater than the era year, or if the year
951             # is the same as the era year and we do not know the
952             # month, just replace.
953              
954 8 100 66     43 if ($year > $eyear ||
    100 66        
      66        
955             ($year == $eyear && ! defined ($month))) {
956 2         4 $subs = 1;
957             }
958              
959             # If the year is the same, and there is a month
960              
961             elsif ($year == $eyear && defined ($month)) {
962              
963             # If there is a day of the month, then only substitute
964             # if the month is greater than the changeover month,
965             # or the month is the same, and the day of the month
966             # is greater than or equal to the changeover day of
967             # the month.
968              
969 4 50       8 if (defined ($date)) {
    0          
970 4 100 100     17 if ($month > $emonth ||
      100        
971             ($month == $emonth && $date >= $eday)) {
972 2         3 $subs = 1;
973             }
974             }
975              
976             # If we don't know the day of the month, substitute if
977             # the month is greater than or equal to the changeover
978             # month.
979              
980             elsif ($month >= $emonth) {
981 0         0 $subs = 1;
982             }
983             }
984 8 100       14 if ($subs) {
985              
986             # Only substitute if we need to.
987              
988 4 50       33 if ($original !~ /$ename/) {
989              
990             # The year counting starts from 1, so we add 1 to
991             # the difference.
992              
993 4         10 my $hyear = $year - $eyear + 1;
994 4         29 $original =~ s/\d+年/$ename${hyear}年/;
995             }
996              
997             # Don't replace again, stop the loop.
998              
999 4         13 last;
1000             }
1001             }
1002             }
1003 4         5 my $count = $data->{count};
1004 4         10 $data->{$count} = $original;
1005 4         5 $data->{count}++;
1006              
1007             # This is a tag for substituting with.
1008              
1009 4         18 return "#REPLACEME${count}REPLACEME#";
1010             }
1011              
1012             # Regularize any small integer Japanese numbers in a piece of text.
1013              
1014             sub regjnums
1015             {
1016 2     2 1 425 my ($input) = @_;
1017 2         24 $input =~ tr/0-9/0-9/;
1018 2         32 $input =~ s/([$kanjidigits]+)/kanji2number($1)/ge;
  1         3  
1019 2         9 return $input;
1020             }
1021              
1022             1;
1023