File Coverage

lib/i18n.pm

Criterion	Covered	Total	%
statement	115	118	97.4
branch	27	34	79.4
condition	4	6	66.6
subroutine	22	23	95.6
pod			n/a
total	168	181	92.8

package i18n;
$i18n::VERSION = '0.13';

use 5.006;
use strict;
use constant DATA    => 0;
use constant LINE    => 1;
use constant PACKAGE => 2;
use constant NEGATED => 3;
use warnings::register;
use overload (
    '~'      => \&_negate,
    '.'      => \&_concat,
    '""'     => \&_stringify,
    fallback => 1,
);

sub import {
    my $class  = shift;
    my $caller = caller;

    local $@;
    eval { require Locale::Maketext::Simple; 1 } or return;

    overload::constant(
        q => sub {
            shift;
            pop;
            bless(
                [
                    \@_,                 # DATA
                    ( caller(1) )[2],    # LINE
                    $caller,             # PACKAGE
                ],
                $class
            );
        },
    );

    {
        no strict 'refs';
        no warnings 'redefine';

        delete ${"$class\::"}{loc};
        delete ${"$class\::"}{loc_lang};

        unshift @_, 'Path' if @_ % 2;
        Locale::Maketext::Simple->import(@_);

        *{"$caller\::loc"}      = $class->can('loc');
        *{"$caller\::loc_lang"} = $class->can('loc_lang');

        *{"$class\::loc"}      = \&_loc;
        *{"$class\::loc_lang"} = \&_loc_lang;
    }

    @_ = ( warnings => $class );
    goto &warnings::import;
}

sub unimport {
    my $class = shift;
    overload::remove_constant('q');

    @_ = ( warnings => $class );
    goto &warnings::unimport;
}

sub loc      { goto \&_loc }
sub loc_lang { goto \&_loc_lang }

sub _loc {
    my $class = shift;
    return $_[0] unless UNIVERSAL::can( $_[0], '_negate' );
    goto &_do_loc;
}

sub _loc_lang {
    my $class    = shift;
    my $caller   = caller;
    my $loc_lang = $caller->can('loc_lang') or return;
    goto &$loc_lang;
}

sub _negate {
    my $class = ref $_[0];

    return ~_stringify( $_[0] ) unless warnings::enabled($class);

    goto &_do_loc if $_[0][NEGATED];

    bless(
        [
            [ @{ $_[0][DATA] } ],    # DATA
            $_[0][LINE],             # LINE
            $_[0][PACKAGE],          # PACKAGE
            1,                       # NEGATED
        ],
        $class
    );
}

sub _concat {
    my $class = ref $_[0];
    my $pkg   = $_[0][PACKAGE];

    @_ = reverse(@_) if pop;
    return join( '', @_ ) unless warnings::enabled($class);

    my $line = (caller)[2];
    my ( $seen, @data );

    foreach (@_) {
        ( push( @data, bless( \\$_, "$class\::var" ) ), next )
          unless ref($_)
              and UNIVERSAL::isa( $_, $class );
        $seen++;

        ( push( @data, bless( \\$_, "$class\::var" ) ), next )
          unless $_->[LINE] == $line and !$_->[NEGATED];
        $seen++;

        $pkg = $_->[PACKAGE];
        push @data, @{ $_->[DATA] };
    }

    return join( '', @data ) if $seen < 2;

    return bless(
        [
            \@data,    # DATA
            $line,     # LINE
            $pkg,      # PACKAGE
        ],
        $class
    );
}

sub _stringify {
    ( $_[0][NEGATED] )
      ? ~join( '', map { ( ref $_ ) ? "$$$_" : "$_" } @{ $_[0][DATA] } )
      : join( '', map { ( ref $_ ) ? "$$$_" : "$_" } @{ $_[0][DATA] } );
}

sub _do_loc {
    my $class = ref $_[0];
    my $pkg   = $_[0][PACKAGE];

    my $loc = $pkg->can('loc')
      or return ~"$_[0]";

    my @vars;
    my $format = join(
        '',
        map {
            UNIVERSAL::isa( $_, "$class\::var" )
              ? do { push( @vars, $$$_ ); "[_" . @vars . "]" }
              : do { my $str = $_; $str =~ s/(?=[\[\]~])/~/g; $str };
          } @{ $_[0][DATA] }
    );

    # Defeat constant folding
    return bless( [ $loc => $format ], 'i18n::string' ) if !@vars;

    @_ = ( $format, @vars );
    goto &$loc;
}

package
    i18n::string;

use overload (
    '""'     => \&_stringify,
    '0+'     => \&_stringify,
    fallback => 1,
);

sub _stringify {
    $_[0][0]->( $_[0][1] );
}

package
    i18n::var;

use overload (
    '""'     => \&_stringify,
    '0+'     => \&_stringify,
    fallback => 1,
);

sub _stringify { ${ ${ $_[0] } } }

1;

__END__