File Coverage

blib/lib/Astro/App/Satpass2/Locale.pm

Criterion	Covered	Total	%
statement	75	85	88.2
branch	32	42	76.1
condition	9	14	64.2
subroutine	12	12	100.0
pod			n/a
total	128	153	83.6

package Astro::App::Satpass2::Locale;

use 5.008;

use strict;
use warnings;

use Astro::App::Satpass2::Utils qw{
    expand_tilde instance
    ARRAY_REF CODE_REF HASH_REF
    @CARP_NOT
};
use Exporter qw{ import };
use I18N::LangTags ();
use I18N::LangTags::Detect ();

our $VERSION = '0.057_01';

our @EXPORT_OK = qw{ __localize __message __preferred };

my @lang;
my $locale;

{

    my %deref = (
	ARRAY_REF()	=> sub {
	    my ( $data, $inx ) = @_;
	    defined $inx
		and exists $data->[$inx]
		and return $data->[$inx];
	    return;
	},
	CODE_REF()	=> sub {
	    my ( $code, $key, $arg ) = @_;
	    my $rslt = $code->( $key, $arg );
	    return $rslt;
	},
	HASH_REF()	=> sub {
	    my ( $data, $key ) = @_;
	    defined $key
		and exists $data->{$key}
		and return $data->{$key};
	    return;
	},
	''		=> sub {
	    return;
	},
    );

    sub __localize {

# Keys used:
# {argument} = argument for code reference
# {default} = the default value
# {text} = the text to localize, as scalar or array ref. REQUIRED.
# {locale} = fallback locales, as hash ref or ref to array of hash refs.

	my %arg = @_;
	unless ( $arg{text} ) {
	    require Carp;
	    Carp::confess( q );
	}
	ref $arg{text}
	    or $arg{text} = [ $arg{text} ];
	$arg{locale} ||= [];
	HASH_REF eq ref $arg{locale}
	    and $arg{locale} = [ $arg{locale} ];
	$locale ||= _load();

	my @rslt;
	foreach my $lc ( @lang ) {
	    SOURCE_LOOP:
	    foreach my $source ( @{ $locale }, @{ $arg{locale} } ) {
		unless ( HASH_REF eq ref $source ) {
		    require Carp;
		    Carp::confess( "\$source is '$source'" );
		}
		my $data = $source->{$lc}
		    or next;
		foreach my $key ( @{ $arg{text} } ) {
		    my $code = $deref{ ref $data }
			or do {
			require Carp;
			Carp::confess(
			    'Programming error - Locale systen can ',
			    'not handle ', ref $data, ' as a container'
			);
		    };
		    ( $data ) = $code->( $data, $key, $arg{argument} )
			or next SOURCE_LOOP;
		}
		wantarray
		    or return $data;
		push @rslt, $data;
	    }
	}
	wantarray
	    or return $arg{default};
	return ( @rslt, $arg{default} );

    }

}

=begin comment

{
    my %stringify_ref = map { $_ => 1 } qw{ Template::Exception };

    sub __message {
	# My OpenBSD 5.5 system seems not to stringify the arguments in
	# the normal course of events, though my Mac OS 10.9 system
	# does. The OpenBSD system gives instead a stringified hash
	# reference (i.e. "HASH{0x....}").
	my @raw_arg = @_;
	my ( $msg, @arg ) =
	    map { $stringify_ref{ ref $_ } ? '' . $_ : $_ } @raw_arg;
	my $lcl = __localize(
	    text	=> [ '+message', $msg ],
	    default	=> $msg,
	);

	CODE_REF eq ref $lcl
	    and return $lcl->( $msg, @arg );

	$lcl =~ m/ \[ % /smx
	    or return join ' ', $lcl, @arg;

	grep { instance( $_, 'Template::Exception' ) } @raw_arg
	    and return join ' ', $lcl, @arg;

	my $tt = Template->new();

	my $output;
	$tt->process( \$lcl, {
		arg	=> \@arg,
	    }, \$output );

	return $output;
    }
}

=end comment

=cut

sub __message {
    my ( $msg, @arg ) = @_;

    instance( $msg, 'Template::Exception' )
	and return _message_template_exception( $msg, @arg );

    my $lcl = __localize(
	text	=> [ '+message', $msg ],
	default	=> $msg,
    );

    CODE_REF eq ref $lcl
	and return $lcl->( $msg, @arg );

    $lcl =~ m/ \[ % /smx
	or return join ' ', $lcl, @arg;

    my $tt = Template->new();

    my $output;
    $tt->process( \$lcl, {
	    arg	=> \@arg,
	}, \$output );

    return $output;
}

sub _message_template_exception {
    my ( $ex, @arg ) = @_;
    local $_ = $ex->info();
    # NOTE we're assuming that if there is a return we caught a
    # re-thrown exception that had already been munged.
    m/ \n \z /smx
	and return $ex;
    $_ = join ' ', $_, @arg;
    m/ [.?|] \z /smx
	or $_ .= '.';
    $_ .= "\n";
    my $class = ref $ex;
    return $class->new( $ex->type(), $_ );
}

sub __preferred {
    $locale ||= _load();
    return wantarray ? @lang : $lang[0];
}

sub _load {

    # Pick up the languages from the environment
    @lang = I18N::LangTags::implicate_supers(
	I18N::LangTags::Detect::detect() );

    # Normalize the language names.
    foreach ( @lang ) {
	s/ ( [^_-]+ ) [_-] (.* ) /\L$1_\U$2/smx
	    or $_ = lc $_;
	'c' eq $_
	    and $_ = uc $_;
    }

    # Append the default locale name.
    grep { 'C' eq $_ } @lang
	or push @lang, 'C';

    # Accumulator for locale data.
    my @locales;

    # Put all the user's data in a hash.
    push @locales, {};
    foreach my $lc ( @lang ) {
	eval {	## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
	    defined( my $path = expand_tilde( "~~/locale/$lc.pm" ) )
		or return;
	    my $data;
	    $data = do $path
		and HASH_REF eq ref $data
		and $locales[-1]{$lc} = $data;
	};
    }

    # Put the system-wide data in a hash.
    push @locales, {};
    foreach my $lc ( @lang ) {
	my $mod_name = __PACKAGE__ . "::$lc";
	my $data;
	$data = eval "require $mod_name"
	    and HASH_REF eq ref $data
	    and $locales[-1]{$lc} = $data;
    }

    # Return a reference to the names of locales.
    return \@locales;
}

1;

__END__