File Coverage

blib/lib/Locale/Maketext/Extract.pm

Criterion	Covered	Total	%
statement	204	220	92.7
branch	57	86	66.2
condition	20	35	57.1
subroutine	37	42	88.1
pod	5	35	14.2
total	323	418	77.2

package Locale::Maketext::Extract;
$Locale::Maketext::Extract::VERSION = '1.00';
use strict;
use Locale::Maketext::Lexicon();

# ABSTRACT: Extract translatable strings from source


our %Known_Plugins = (
    perl    => 'Locale::Maketext::Extract::Plugin::Perl',
    yaml    => 'Locale::Maketext::Extract::Plugin::YAML',
    tt2     => 'Locale::Maketext::Extract::Plugin::TT2',
    text    => 'Locale::Maketext::Extract::Plugin::TextTemplate',
    mason   => 'Locale::Maketext::Extract::Plugin::Mason',
    generic => 'Locale::Maketext::Extract::Plugin::Generic',
    formfu  => 'Locale::Maketext::Extract::Plugin::FormFu',
    haml    => 'Locale::Maketext::Extract::Plugin::Haml',
);

sub new {
    my $class   = shift;
    my %params  = @_;
    my $plugins = delete $params{plugins}
        || { map { $_ => undef } keys %Known_Plugins };

    Locale::Maketext::Lexicon::set_option( 'keep_fuzzy' => 1 );
    my $self = bless(
        {   header           => '',
            entries          => {},
            compiled_entries => {},
            lexicon          => {},
            warnings         => 0,
            verbose          => 0,
            wrap             => 0,
            %params,
        },
        $class
    );
    $self->{verbose} ||= 0;
    die "No plugins defined in new()"
        unless $plugins;
    $self->plugins($plugins);
    return $self;
}


sub header { $_[0]{header} || _default_header() }
sub set_header { $_[0]{header} = $_[1] }

sub lexicon { $_[0]{lexicon} }
sub set_lexicon { $_[0]{lexicon} = $_[1] || {}; delete $_[0]{lexicon}{''}; }

sub msgstr { $_[0]{lexicon}{ $_[1] } }
sub set_msgstr { $_[0]{lexicon}{ $_[1] } = $_[2] }

sub entries { $_[0]{entries} }
sub set_entries { $_[0]{entries} = $_[1] || {} }

sub compiled_entries { $_[0]{compiled_entries} }
sub set_compiled_entries { $_[0]{compiled_entries} = $_[1] || {} }

sub entry { @{ $_[0]->entries->{ $_[1] } || [] } }
sub add_entry { push @{ $_[0]->entries->{ $_[1] } }, $_[2] }
sub del_entry { delete $_[0]->entries->{ $_[1] } }

sub compiled_entry { @{ $_[0]->compiled_entries->{ $_[1] } || [] } }
sub add_compiled_entry { push @{ $_[0]->compiled_entries->{ $_[1] } }, $_[2] }
sub del_compiled_entry { delete $_[0]->compiled_entries->{ $_[1] } }

sub plugins {
    my $self = shift;
    if (@_) {
        my @plugins;
        my %params = %{ shift @_ };

        foreach my $name ( keys %params ) {
            my $plugin_class = $Known_Plugins{$name} || $name;
            my $filename = $plugin_class . '.pm';
            $filename =~ s/::/\//g;
            local $@;
            eval {
                require $filename && 1;
                1;
            } or do {
                my $error = $@ || 'Unknown';
                print STDERR "Error loading $plugin_class: $error\n"
                    if $self->{warnings};
                next;
            };

            my $plugin
                = $params{$name}
                ? $plugin_class->new( $params{$name} )
                : $plugin_class->new;
            push @plugins, $plugin;
        }
        $self->{plugins} = \@plugins;
    }
    return $self->{plugins} || [];
}

sub clear {
    $_[0]->set_header;
    $_[0]->set_lexicon;
    $_[0]->set_comments;
    $_[0]->set_fuzzy;
    $_[0]->set_entries;
    $_[0]->set_compiled_entries;
}


sub read_po {
    my ( $self, $file ) = @_;
    print STDERR "READING PO FILE : $file\n"
        if $self->{verbose};

    my $header = '';

    local ( *LEXICON, $_ );
    open LEXICON, $file or die $!;
    while () {
        ( 1 .. /^$/ ) or last;
        $header .= $_;
    }
    1 while chomp $header;

    $self->set_header("$header\n");

    require Locale::Maketext::Lexicon::Gettext;
    my $lexicon  = {};
    my $comments = {};
    my $fuzzy    = {};
    $self->set_compiled_entries( {} );

    if ( defined($_) ) {
        ( $lexicon, $comments, $fuzzy )
            = Locale::Maketext::Lexicon::Gettext->parse( $_,  );
    }

    # Internally the lexicon is in gettext format already.
    $self->set_lexicon( { map _maketext_to_gettext($_), %$lexicon } );
    $self->set_comments($comments);
    $self->set_fuzzy($fuzzy);

    close LEXICON;
}

sub msg_comment {
    my $self    = shift;
    my $msgid   = shift;
    my $comment = $self->{comments}->{$msgid};
    return $comment;
}

sub msg_fuzzy {
    return $_[0]->{fuzzy}{ $_[1] } ? ', fuzzy' : '';
}

sub set_comments {
    $_[0]->{comments} = $_[1];
}

sub set_fuzzy {
    $_[0]->{fuzzy} = $_[1];
}


sub write_po {
    my ( $self, $file, $add_format_marker ) = @_;
    print STDERR "WRITING PO FILE : $file\n"
        if $self->{verbose};

    local *LEXICON;
    open LEXICON, ">$file" or die "Can't write to $file$!\n";

    print LEXICON $self->header;

    foreach my $msgid ( $self->msgids ) {
        $self->normalize_space($msgid);
        print LEXICON "\n";
        if ( my $comment = $self->msg_comment($msgid) ) {
            my @lines = split "\n", $comment;
            print LEXICON map {"# $_\n"} @lines;
        }
        print LEXICON $self->msg_variables($msgid);
        print LEXICON $self->msg_positions($msgid);
        my $flags = $self->msg_fuzzy($msgid);
        $flags .= $self->msg_format($msgid) if $add_format_marker;
        print LEXICON "#$flags\n" if $flags;
        print LEXICON $self->msg_out($msgid);
    }

    print STDERR "DONE\n\n"
        if $self->{verbose};

}


sub extract {
    my $self    = shift;
    my $file    = shift;
    my $content = shift;

    local $@;

    my ( @messages, $total, $error_found );
    $total = 0;
    my $verbose = $self->{verbose};

    my @plugins = $self->_plugins_specifically_for_file($file);

    # If there's no plugin which can handle this file
    # specifically, fall back trying with all known plugins.
    @plugins = @{ $self->plugins } if not @plugins;

    foreach my $plugin (@plugins) {
        pos($content) = 0;
        my $success = eval { $plugin->extract($content); 1; };
        if ($success) {
            my $entries = $plugin->entries;
            if ( $verbose > 1 && @$entries ) {
                push @messages,
                      "     - "
                    . ref($plugin)
                    . ' - Strings extracted : '
                    . ( scalar @$entries );
            }
            for my $entry (@$entries) {
                my ( $string, $line, $vars ) = @$entry;
                $self->add_entry( $string => [ $file, $line, $vars ] );
                if ( $verbose > 2 ) {
                    $vars = '' if !defined $vars;

                    # pad string
                    $string =~ s/\n/\n               /g;
                    push @messages,
                        sprintf(
                        qq[       - %-8s "%s" (%s)],
                        $line . ':',
                        $string, $vars
                        ),
                        ;
                }
            }
            $total += @$entries;
        }
        else {
            $error_found++;
            if ( $self->{warnings} ) {
                push @messages,
                      "Error parsing '$file' with plugin "
                    . ( ref $plugin )
                    . ": \n $@\n";
            }
        }
        $plugin->clear;
    }

    print STDERR " * $file\n   - Total strings extracted : $total"
        . ( $error_found ? ' [ERROR ] ' : '' ) . "\n"
        if $verbose
        && ( $total || $error_found );
    print STDERR join( "\n", @messages ) . "\n"
        if @messages;

}

sub extract_file {
    my ( $self, $file ) = @_;

    local ( *FH );
    open FH, $file or die "Error reading from file '$file' : $!";
    my $content = do {
        local $/;
        scalar ;
    };

    $self->extract( $file => $content );
    close FH;
}


sub compile {
    my ( $self, $entries_are_in_gettext_style ) = @_;
    my $entries = $self->entries;
    my $lexicon = $self->lexicon;
    my $comp    = $self->compiled_entries;

    while ( my ( $k, $v ) = each %$entries ) {
        my $compiled_key = (
            ($entries_are_in_gettext_style)
            ? $k
            : _maketext_to_gettext($k)
        );
        $comp->{$compiled_key}    = $v;
        $lexicon->{$compiled_key} = ''
            unless exists $lexicon->{$compiled_key};
    }

    return %$lexicon;
}


my %Escapes = map { ( "\\$_" => eval("qq(\\$_)") ) } qw(t r f b a e);

sub normalize_space {
    my ( $self, $msgid ) = @_;
    my $nospace = $msgid;
    $nospace =~ s/ +$//;

    return
        unless ( !$self->has_msgid($msgid) and $self->has_msgid($nospace) );

    $self->set_msgstr( $msgid => $self->msgstr($nospace)
            . ( ' ' x ( length($msgid) - length($nospace) ) ) );
}


sub msgids { sort keys %{ $_[0]{lexicon} } }

sub has_msgid {
    my $msg_str = $_[0]->msgstr( $_[1] );
    return defined $msg_str ? length $msg_str : 0;
}

sub msg_positions {
    my ( $self, $msgid ) = @_;
    my %files = ( map { ( " $_->[0]:$_->[1]" => 1 ) }
            $self->compiled_entry($msgid) );
    return $self->{wrap}
        ? join( "\n", ( map { '#:' . $_ } sort( keys %files ) ), '' )
        : join( '', '#:', sort( keys %files ), "\n" );
}

sub msg_variables {
    my ( $self, $msgid ) = @_;
    my $out = '';

    my %seen;
    foreach my $entry ( grep { $_->[2] } $self->compiled_entry($msgid) ) {
        my ( $file, $line, $var ) = @$entry;
        $var =~ s/^\s*,\s*//;
        $var =~ s/\s*$//;
        $out .= "#. ($var)\n" unless !length($var) or $seen{$var}++;
    }

    return $out;
}

sub msg_format {
    my ( $self, $msgid ) = @_;
    return ", perl-maketext-format"
        if $msgid =~ /%(?:[1-9]\d*|\w+\([^\)]*\))/;
    return '';
}

sub msg_out {
    my ( $self, $msgid ) = @_;
    my $msgstr = $self->msgstr($msgid);

    return "msgid " . _format($msgid) . "msgstr " . _format($msgstr);
}


sub _default_header {
    return << '.';
# SOME DESCRIPTIVE TITLE.
# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER
# This file is distributed under the same license as the PACKAGE package.
# FIRST AUTHOR , YEAR.
#
#, fuzzy
msgid ""
msgstr ""
"Project-Id-Version: PACKAGE VERSION\n"
"POT-Creation-Date: YEAR-MO-DA HO:MI+ZONE\n"
"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
"Last-Translator: FULL NAME \n"
"Language-Team: LANGUAGE \n"
"MIME-Version: 1.0\n"
"Content-Type: text/plain; charset=CHARSET\n"
"Content-Transfer-Encoding: 8bit\n"
.
}

sub _maketext_to_gettext {
    my $text = shift;
    return '' unless defined $text;

    $text =~ s{((?
              {$1%$2}g;
    $text =~ s{((?
              {"$1%$2(" . _escape($3) . ')'}eg;

    $text =~ s/~([\~\[\]])/$1/g;
    return $text;
}

sub _escape {
    my $text = shift;
    $text =~ s/\b_([1-9]\d*)/%$1/g;
    return $text;
}

sub _format {
    my $str = shift;

    $str =~ s/(?=[\\"])/\\/g;

    while ( my ( $char, $esc ) = each %Escapes ) {
        $str =~ s/$esc/$char/g;
    }

    return "\"$str\"\n" unless $str =~ /\n/;
    my $multi_line = ( $str =~ /\n(?!\z)/ );
    $str =~ s/\n/\\n"\n"/g;
    if ( $str =~ /\n"$/ ) {
        chop $str;
    }
    else {
        $str .= "\"\n";
    }
    return $multi_line ? qq(""\n"$str) : qq("$str);
}

sub _plugins_specifically_for_file {
    my ( $self, $file ) = @_;

    return () if not $file;

    my @plugins = grep {
        my $plugin     = $_;
        my @file_types = $plugin->file_types;
        my $is_generic
            = ( scalar @file_types == 1 and $file_types[0] eq '*' );
        ( not $is_generic and $plugin->known_file_type($file) );
    } @{ $self->plugins };

    return @plugins;
}

1;

__END__