File Coverage

blib/lib/Locale/Maketext/Lexicon/Msgcat.pm

Criterion	Covered	Total	%
statement	42	43	97.6
branch	13	16	81.2
condition	2	3	66.6
subroutine	6	6	100.0
pod	0	2	0.0
total	63	70	90.0

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

# ABSTRACT: Msgcat catalog parser Maketext


sub parse {
    my $set = 0;
    my $msg = undef;
    my ( $qr, $qq, $qc ) = ( qr//, '', '' );
    my @out;

    # Set up the msgcat handler
    {
        no strict 'refs';
        no warnings 'once';
        *{Locale::Maketext::msgcat} = \&_msgcat;
    }

    # Parse *.m files; Locale::Msgcat objects and *.cat are not yet supported.
    foreach (@_) {
        s/[\015\012]*\z//;    # fix CRLF issues

        /^\$set (\d+)/
            ? do {            # set_id
            $set = int($1);
            push @out, $1, "[msgcat,$1,_1]";
            }
            :

            /^\$quote (.)/
            ? do {            # quote character
            $qc = $1;
            $qq = quotemeta($1);
            $qr = qr/$qq?/;
            }
            :

            /^(\d+) ($qr)(.*?)\2(\\?)$/
            ? do {            # msg_id and msg_str
            local $^W;
            push @out, "$set," . int($1);
            if ($4) {
                $msg = $3;
            }
            else {
                push @out, unescape( $qq, $qc, $3 );
                undef $msg;
            }
            }
            :

            ( defined $msg and /^($qr)(.*?)\1(\\?)$/ )
            ? do {    # continued string
            local $^W;
            if ($3) {
                $msg .= $2;
            }
            else {
                push @out, unescape( $qq, $qc, $msg . $2 );
                undef $msg;
            }
            }
            : ();
    }

    push @out, '' if defined $msg;

    return {@out};
}

sub _msgcat {
    my ( $self, $set_id, $msg_id, @args ) = @_;
    return $self->maketext( int($set_id) . ',' . int($msg_id), @args );
}

sub unescape {
    my ( $qq, $qc, $str ) = @_;
    $str =~ s/(\\([ntvbrf\\$qq]))/($2 eq $qc) ? $qc : eval qq("$1")/e;
    $str =~ s/([\~\[\]])/~$1/g;
    return $str;
}

1;

__END__