File Coverage

blib/lib/Locale/Maketext/Lexicon.pm

Criterion	Covered	Total	%
statement	185	229	80.7
branch	58	112	51.7
condition	12	30	40.0
subroutine	31	38	81.5
pod	0	10	0.0
total	286	419	68.2

package Locale::Maketext::Lexicon;
$Locale::Maketext::Lexicon::VERSION = '1.00';
use 5.004;
use strict;

# ABSTRACT: Use other catalog formats in Maketext


our %Opts;
sub option { shift if ref( $_[0] ); $Opts{ lc $_[0] } }
sub set_option { shift if ref( $_[0] ); $Opts{ lc $_[0] } = $_[1] }

sub encoding {
    my $encoding = option( @_, 'encoding' ) or return;
    return $encoding unless lc($encoding) eq 'locale';

    local $^W;    # no warnings 'uninitialized', really.
    my ( $country_language, $locale_encoding );

    local $@;
    eval {
        require I18N::Langinfo;
        $locale_encoding
            = I18N::Langinfo::langinfo( I18N::Langinfo::CODESET() );
    } or eval {
        require Win32::Console;
        $locale_encoding = 'cp' . Win32::Console::OutputCP();
    };
    if ( !$locale_encoding ) {
        foreach my $key (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
            $ENV{$key} =~ /^([^.]+)\.([^.:]+)/ or next;
            ( $country_language, $locale_encoding ) = ( $1, $2 );
            last;
        }
    }
    if (   defined $locale_encoding
        && lc($locale_encoding) eq 'euc'
        && defined $country_language )
    {
        if ( $country_language =~ /^ja_JP|japan(?:ese)?$/i ) {
            $locale_encoding = 'euc-jp';
        }
        elsif ( $country_language =~ /^ko_KR|korean?$/i ) {
            $locale_encoding = 'euc-kr';
        }
        elsif ( $country_language =~ /^zh_CN|chin(?:a|ese)?$/i ) {
            $locale_encoding = 'euc-cn';
        }
        elsif ( $country_language =~ /^zh_TW|taiwan(?:ese)?$/i ) {
            $locale_encoding = 'euc-tw';
        }
    }

    return $locale_encoding;
}

sub import {
    my $class = shift;
    return unless @_;

    my %entries;
    if ( UNIVERSAL::isa( $_[0], 'HASH' ) ) {

        # a hashref with $lang as keys, [$format, $src ...] as values
        %entries = %{ $_[0] };
    }
    elsif ( @_ % 2 == 0 ) {
        %entries = ( '' => [ splice @_, 0, 2 ], @_ );
    }

    # expand the wildcard entry
    if ( my $wild_entry = delete $entries{'*'} ) {
        while ( my ( $format, $src ) = splice( @$wild_entry, 0, 2 ) ) {
            next if ref($src); # XXX: implement globbing for the 'Tie' backend

            my $pattern = quotemeta($src);
            $pattern =~ s/\\\*(?=[^*]+$)/\([-\\w]+\)/g or next;
            $pattern =~ s/\\\*/.*?/g;
            $pattern =~ s/\\\?/./g;
            $pattern =~ s/\\\[/[/g;
            $pattern =~ s/\\\]/]/g;
            $pattern =~ s[\\\{(.*?)\\\\}][
                '(?:'.join('|', split(/,/, $1)).')'
            ]eg;

            require File::Glob;
            foreach my $file ( File::Glob::bsd_glob($src) ) {
                $file =~ /$pattern/ or next;
                push @{ $entries{$1} }, ( $format => $file ) if $1;
            }
            delete $entries{$1}
                unless !defined($1)
                or exists $entries{$1} and @{ $entries{$1} };
        }
    }

    %Opts = ();
    foreach my $key ( grep /^_/, keys %entries ) {
        set_option( lc( substr( $key, 1 ) ) => delete( $entries{$key} ) );
    }
    my $OptsRef = {%Opts};

    while ( my ( $lang, $entry ) = each %entries ) {
        my $export = caller;

        if ( length $lang ) {

            # normalize language tag to Maketext's subclass convention
            $lang = lc($lang);
            $lang =~ s/-/_/g;
            $export .= "::$lang";
        }

        my @pairs = @{ $entry || [] } or die "no format specified";

        while ( my ( $format, $src ) = splice( @pairs, 0, 2 ) ) {
            if ( defined($src) and !ref($src) and $src =~ /\*/ ) {
                unshift( @pairs, $format => $_ )
                    for File::Glob::bsd_glob($src);
                next;
            }

            my @content
                = eval { $class->lexicon_get( $src, scalar caller(1), $lang ); };
            next if $@ and $@ =~ /^next\b/;
            die $@ if $@;

            no strict 'refs';
            eval "use $class\::$format; 1" or die $@;

            if ( %{"$export\::Lexicon"} ) {
                my $lexicon = \%{"$export\::Lexicon"};
                if ( my $obj = tied %$lexicon ) {

                    # if it's our tied hash then force loading
                    # otherwise late load will rewrite
                    $obj->_force if $obj->isa(__PACKAGE__);
                }

                # clear the memoized cache for old entries:
                Locale::Maketext->clear_isa_scan;

                my $new = "$class\::$format"->parse(@content);

                # avoid hash rebuild, on big sets
                @{$lexicon}{ keys %$new } = values %$new;
            }
            else {
                local $^W if $] >= 5.009;    # no warnings 'once', really.
                tie %{"$export\::Lexicon"}, __PACKAGE__,
                    {
                    Opts    => $OptsRef,
                    Export  => "$export\::Lexicon",
                    Class   => "$class\::$format",
                    Content => \@content,
                    };
                tied( %{"$export\::Lexicon"} )->_force
                    if $OptsRef->{'preload'};
            }

            length $lang or next;

            # Avoid re-entry
            my $caller = caller();
            next if $export->isa($caller);

            push( @{"$export\::ISA"}, scalar caller );

            if ( my $style = option('style') ) {
                my $cref
                    = $class->can( lc("_style_$style") )
                    ->( $class, $export->can('maketext') )
                    or die "Unknown style: $style";

                # Avoid redefinition warnings
                local $SIG{__WARN__} = sub {1};
                *{"$export\::maketext"} = $cref;
            }
        }
    }
}

sub _style_gettext {
    my ( $self, $orig ) = @_;

    require Locale::Maketext::Lexicon::Gettext;

    sub {
        my $lh  = shift;
        my $str = shift;
        return $orig->(
            $lh,
            Locale::Maketext::Lexicon::Gettext::_gettext_to_maketext($str), @_
        );
        }
}

sub TIEHASH {
    my ( $class, $args ) = @_;
    return bless( $args, $class );

}

{
    no strict 'refs';

    sub _force {
        my $args = shift;
        unless ( $args->{'Done'} ) {
            $args->{'Done'} = 1;
            local *Opts = $args->{Opts};
            *{ $args->{Export} }
                = $args->{Class}->parse( @{ $args->{Content} } );
            $args->{'Export'}{'_AUTO'} = 1
                if option('auto');
        }
        return $args->{'Export'};
    }
    sub FETCH   { _force( $_[0] )->{ $_[1] } }
    sub EXISTS  { _force( $_[0] )->{ $_[1] } }
    sub DELETE  { delete _force( $_[0] )->{ $_[1] } }
    sub SCALAR  { scalar %{ _force( $_[0] ) } }
    sub STORE   { _force( $_[0] )->{ $_[1] } = $_[2] }
    sub CLEAR   { %{ _force( $_[0] )->{ $_[1] } } = () }
    sub NEXTKEY { each %{ _force( $_[0] ) } }

    sub FIRSTKEY {
        my $hash = _force( $_[0] );
        my $a    = scalar keys %$hash;
        each %$hash;
    }
}

sub lexicon_get {
    my ( $class, $src, $caller, $lang ) = @_;
    return unless defined $src;

    foreach my $type ( qw(ARRAY HASH SCALAR GLOB), ref($src) ) {
        next unless UNIVERSAL::isa( $src, $type );

        my $method = 'lexicon_get_' . lc($type);
        die "cannot handle source $type for $src: no $method defined"
            unless $class->can($method);

        return $class->$method( $src, $caller, $lang );
    }

    # default handler
    return $class->lexicon_get_( $src, $caller, $lang );
}

# for scalarrefs and arrayrefs we just dereference the $src
sub lexicon_get_scalar { ${ $_[1] } }
sub lexicon_get_array  { @{ $_[1] } }

sub lexicon_get_hash {
    my ( $class, $src, $caller, $lang ) = @_;
    return map { $_ => $src->{$_} } sort keys %$src;
}

sub lexicon_get_glob {
    my ( $class, $src, $caller, $lang ) = @_;

    no strict 'refs';
    local $^W if $] >= 5.009;    # no warnings 'once', really.

    # be extra magical and check for DATA section
    if ( eof($src) and $src eq \*{"$caller\::DATA"}
        or $src eq \*{"main\::DATA"} )
    {

        # okay, the *DATA isn't initiated yet. let's read.
        #
        require FileHandle;
        my $fh = FileHandle->new;
        my $package = ( ( $src eq \*{"main\::DATA"} ) ? 'main' : $caller );

        if ( $package eq 'main' and -e $0 ) {
            $fh->open($0) or die "Can't open $0: $!";
        }
        else {
            my $level = 1;
            while ( my ( $pkg, $filename ) = caller( $level++ ) ) {
                next unless $pkg eq $package;
                next unless -e $filename;
                next;

                $fh->open($filename) or die "Can't open $filename: $!";
                last;
            }
        }

        while (<$fh>) {

            # okay, this isn't foolproof, but good enough
            last if /^__DATA__$/;
        }

        return <$fh>;
    }

    # fh containing the lines
    my $pos   = tell($src);
    my @lines = <$src>;
    seek( $src, $pos, 0 );
    return @lines;
}

# assume filename - search path, open and return its contents
sub lexicon_get_ {
    my ( $class, $src, $caller, $lang ) = @_;
    $src = $class->lexicon_find( $src, $caller, $lang );
    defined $src or die 'next';

    require FileHandle;
    my $fh = FileHandle->new;
    $fh->open($src) or die "Cannot read $src (called by $caller): $!";
    binmode($fh);
    return <$fh>;
}

sub lexicon_find {
    my ( $class, $src, $caller, $lang ) = @_;
    return $src if -e $src;

    require File::Spec;

    my @path = split '::', $caller;
    push @path, $lang if length $lang;

    while (@path) {
        foreach (@INC) {
            my $file = File::Spec->catfile( $_, @path, $src );
            return $file if -e $file;
        }
        pop @path;
    }

    return undef;
}

1;

__END__