Changeset 24596

Show
Ignore:
Timestamp:
11/22/08 12:37:01 (6 years ago)
Author:
daisuke
Message:

locale generator

Files:
1 modified

Legend:

Unmodified
Added
Removed
  • lang/perl/DateTime-Lite/trunk/tools/lib/DateTime/Lite/Tool/Locale/Generator.pm

    r24525 r24596  
    55use Moose::Util::TypeConstraints; 
    66use MooseX::Types::Path::Class qw(Dir); 
     7use Data::Dumper; 
    78use DateTime::Lite::Tool::Locale::LDML; 
    89use File::chdir; 
     
    4647no Moose::Util::TypeConstraints; 
    4748 
     49my %DATA; 
     50 
     51sub get_ldml_from_id { 
     52    my ($self, $id) = @_; 
     53    return $DATA{$id}; 
     54} 
     55 
    4856sub run { 
    4957    my $self = shift; 
     
    5563    ); 
    5664     
    57     local $CWD = $self->dest->stringify; 
    58     system("unzip", "core.zip") and die $!; 
    59  
    60     my @files = $self->read_all_files($self->dest->subdir("main")); 
     65    my @files; 
     66    { 
     67        local $CWD = $self->dest->stringify; 
     68        system("unzip", "core.zip") and die $!; 
     69 
     70        @files = $self->read_all_files($self->dest->subdir("main")); 
     71    } 
     72 
     73    %DATA = map { ($_->id, $_) } @files; 
     74 
    6175    $self->generate_dat_files(@files); 
    6276} 
     
    118132    } 
    119133 
    120     open my $fh, '>:utf8', $dat_file 
     134    my $fh = $dat_file->openw() 
    121135        or die "Cannot write to $dat_file: $!"; 
    122  
    123 #    write_pm_header( $fh, $ldml ); 
    124 #    write_pm_inheritance( $fh, $ldml ); 
    125 #    write_pm_cldr_version( $fh ); 
    126 #    write_pm_subs( $fh, $ldml ); 
    127 #    write_pm_footer( $fh, $ldml ); 
    128 #} 
    129  
    130     print $fh <<EOF; 
     136    $fh->binmode(':utf8'); 
     137 
     138    print $fh <<EOF or die "could not write to $dat_file: $!"; 
    131139########################################################################### 
    132140# 
     
    143151########################################################################### 
    144152EOF 
     153 
     154    my $data = $self->generate_data($ldml->id); 
     155 
     156    print $fh Dumper($data); 
     157    close($fh); 
     158} 
     159 
     160sub generate_data { 
     161    my ($self, $ldml) = @_; 
     162 
     163    $ldml = $DATA{$ldml} if ! ref $ldml; 
     164    return unless $ldml; 
     165 
    145166    my %data = ( 
    146         cldr_version => $self->version 
     167        cldr_version => $self->version, 
    147168    ); 
     169 
     170    if (my $parent_id = $ldml->parent_id) { 
     171        print "fetching parent $parent_id\n"; 
     172        my $parent_data = $self->generate_data($parent_id); 
     173        if ($parent_data) { 
     174            %data = (%data, %$parent_data); 
     175        } 
     176    } 
     177 
     178    $data{id} = $ldml->id; 
    148179 
    149180    foreach my $attr ( sort { $a->name() cmp $b->name() } 
     
    153184            /^(?:day_|month_|quarter_|am_pm|era_|date_|time_|datetime_|first_day_)/; 
    154185 
    155         next if make_alias( $fh, $ldml, $attr->name() ); 
    156  
     186        next if $self->make_alias( $ldml, \%data, $attr->name() ); 
     187 
     188        my $name  = $attr->name; 
     189        my $value = $ldml->$name; 
    157190        my $type = $attr->type_constraint(); 
    158191 
    159         if ( $type->is_a_type_of('ArrayRef') ) 
    160         { 
    161             write_arrayref_sub( $fh, $ldml, $attr->name() ); 
     192        my $ok = 0; 
     193        if (defined $value) { 
     194            if ($type->is_a_type_of('ArrayRef')) { 
     195                $ok = scalar @$value; 
     196            } elsif ($type->is_a_type_of('HashRef')) { 
     197                $ok = scalar keys %$value; 
     198            } elsif ($type->is_a_type_of('Str') || $type->is_a_type_of('Int')) { 
     199                $ok = length $value; 
     200            } else { 
     201                die "Cannot handle type: $name"; 
     202            } 
     203         
     204            $data{ $name } = $value if $ok; 
    162205        } 
    163         elsif ( $type->is_a_type_of('HashRef') ) 
    164         { 
    165             write_hashref_sub( $fh, $ldml, $attr->name() ); 
    166         } 
    167         elsif ( $type->is_a_type_of('Str') ) 
    168         { 
    169             write_string_sub( $fh, $ldml, $attr->name() ); 
    170         } 
    171         elsif ( $type->is_a_type_of('Int') ) 
    172         { 
    173             write_int_sub( $fh, $ldml, $attr->name() ); 
    174         } 
    175         else 
    176         { 
    177             die "Cannot handle type: " . $type->name(); 
    178         } 
    179     } 
    180  
    181 } 
     206    } 
     207    return \%data; 
     208} 
     209 
     210 
     211sub make_alias { 
     212    my $self = shift; 
     213    my $ldml = shift; 
     214    my $data = shift; 
     215    my $name = shift; 
     216 
     217    if ( $name =~ /stand_alone/ ) 
     218    { 
     219        return $self->make_stand_alone_alias( $ldml, $data, $name ); 
     220    } 
     221    elsif ( $name =~ /(?:abbreviated|narrow)/ ) 
     222    { 
     223        return $self->make_length_alias( $ldml, $data, $name ); 
     224    } 
     225 
     226} 
     227 
     228sub make_stand_alone_alias 
     229{ 
     230    my $self = shift; 
     231    my $ldml = shift; 
     232    my $data = shift; 
     233    my $name = shift; 
     234 
     235    ( my $format = $name ) =~ s/stand_alone/format/; 
     236 
     237    return $self->maybe_make_alias( $ldml, $data, $name, $format ); 
     238} 
     239 
     240sub make_length_alias 
     241{ 
     242    my $self = shift; 
     243    my $ldml = shift; 
     244    my $data = shift; 
     245    my $name = shift; 
     246    # This isn't well documented (or really documented at all) in the 
     247    # LDML spec, but the example seem to suggest that for the narrow 
     248    # form, the format type should "inherit" from the stand-alone 
     249    # type if possible, rather than the abbreviated type. 
     250    # 
     251    # See 
     252    # http://www.unicode.org/cldr/data/charts/by_type/calendar-gregorian.day.html 
     253    # for examples of the expected output. Note that the format narrow 
     254    # days for English are inherited from its stand-alone narrow form, 
     255    # not the root locale. 
     256    if ( $name =~ /format_narrow/ ) 
     257    { 
     258        ( my $to_name = $name ) =~ s/format/stand_alone/; 
     259        return 1 
     260            if $self->maybe_make_alias( $ldml, $data, $name, $to_name ); 
     261    } 
     262 
     263    # It seems like the quarters should just inherit up the (Perl) 
     264    # inheritance chain, rather than from the next biggest size. See 
     265    # http://www.unicode.org/cldr/data/charts/by_type/calendar-gregorian.quarter.html 
     266    # for an example. Note that the English format narrow quarter is 
     267    # "1", not "Q1". 
     268    if ( $name =~ /quarter_(\w+)_narrow/ ) 
     269    { 
     270        return; 
     271    } 
     272 
     273    ( my $to_name = $name ); 
     274    $to_name =~ s/abbreviated/wide/; 
     275    $to_name =~ s/narrow/abbreviated/; 
     276 
     277    return $self->maybe_make_alias( $ldml, $data, $name, $to_name ); 
     278} 
     279 
     280sub maybe_make_alias 
     281{ 
     282    my $self = shift; 
     283    my $ldml = shift; 
     284    my $data = shift; 
     285    my $from = shift; 
     286    my $to   = shift; 
     287 
     288    my $val = $ldml->$from(); 
     289 
     290    return if @{ $val }; 
     291 
     292    return unless $ldml->can($to); 
     293 
     294    my $to_val = $ldml->$to(); 
     295 
     296    return unless @{ $to_val }; 
     297 
     298    $data->{$from} = $to; 
     299 
     300    return 1; 
     301} 
     302 
     303sub write_arrayref_sub 
     304{ 
     305    my $self = shift; 
     306    my $ldml = shift; 
     307    my $data = shift; 
     308    my $name = shift; 
     309 
     310    my $arr = $ldml->$name(); 
     311 
     312    return unless @{ $arr }; 
     313 
     314    $data->{$name} = $arr; 
     315} 
     316 
    182317 
    1833181;