root/lang/perl/DateTimeX-Lite/trunk/tools/lib/DateTimeX/Lite/Tool/Locale/LDML.pm @ 30049

Revision 30032, 21.5 kB (checked in by daisuke, 5 years ago)

mo locale fixes (still need to tweak)

  • Property svn:keywords set to Id
Line 
1package # hide from PAUSE
2    DateTimeX::Lite::Tool::Locale::LDML;
3use Moose;
4use Moose::Util::TypeConstraints;
5use MooseX::ClassAttribute;
6use utf8;
7
8use Data::Dumper;
9use Lingua::EN::Inflect qw( PL_N );
10use List::Util qw( first );
11use Path::Class;
12use Storable qw( nstore_fd fd_retrieve );
13use XML::LibXML;
14
15
16has 'id' =>
17    ( is       => 'ro',
18      isa      => 'Str',
19      required => 1,
20    );
21
22has 'source_file' =>
23    ( is       => 'ro',
24      isa      => 'Path::Class::File',
25      required => 1,
26    );
27
28has 'document' =>
29    ( is       => 'ro',
30      isa      => 'XML::LibXML::Document',
31      required => 1,
32      clearer  => '_clear_document',
33    );
34
35class_has 'Aliases' =>
36    ( is      => 'ro',
37      isa     => 'HashRef',
38      lazy    => 1,
39      default => sub { return { 'C'             => 'en_US_POSIX',
40                                'POSIX'         => 'en_US_POSIX',
41                                # Apparently the Hebrew locale code was changed from iw to he at
42                                # one point.
43                                'iw'            => 'he',
44                                'iw_IL'         => 'he_IL',
45                                # CLDR got rid of no
46                                'no'            => 'nn',
47                                'no_NO'         => 'nn_NO',
48                                'no_NO_NY'      => 'nn_NO',
49                              } },
50    );
51
52class_has 'FormatLengths' =>
53    ( is      => 'ro',
54      isa     => 'ArrayRef',
55      lazy    => 1,
56      default => sub { return [qw( full long medium short ) ] },
57    );
58
59has 'version' =>
60    ( is         => 'ro',
61      isa        => 'Str',
62      lazy_build => 1,
63    );
64
65has 'generation_date' =>
66    ( is         => 'ro',
67      isa        => 'Str',
68      lazy_build => 1,
69    );
70
71has 'language' =>
72    ( is      => 'ro',
73      isa     => 'Str',
74      lazy    => 1,
75      default => sub { ( $_[0]->_parse_id() )[0] },
76    );
77
78has 'script' =>
79    ( is      => 'ro',
80      isa     => 'Str|Undef',
81      lazy    => 1,
82      default => sub { ( $_[0]->_parse_id() )[1] },
83    );
84
85has 'territory' =>
86    ( is      => 'ro',
87      isa     => 'Str|Undef',
88      lazy    => 1,
89      default => sub { ( $_[0]->_parse_id() )[2] },
90    );
91
92has 'variant' =>
93    ( is      => 'ro',
94      isa     => 'Str|Undef',
95      lazy    => 1,
96      default => sub { ( $_[0]->_parse_id() )[3] },
97    );
98
99has 'parent_id' =>
100    ( is         => 'ro',
101      isa        => 'Str',
102      lazy_build => 1,
103    );
104
105class_type 'XML::LibXML::Node';
106has '_calendar_node' =>
107    ( is      => 'ro',
108      isa     => 'XML::LibXML::Node|Undef',
109      lazy    => 1,
110      default => sub { $_[0]->_find_one_node( q{dates/calendars/calendar[@type='gregorian']} ) },
111    );
112
113has 'has_calendar_data' =>
114    ( is      => 'ro',
115      isa     => 'Bool',
116      lazy    => 1,
117      default => sub { $_[0]->_calendar_node() ? 1 : 0 },
118    );
119
120for my $thing ( { name   => 'day',
121                  length => 7,
122                  order  => [ qw( mon tue wed thu fri sat sun ) ],
123                },
124                { name   => 'month',
125                  length => 12,
126                  order  => [ 1..12 ],
127                },
128                { name   => 'quarter',
129                  length => 4,
130                  order  => [ 1..4 ],
131                },
132              )
133{
134    for my $context ( qw( format stand_alone ) )
135    {
136        for my $size ( qw( wide abbreviated narrow ) )
137        {
138            my $name = $thing->{name};
139
140            my $attr = $name . q{_} . $context . q{_} . $size;
141            has $attr =>
142                ( is         => 'ro',
143                  isa        => 'ArrayRef',
144                  lazy_build => 1,
145                );
146
147            my $required_length = $thing->{length};
148
149            ( my $xml_context = $context ) =~ s/_/-/g;
150            my $path =
151                ( join '/',
152                  PL_N($name),
153                  $name . 'Context' . q{[@type='} . $xml_context . q{']},
154                  $name . 'Width' . q{[@type='} . $size . q{']},
155                  $name
156                );
157
158            my $builder =
159                sub { my $self = shift;
160
161                      return [] unless $self->has_calendar_data();
162
163                      my @vals =
164                          $self->_find_preferred_values
165                              ( ( scalar $self->_calendar_node()->findnodes($path) ),
166                                'type',
167                                $thing->{order},
168                              );
169
170                      return [] unless @vals == $thing->{length};
171
172                      return \@vals;
173                    };
174
175            __PACKAGE__->meta()->add_method( '_build_' . $attr => $builder );
176        }
177    }
178}
179
180# eras have a different name scheme for sizes than other data
181# elements, go figure.
182for my $size ( [ wide => 'Names' ], [ abbreviated => 'Abbr' ], [ narrow => 'Narrow' ] )
183{
184    my $attr = 'era_' . $size->[0];
185
186    has $attr =>
187        ( is         => 'ro',
188          isa        => 'ArrayRef',
189          lazy_build => 1,
190        );
191
192    my $path =
193        ( join '/',
194          'eras',
195          'era' . $size->[1],
196          'era',
197        );
198
199    my $builder =
200        sub { my $self = shift;
201
202              return [] unless $self->has_calendar_data();
203
204              my @vals =
205                  $self->_find_preferred_values
206                      ( ( scalar $self->_calendar_node()->findnodes($path) ),
207                        'type',
208                        [ 0, 1 ],
209                      );
210
211              return [] unless @vals == 2;
212
213              return \@vals;
214          };
215
216    __PACKAGE__->meta()->add_method( '_build_' . $attr => $builder );
217}
218
219for my $type ( qw( date time ) )
220{
221    for my $length ( qw( full long medium short ) )
222    {
223        my $attr = $type . q{_format_} . $length;
224
225        has $attr =>
226            ( is         => 'ro',
227              isa        => 'Str|Undef',
228              lazy_build => 1,
229            );
230
231        my $path =
232            ( join '/',
233              $type . 'Formats',
234              $type . q{FormatLength[@type='} . $length . q{']},
235              $type . 'Format',
236              'pattern',
237            );
238
239        my $builder =
240            sub { my $self = shift;
241
242                  return unless $self->has_calendar_data();
243
244                  return $self->_find_one_node_text( $path, $self->_calendar_node() );
245              };
246
247        __PACKAGE__->meta()->add_method( '_build_' . $attr => $builder );
248    }
249}
250
251has 'default_date_format_length' =>
252    ( is      => 'ro',
253      isa     => 'Str|Undef',
254      lazy    => 1,
255      default => sub { $_[0]->_find_one_node_attribute( 'dateFormats/default',
256                                                        $_[0]->_calendar_node(),
257                                                        'choice' )
258                     },
259    );
260
261has 'default_time_format_length' =>
262    ( is      => 'ro',
263      isa     => 'Str|Undef',
264      lazy    => 1,
265      default => sub { $_[0]->_find_one_node_attribute( 'timeFormats/default',
266                                                        $_[0]->_calendar_node(),
267                                                        'choice' )
268                     },
269    );
270
271has 'am_pm_abbreviated' =>
272    ( is         => 'ro',
273      isa        => 'ArrayRef',
274      lazy_build => 1,
275    );
276
277has 'datetime_format' =>
278    ( is         => 'ro',
279      isa        => 'Str|Undef',
280      lazy_build => 1,
281    );
282
283has 'available_formats' =>
284    ( is         => 'ro',
285      isa        => 'HashRef[Str]',
286      lazy_build => 1,
287    );
288
289# This is really only built once for all objects
290has '_first_day_of_week_index' =>
291    ( is         => 'ro',
292      isa        => 'HashRef',
293      lazy_build => 1,
294    );
295
296has 'first_day_of_week' =>
297    ( is         => 'ro',
298      isa        => 'Int',
299      lazy_build => 1,
300    );
301
302for my $thing ( qw( language script territory variant ) )
303{
304    {
305        my $en_attr = q{en_} . $thing;
306
307        has $en_attr =>
308            ( is         => 'ro',
309              isa        => 'Str|Undef',
310              lazy_build => 1,
311            );
312
313        my $en_ldml;
314        my $builder =
315            sub { my $self = shift;
316
317                  my $val_from_id = $self->$thing();
318                  return unless defined $val_from_id;
319
320                  $en_ldml ||= (ref $self)->new_from_file( $self->source_file()->dir()->file('en.xml') );
321
322                  my $path =
323                      'localeDisplayNames/' . PL_N( $thing ) . q{/} . $thing . q{[@type='} . $self->$thing() . q{']};
324
325                  return $en_ldml->_find_one_node_text($path);
326              };
327
328        __PACKAGE__->meta()->add_method( '_build_' . $en_attr => $builder );
329    }
330
331    {
332        my $native_attr = q{native_} . $thing;
333
334        has $native_attr =>
335            ( is         => 'ro',
336              isa        => 'Str|Undef',
337              lazy_build => 1,
338            );
339
340        my $builder =
341            sub { my $self = shift;
342
343                  my $val_from_id = $self->$thing();
344                  return unless defined $val_from_id;
345
346                  my $path =
347                      'localeDisplayNames/' . PL_N( $thing ) . q{/} . $thing . q{[@type='} . $self->$thing() . q{']};
348
349                  for ( my $ldml = $self; $ldml; $ldml = $ldml->_load_parent() )
350                  {
351                      my $native_val = $ldml->_find_one_node_text($path);
352                      return $native_val if defined $native_val;
353                  }
354
355                  return;
356              };
357
358        __PACKAGE__->meta()->add_method( '_build_' . $native_attr => $builder );
359    }
360}
361
362sub _load_parent
363{
364    my $self = shift;
365
366    my $parent_id = $self->parent_id();
367    return unless defined $parent_id;
368
369    my $file = $self->source_file()->dir()->file( $parent_id . '.xml' );
370
371    return unless -f $file;
372
373    return (ref $self)->new_from_file($file);
374}
375
376{
377    my %Cache;
378    sub new_from_file
379    {
380        my $class = shift;
381        my $file  = file( shift );
382
383        my $id = $file->basename();
384        $id =~ s/\.xml$//i;
385
386        return $Cache{$id}
387            if $Cache{$id};
388
389        my $doc = $class->_resolve_document_aliases($file);
390
391        return $Cache{$id} =
392            $class->new( id          => $id,
393                         source_file => $file,
394                         document    => $doc,
395                       );
396    }
397}
398
399{
400    my $Parser = XML::LibXML->new();
401    $Parser->load_catalog( '/etc/xml/catalog.xml' );
402    $Parser->load_ext_dtd(0);
403
404    sub _resolve_document_aliases
405    {
406        my $class = shift;
407        my $file  = shift;
408
409print "Parseing $file\n===\n";
410
411        my $doc = $Parser->parse_file( $file->stringify() );
412
413        $class->_resolve_aliases_in_node( $doc->documentElement(), $file );
414
415        return $doc;
416    }
417}
418
419sub _resolve_aliases_in_node
420{
421    my $class = shift;
422    my $node  = shift;
423    my $file  = shift;
424
425 ALIAS:
426    for my $node ( $node->getElementsByTagName('alias') )
427    {
428        # Replacing all the aliases is slow, and we really don't care
429        # about most of the data in the file, just the
430        # localeDisplayNames and the gregorian calendar.
431        #
432        # We also end up skipping the case where the entire locale is an alias to some
433        # other locale. This is handled in the generated Perl code.
434        for ( my $p = $node->parentNode(); $p; $p = $p->parentNode() )
435        {
436            if ( $p->nodeName() eq 'calendar' )
437            {
438                if ( $p->getAttribute('type') eq 'gregorian' )
439                {
440                    last;
441                }
442                else
443                {
444                    next ALIAS;
445                }
446            }
447
448            last if $p->nodeName() eq 'localeDisplayNames';
449
450            next ALIAS if $p->nodeName() eq 'ldml';
451            next ALIAS if $p->nodeName() eq '#document';
452        }
453
454        $class->_resolve_alias( $node, $file );
455    }
456}
457
458sub _resolve_alias
459{
460    my $class = shift;
461    my $node  = shift;
462    my $file  = shift;
463
464    my $source = $node->getAttribute('source')
465        or die "Alias with no source in $file";
466
467    if ( $source eq 'locale' )
468    {
469        $class->_resolve_local_alias( $node, $file );
470    }
471    else
472    {
473        $class->_resolve_remote_alias( $node, $file );
474    }
475}
476
477sub _resolve_local_alias
478{
479    my $class = shift;
480    my $node = shift;
481    my $file = shift;
482
483    my $path = $node->getAttribute('path');
484
485    # The path resolves from the context of the parent node, not the
486    # current node. Why? Why not?
487    $class->_replace_alias_with_path( $node, $path, $node->parentNode(), $file );
488}
489
490sub _resolve_remote_alias
491{
492    my $class = shift;
493    my $node  = shift;
494    my $file  = shift;
495
496    my $source = $node->getAttribute('source');
497    my $target_file = $file->dir()->file( $source . q{.xml} );
498
499    my $doc = $class->_resolve_document_aliases($target_file);
500
501    # I'm not sure nodePath() will work, since it seems to return an
502    # array-based index like /ldml/dates/calendars/calendar[4]. I'm
503    # not sure if LDML allows this, but the target file might contain
504    # a different ordering or may just be missing something. This
505    # whole alias thing is madness.
506    #
507    # However, remote aliases seem to be a rare case outside of an
508    # alias for the entire file, so they can be investigated as
509    # needed.
510
511    my $path = $node->getAttribute('path') || $node->parentNode()->nodePath();
512
513    if (! $path) {
514        printf STDERR "TODO: alias node has source (%s), but we don't know to do with it\n", $node->getAttribute('source');
515        return;
516    }
517
518    $class->_replace_alias_with_path( $node, $path, $doc, $target_file );
519}
520
521sub _replace_alias_with_path
522{
523    my $class   = shift;
524    my $node    = shift;
525    my $path    = shift;
526    my $context = shift;
527    my $file    = shift;
528
529    my @targets = $context->findnodes($path);
530
531    my $line = $node->line_number();
532    die "Path ($path) resolves to multiple nodes in $file (line $line)"
533        if @targets > 1;
534
535    die "Path ($path) does not resolve to any node in $file (line $line)"
536        if @targets == 0;
537
538    my $parent = $node->parentNode();
539
540    $parent->removeChildNodes();
541    $parent->appendChild( $_->cloneNode(1) ) for $targets[0]->childNodes();
542
543    # This means the same things get resolved multiple times, but it's
544    # pretty fast with LibXML, and simpler to code than something more
545    # efficient.
546    $class->_resolve_aliases_in_node( $parent, $file );
547}
548
549sub BUILD
550{
551    my $self = shift;
552
553    my $meth = q{_} . $self->id() . q{_hack};
554
555    # This gives us a chance to apply bug fixes to the data as needed.
556    $self->$meth()
557        if $self->can($meth);
558
559    return $self;
560}
561
562sub _az_hack
563{
564    my $self = shift;
565    my $data = shift;
566
567    # The az.xml file appears to have a mistake in the wide day names,
568    # thursday and friday are the same for this locale
569
570    my $thu = $self->_find_one_node_text( q{days/dayContext[@type='format']/dayWidth[@type='wide']/day[@type='thu']},
571                                          $self->_calendar_node() );
572
573    my $fri = $self->_find_one_node( q{days/dayContext[@type='format']/dayWidth[@type='wide']/day[@type='fri']},
574                                     $self->_calendar_node() );
575
576    $fri->removeChildNodes();
577
578    $thu =~ s/ \w+$//;
579    $fri->appendChild( $self->document()->createTextNode($thu) );
580}
581
582sub _gaa_hack
583{
584    my $self = shift;
585    my $data = shift;
586
587    my $path = q{days/dayContext[@type='format']/dayWidth[@type='abbreviated']/day[@type='sun']};
588
589    my $day_text = $self->_find_one_node_text( $path, $self->_calendar_node() );
590
591    return unless $day_text eq 'Ho';
592
593    # I am completely making this up, but the data is marked as
594    # unconfirmed in the locale file and making something up is
595    # preferable to having two days with the same abbreviation
596
597    my $day = $self->_find_one_node( $path, $self->_calendar_node() );
598
599    $day->removeChildNodes();
600    $day->appendChild( $self->document()->createTextNode('Hog') );
601}
602
603sub _ve_hack
604{
605    my $self = shift;
606    my $data = shift;
607
608    my $path = q{months/monthContext[@type='format']/monthWidth[@type='abbreviated']/month[@type='3']};
609
610    my $day_text = $self->_find_one_node_text( $path, $self->_calendar_node() );
611
612    return unless $day_text eq 'Ṱha';
613
614    # Again, making stuff up to avoid non-unique abbreviations
615
616    my $day = $self->_find_one_node( $path, $self->_calendar_node() );
617
618    $day->removeChildNodes();
619    $day->appendChild( $self->document()->createTextNode('Ṱhf') );
620}
621
622sub _build_version
623{
624    my $self = shift;
625
626    my $version = $self->_find_one_node_attribute( 'identity/version', 'number' );
627    $version =~ s/^\$Revision:\s+//;
628    $version =~ s/\s+\$$//;
629
630    return $version;
631}
632
633sub _build_generation_date
634{
635    my $self = shift;
636
637    my $date = $self->_find_one_node_attribute( 'identity/generation', 'date' );
638    $date =~ s/^\$Date:\s+//;
639    $date =~ s/\s+\$$//;
640
641    return $date;
642}
643
644sub _parse_id
645{
646    my $self = shift;
647
648    return
649        $self->id() =~ /([a-z]+)               # language
650                        (?: _([A-Z][a-z]+) )?  # script - Title Case - optional
651                        (?: _([A-Z]+) )?       # territory - ALL CAPS - optional
652                        (?: _([A-Z]+) )?       # variant - ALL CAPS - optional
653                       /x;
654}
655
656sub _build_parent_id
657{
658    my $self = shift;
659
660    my $source = $self->_find_one_node_attribute( 'alias', 'source' );
661    return $source if defined $source;
662
663    my @parts =
664        ( grep { defined }
665          $self->language(),
666          $self->script(),
667          $self->territory(),
668          $self->variant(),
669        );
670
671    pop @parts;
672
673    if (@parts)
674    {
675        return join '_', @parts;
676    }
677    else
678    {
679        return $self->id() eq 'root' ? 'Base' : 'root';
680    }
681}
682
683sub _build_am_pm_abbreviated
684{
685    my $self = shift;
686
687    my $am = $self->_find_one_node_text( 'am', $self->_calendar_node() );
688    my $pm = $self->_find_one_node_text( 'pm', $self->_calendar_node() );
689
690    return [] unless defined $am && defined $pm;
691
692    return [ $am, $pm ];
693}
694
695sub _build_datetime_format
696{
697    my $self = shift;
698
699    return
700        $self->_find_one_node_text( 'dateTimeFormats/dateTimeFormatLength/dateTimeFormat/pattern',
701                                    $self->_calendar_node() );
702}
703
704sub _build_available_formats
705{
706    my $self = shift;
707
708    return {} unless $self->has_calendar_data();
709
710    my @nodes = $self->_calendar_node()->findnodes('dateTimeFormats/availableFormats/dateFormatItem');
711
712    my %index;
713    for my $node (@nodes)
714    {
715        push @{ $index{ $node->getAttribute('id') } }, $node;
716    }
717
718    my %formats;
719    for my $id ( keys %index )
720    {
721        my $preferred = $self->_find_preferred_node( @{ $index{$id} } )
722            or next;
723
724        $formats{$id} = join '', map { $_->data() } $preferred->childNodes();
725    }
726
727    return \%formats;
728}
729
730sub _build_first_day_of_week
731{
732    my $self = shift;
733
734    my $terr = $self->territory();
735    return 1 unless defined $terr;
736
737    my $index = $self->_first_day_of_week_index();
738
739    return $index->{$terr} || 1;
740}
741
742sub _find_preferred_values
743{
744    my $self  = shift;
745    my $nodes = shift;
746    my $attr  = shift;
747    my $order = shift;
748
749    my @nodes = $nodes->get_nodelist();
750
751    return [] unless @nodes;
752
753    my %index;
754
755    for my $node (@nodes)
756    {
757        push @{ $index{ $node->getAttribute($attr) } }, $node;
758    }
759
760    my @preferred;
761    for my $attr ( @{ $order } )
762    {
763        # There may be nothing in the index for incomplete sets (of
764        # days, months, etc)
765        my @matches = @{ $index{$attr} || [] };
766
767        my $preferred = $self->_find_preferred_node(@matches)
768            or next;
769
770        push @preferred, join '', map { $_->data() } $preferred->childNodes();
771    }
772
773    return @preferred;
774}
775
776sub _find_preferred_node
777{
778    my $self  = shift;
779    my @nodes = @_;
780
781    return unless @nodes;
782
783    return $nodes[0] if @nodes == 1;
784
785    my $non_draft = first { ! $_->getAttribute('draft') } @nodes;
786
787    return $non_draft if $non_draft;
788
789    return $nodes[0];
790}
791
792sub _find_one_node_text
793{
794    my $self = shift;
795
796    my $node = $self->_find_one_node(@_);
797
798    return unless $node;
799
800    return join '', map { $_->data() } $node->childNodes();
801}
802
803sub _find_one_node_attribute
804{
805    my $self = shift;
806
807    # attr name will always be last
808    my $attr = pop;
809
810    my $node = $self->_find_one_node(@_);
811
812    return unless $node;
813
814    return $node->getAttribute($attr);
815}
816
817sub _find_one_node
818{
819    my $self    = shift;
820    my $path    = shift;
821    my $context = shift || $self->document()->documentElement();
822
823    my @nodes = $self->_find_preferred_node( $context->findnodes($path) );
824
825    if ( @nodes > 1 )
826    {
827        my $context_path = $context->nodePath();
828
829        die "Found multiple nodes for $path under $context_path";
830    }
831
832    return $nodes[0];
833}
834
835{
836    my %days = do { my $x = 1; map { $_ => $x++ } qw( mon tue wed thu fri sat sun ) };
837
838    my %index;
839
840    my $file_name = 'supplementalData.xml';
841
842    sub _build__first_day_of_week_index
843    {
844        return \%index
845            if keys %index;
846
847        my $self = shift;
848
849        my $file;
850        for my $dir ( $self->source_file()->dir(),
851                      $self->source_file()->dir()->parent()->subdir('supplemental'),
852                    )
853        {
854            $file = $dir->file($file_name);
855
856            last if -f $file;
857        }
858
859        die "Cannot find $file_name"
860            unless -f $file;
861
862        my $doc = XML::LibXML->new()->parse_file( $file->stringify() );
863
864        my @nodes = $doc->findnodes('supplementalData/weekData/firstDay');
865
866        for my $node (@nodes)
867        {
868            my $day_num = $days{ $node->getAttribute('day') };
869
870            $index{$_} = $day_num for split /\s+/, $node->getAttribute('territories');
871        }
872
873        return \%index;
874    }
875}
876
877__PACKAGE__->meta()->make_immutable();
878no Moose;
879no Moose::Util::TypeConstraints;
880
8811;
Note: See TracBrowser for help on using the browser.