The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package    # hide from PAUSE
    ModuleGenerator::Locale;

use v5.22;

use strict;
use warnings;
use feature qw( postderef signatures );
use namespace::autoclean;

use DateTime::Locale::Util qw( parse_locale_code );
use JSON::MaybeXS qw( decode_json );

use Moose;
use MooseX::Types::Moose qw( HashRef Int Maybe Str );
use MooseX::Types::Path::Class qw( Dir File );

## no critic (TestingAndDebugging::ProhibitNoWarnings)
no warnings qw( experimental::postderef experimental::signatures );
## use critic

has code => (
    is       => 'ro',
    isa      => Str,
    required => 1,
);

has _source_data_root => (
    is       => 'ro',
    isa      => Dir,
    required => 1,
    init_arg => 'source_data_root',
);

has _parent_code => (
    is      => 'ro',
    isa     => Str,
    lazy    => 1,
    builder => '_build_parent_code',
);

has _parent_locale => (
    is      => 'ro',
    isa     => Maybe ['ModuleGenerator::Locale'],
    lazy    => 1,
    builder => '_build_parent_locale',
);

has _json_file => (
    is      => 'ro',
    isa     => File,
    lazy    => 1,
    builder => '_build_json_file',
);

has _glibc_file => (
    is      => 'ro',
    isa     => File,
    lazy    => 1,
    builder => '_build_glibc_file',
);

has _glibc_data => (
    is      => 'ro',
    isa     => HashRef,
    lazy    => 1,
    builder => '_build_glibc_data',
);

has _parsed_code => (
    is      => 'ro',
    isa     => HashRef [ Maybe [Str] ],
    lazy    => 1,
    builder => '_build_parsed_code',
);

has language_code => (
    is      => 'ro',
    isa     => Str,
    lazy    => 1,
    default => sub ($self) { $self->_parsed_code->{language} },
);

has script_code => (
    is      => 'ro',
    isa     => Maybe [Str],
    lazy    => 1,
    default => sub ($self) { $self->_parsed_code->{script} },
);

has territory_code => (
    is      => 'ro',
    isa     => Maybe [Str],
    lazy    => 1,
    default => sub ($self) { $self->_parsed_code->{territory} },
);

has variant_code => (
    is      => 'ro',
    isa     => Maybe [Str],
    lazy    => 1,
    default => sub ($self) { $self->_parsed_code->{variant} },
);

has en_name => (
    is      => 'ro',
    isa     => Str,
    lazy    => 1,
    builder => '_build_en_name',
);

has native_name => (
    is      => 'ro',
    isa     => Str,
    lazy    => 1,
    builder => '_build_native_name',
);

for my $lang (qw( en native )) {
    for my $part (qw( language territory script variant )) {
        my $attr = q{_} . $lang . q{_} . $part;
        has $attr => (
            is      => 'ro',
            isa     => Maybe [Str],
            lazy    => 1,
            builder => '_build' . $attr,
        );
    }
}

has _cldr_json_data => (
    is      => 'ro',
    isa     => HashRef,
    lazy    => 1,
    builder => '_build_cldr_json_data',
);

has _first_day_of_week => (
    is      => 'ro',
    isa     => Int,
    lazy    => 1,
    builder => '_build_first_day_of_week',
);

has version => (
    is      => 'ro',
    isa     => Int,
    lazy    => 1,
    builder => '_build_version',
);

has data_hash => (
    is      => 'ro',
    isa     => HashRef,
    lazy    => 1,
    builder => '_build_data_hash',
);

{
    my %Cache;

    sub instance ( $class, %p ) {
        return $Cache{ $p{code} } //= $class->new(%p);
    }
}

## no critic (ValuesAndExpressions::ProhibitFiletest_f)

sub source_files ($self) {
    return grep {-f} $self->_json_file, $self->_glibc_file;
}

sub _build_cldr_json_data($self) {
    my $json = $self->_json_from( $self->_json_file );

    my $json_file_id = $self->_json_file->parent->basename;
    return $json->{main}{$json_file_id};
}

sub _build_data_hash ($self) {
    my $cal_root = $self->_cldr_json_data->{dates}{calendars}{gregorian};

    my %data = (
        ## no critic (ValuesAndExpressions::ProhibitCommaSeparatedStatements)
        am_pm_abbreviated =>
            [ $cal_root->{dayPeriods}{format}{abbreviated}->@{ 'am', 'pm' } ],
        available_formats => $cal_root->{dateTimeFormats}{availableFormats},
        code              => $self->code,
        first_day_of_week => $self->_first_day_of_week,
        version           => $self->version,
        $self->_glibc_data->%*,
    );

    for my $thing (qw( name language script territory variant )) {
        for my $type (qw( en native )) {
            my $meth
                = ( $thing eq 'name' ? q{} : q{_} ) . $type . q{_} . $thing;
            my $key = join q{_}, ( ( $type eq 'en' ? () : $type ), $thing );
            $data{$key} = $self->$meth;
        }
    }

    for my $thing (qw( date time dateTime )) {
        for my $length (qw( full long medium short )) {
            my $val = $cal_root->{ $thing . 'Formats' }{$length};
            $data{ lc $thing . q{_format_} . $length }
                = ref $val ? $val->{_value} : $val;
        }
    }

    my %ordering = (
        day     => [qw( mon tue wed thu fri sat sun )],
        month   => [ 1 .. 12 ],
        quarter => [ 1 .. 4 ],
    );

    my @lengths = qw( abbreviated narrow wide );
    for my $thing (qw( day month quarter )) {
        for my $type (qw( format stand-alone )) {
            for my $length (@lengths) {
                my $key = join q{_}, $thing, ( $type =~ s/-/_/gr ), $length;
                $data{$key}
                    = [ $cal_root->{ $thing . 's' }{$type}{$length}
                        ->@{ $ordering{$thing}->@* } ];
            }
        }
    }

    my %eraLength = (
        narrow      => 'Narrow',
        abbreviated => 'Abbr',
        wide        => 'Names',
    );
    for my $length (@lengths) {
        ## no critic (ValuesAndExpressions::ProhibitCommaSeparatedStatements)
        $data{ 'era_' . $length }
            = [ $cal_root->{eras}{ 'era' . $eraLength{$length} }->@{ 0, 1 } ];
    }

    return \%data;
}

sub _build_glibc_data ($self) {
    my $parent = $self->_parent_locale;

    unless ( -f $self->_glibc_file ) {
        return $parent->_glibc_data;
    }

    my $raw = $self->_glibc_file->slurp;

    return {
        glibc_datetime_format =>
            $self->_extract_glibc_value( 'd_t_fmt', $raw )
            // $parent->_glibc_data->{glibc_datetime_format},
        glibc_date_format => $self->_extract_glibc_value( 'd_fmt', $raw )
            // $parent->_glibc_data->{glibc_date_format},
        glibc_date_1_format => $self->_extract_glibc_value( 'date_fmt', $raw )
            // $parent->_glibc_data->{glibc_date_1_format},
        glibc_time_format => $self->_extract_glibc_value( 't_fmt', $raw )
            // $parent->_glibc_data->{glibc_time_format},
        glibc_time_12_format =>
            $self->_extract_glibc_value( 't_fmt_ampm', $raw )
            // $parent->_glibc_data->{glibc_time_12_format},
    };
}

sub _build_glibc_file ($self) {
    my $glibc_code = join '_', grep {defined} $self->language_code,
        $self->territory_code;
    if ( my $script = $self->_en_script ) {
        $glibc_code .= '@' . lc $script;
    }

    # This ensures some sort of sanish fallback
    $glibc_code = 'POSIX' if $self->code eq 'root';

    return $self->_source_data_root->file( 'glibc-locales', $glibc_code );
}

sub _extract_glibc_value ( $self, $key, $raw ) {
    my ($val) = $raw =~ /^\Q$key\E\s+"([^"]+?)"/m
        or return;

    $val =~ s/[\\\/]\n//g;

    $val =~ s/\<U([A-F\d]+)\>/chr(hex($1))/eg;

    return $val;
}

sub _build_version ($self) {
    return $self->_cldr_json_data->{identity}{version}{_cldrVersion};
}

sub _build_json_file ($self) {
    my $code_file = $self->_source_data_root->file(
        qw( cldr-dates-full main ),
        $self->code, 'ca-gregorian.json'
    );
    return $code_file if -f $code_file;

    my $parent_file = $self->_source_data_root->file(
        qw( cldr-dates-full main ),
        $self->_parent_code,
        'ca-gregorian.json'
    );

    unless ( -f $parent_file ) {
        die "Could not find $code_file or $parent_file for locale ",
            $self->code, "\n";
    }

    return $parent_file;
}

sub _build_parent_code ($self) {
    my $explicit_parent = $self->_explicit_parents;

    return $explicit_parent->{ $self->code }
        if $explicit_parent->{ $self->code };

    return
          $self->code =~ /-/    ? $self->code =~ s/-[^-]+$//r
        : $self->code ne 'root' ? 'root'
        :   die 'There is no parent for the root locale!';
}

sub _has_parent_code ($self) {
    return $self->code ne 'root';
}

sub _build_parent_locale ($self) {
    return unless $self->_has_parent_code;
    return ModuleGenerator::Locale->instance(
        code             => $self->_parent_code,
        source_data_root => $self->_source_data_root
    );
}

sub _explicit_parents ($self) {
    state $explicit_parents;
    return $explicit_parents if $explicit_parents;

    my $json = $self->_json_from(
        $self->_source_data_root->file(
            qw( cldr-core supplemental parentLocales.json ))
    );

    return $explicit_parents
        = $json->{supplemental}{parentLocales}{parentLocale};
}

sub _build_parsed_code ($self) {
    my %parsed = parse_locale_code( $self->code );
    return \%parsed;
}

{
    my $i = 1;
    my %days = map { $_ => $i++ } qw( mon tue wed thu fri sat sun );

    sub _build_first_day_of_week {
        my $self = shift;

        my $terr = $self->territory_code;
        return 1 unless defined $terr;

        my $index = $self->_first_day_of_week_index;
        return $index->{$terr} ? $days{ $index->{$terr} } : 1;
    }
}

sub _first_day_of_week_index ($self) {
    state $first_day_of_week_index;
    return $first_day_of_week_index if $first_day_of_week_index;

    my $json = $self->_json_from(
        $self->_source_data_root->file(
            qw( cldr-core supplemental weekData.json ))
    );

    return $first_day_of_week_index
        = $json->{supplemental}{weekData}{firstDay};
}

sub _build_en_name ($self) {
    return join q{ }, grep {defined} $self->_en_language,
        $self->_en_territory, $self->_en_script, $self->_en_variant;
}

sub _build_en_language ($self) {
    return unless $self->language_code;
    return $self->_en_languages_data->{ $self->language_code };
}

sub _build_en_territory ($self) {
    return unless $self->territory_code;
    return $self->_en_territories_data->{ $self->territory_code };
}

sub _build_en_script ($self) {
    return unless $self->script_code;
    return $self->_en_scripts_data->{ $self->script_code };
}

sub _build_en_variant ($self) {
    return unless $self->variant_code;
    return $self->_en_variants_data->{ $self->variant_code };
}

sub _en_languages_data ($self) {
    state $en_languages_data;
    return $en_languages_data //= $self->_populate_en_lookup('languages');
}

sub _en_territories_data ($self) {
    state $en_territories_data;
    return $en_territories_data //= $self->_populate_en_lookup('territories');
}

sub _en_scripts_data ($self) {
    state $en_scripts_data;
    return $en_scripts_data //= $self->_populate_en_lookup('scripts');
}

sub _en_variants_data ($self) {
    state $en_variants_data;
    return $en_variants_data //= $self->_populate_en_lookup('variants');
}

sub _populate_en_lookup ( $self, $type ) {
    my $json = $self->_json_from(
        $self->_source_data_root->file(
            qw( cldr-localenames-full main en ), $type . '.json'
        )
    );
    return $json->{main}{en}{localeDisplayNames}{$type};
}

sub _build_native_name ($self) {
    return join q{ }, grep {defined} $self->_native_language,
        $self->_native_territory, $self->_native_script,
        $self->_native_variant;
}

sub _build_native_language ($self) {
    return unless $self->language_code;
    return $self->_native_lookup('languages')->{ $self->language_code };
}

sub _build_native_territory ($self) {
    return unless $self->territory_code;
    return $self->_native_lookup('territories')->{ $self->territory_code };
}

sub _build_native_script ($self) {
    return unless $self->script_code;
    return $self->_native_lookup('scripts')->{ $self->script_code };
}

sub _build_native_variant ($self) {
    return unless $self->variant_code;
    return $self->_native_lookup('variants')->{ $self->variant_code };
}

sub _native_lookup ( $self, $type ) {
    my $file;
    my $locale = $self;
    while ($locale) {
        $file = $self->_source_data_root->file(
            qw( cldr-localenames-full main  ),
            $locale->code, $type . '.json'
        );

        last if -f $file;
        $locale = $locale->_parent_locale;
    }
    return {} unless -f $file;

    my $json = $self->_json_from($file);
    return $json->{main}{ $locale->code }{localeDisplayNames}{$type};
}

sub _json_from ( $self, $file ) {
    return decode_json( $file->slurp( iomode => '<:raw' ) );
}

__PACKAGE__->meta->make_immutable;

1;