/usr/share/perl5/Publican/Translate.pm

package Publican::Translate;

use utf8;
use strict;
use warnings;
use 5.008;
use Carp qw(carp croak cluck);
use Publican;
use Publican::Builder;
use Publican::Localise;
use File::Path;
use Term::ANSIColor qw(:constants);
use DateTime;
use Locale::PO 0.24;
use XML::TreeBuilder;
use String::Similarity;
use Encode qw(is_utf8 decode_utf8 encode_utf8);

# What tags do we translate?
my $TRANSTAGS
    = qr/^(?:ackno|bridgehead|caption|conftitle|contrib|entry|firstname|glossentry|indexterm|jobtitle|keyword|label|lastname|lineannotation|lotentry|member|orgdiv|orgname|othername|para|phrase|productname|refclass|refdescriptor|refentrytitle|refmiscinfo|refname|refpurpose|releaseinfo|revremark|screeninfo|secondaryie|seealsoie|seeie|seg|segtitle|simpara|subtitle|surname|td|term|termdef|tertiaryie|textobject|th|title|titleabbrev|screen|programlisting|literallayout|simplelist)$/;

# Blocks that contain translatable tags that need to be kept inline
my $IGNOREBLOCKS
    = qr/^(?:footnote|citerefentry|indexterm|orgname|productname|phrase|textobject)$/;

# Preserve white space in these tags
my $VERBATIM = qr/^(?:screen|programlisting|literallayout|simplelist)$/;

=head1 NAME

Publican::Translate - Module for manipulating POT and PO files.

=head1 SYNOPSIS

	use Publican::Translate;
	my $po = Publican::Translate->new();

	$po->update_pot();
	$po->update_po({ langs => 'fr-FR,de-DE' });
	$po->update_po({ langs => 'all' });
	$po->merge_xml({ lang  => 'fr-FR' });

=head1 DESCRIPTION

Creates, updates and merges POT and PO files for Publican projects.

=head1 INTERFACE 

=cut

=head2  new

Create a new Publican::Translate object.

=cut

sub new {
    my ( $this, $args ) = @_;

    my $showfuzzy = delete( $args->{showfuzzy} );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    my $class = ref($this) || $this;
    my $self = bless {}, $class;

    my $publican = Publican->new();
    $self->{publican}  = $publican;
    $self->{showfuzzy} = $showfuzzy;

    return $self;
}

=head2 trans_drop

Snapshot the source to give translation a stable base.

=cut

sub trans_drop {
    my ($self) = shift();

    my $trans_drop = 'trans_drop';

    mkdir $trans_drop if ( !-d $trans_drop );

    my $source_dir = $self->{publican}->param('xml_lang');

    my @files = dir_list( $source_dir, '*' );
    foreach my $file ( sort(@files) ) {
        logger( "\t" . maketext( "Processing file [_1]", $file ) . "\n" );
        my $new_file = $file;
        $new_file =~ s/^$source_dir/$trans_drop/;
        $new_file =~ m|^(.*)/[^/]+$|;
        my $path = $1;
        mkpath($path) if ( !-d $path );
        fcopy( $file, $new_file );
    }

    return;
}

=head2 update_pot

Update the pot files

=cut

sub update_pot {
    my ($self) = shift();

    mkdir 'pot' if ( !-d 'pot' );

    my $source_dir = $self->{publican}->param('xml_lang');
    $source_dir = 'trans_drop' if ( -d 'trans_drop' );
    my $extras = $self->{publican}->param('extras_dir');

    my @xml_files = dir_list( $source_dir, '*.xml' );
    foreach my $xml_file ( sort(@xml_files) ) {
        next if ( $xml_file =~ m|$source_dir/$extras/| );
        next if ( $xml_file =~ m|$source_dir/Legal_Notice.xml| );
        logger( "\t" . maketext( "Processing file [_1]", $xml_file ) . "\n" );
        my $pot_file = $xml_file;
        $pot_file =~ s/\.xml/\.pot/;
        $pot_file =~ s/^$source_dir/pot/;
        $pot_file =~ m|^(.*)/([^/]+)$|;

        my $path     = $1;
        my $filename = $2;
        mkpath($path) if ( !-d $path );

        my $xml_doc = Publican::Builder::new_tree();
        $xml_doc->store_cdata(1);
        $xml_doc->parse_file($xml_file)
            || croak(
            maketext( "Can't open file [_1]. Error: [_2]", $xml_file, $@ ) );
        $xml_doc->pos( $xml_doc->root() );

        my $msg_list
            = $self->get_msgs( { doc => $xml_doc, filename => $filename } );
##debug_msg( "hash: " . $msg_list->content_list() . "\n\n" );
        $self->print_msgs( { msg_list => $msg_list, pot_file => $pot_file } );

        # Remove pot files with no content
        if ( ( -z $pot_file ) || ( $msg_list->content_list() == 0 ) ) {
            unlink($pot_file);
            logger(
                "\t"
                    . maketext(
                    "deleted empty pot file: [_1]" . "\n", $pot_file
                    )
            );
        }

    }

    return;
}

=head2 po2xml

Merge XML and PO into a translated XML file.

=cut

sub po2xml {
    my ( $self, $args ) = @_;
    my $xml_file = delete( $args->{xml_file} )
        || croak( maketext("xml_file is a mandatory argument") );
    my $po_file = delete( $args->{po_file} )
        || croak( maketext("po_file is a mandatory argument") );
    my $out_file = delete( $args->{out_file} )
        || croak( maketext("out_file is a mandatory argument") );
    my $ent_file = delete( $args->{ent_file} );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    logger(
        "\t"
            . maketext( "Merging [_1] >> [_2] -> [_3]",
            $po_file, $xml_file, $out_file )
            . "\n"
    );

    my $path = undef;
    if ( $out_file =~ m|^(.*/xml)/(.*\/)[^\/]*\.xml| ) {
        $path = $2;
        $path =~ s|[^/]*/|\.\./|g;
    }

    $ent_file = "$path$ent_file" if ($path);

    my $dtdver = $self->{publican}->param('dtdver');

    my $out_doc = Publican::Builder::new_tree();
    $out_doc->parse_file($xml_file)
        || croak(
        maketext( "Can't open file [_1]. Error: [_2]", $xml_file, $@ ) );
    $out_doc->pos( $out_doc->root() );

    my $msgids = Locale::PO->load_file_ashash( $po_file, 'UTF-8' );
    foreach my $key ( keys( %{$msgids} ) ) {
        my $msgref = $msgids->{$key};
        if ( $msgref->obsolete() ) {
            delete( $msgids->{$key} );
        }
        if ( $msgref->fuzzy() && !$self->{showfuzzy} ) {
            $msgref->msgstr("");
        }
    }

    $self->merge_msgs(
        {   out_file => $out_file,
            ent_file => $ent_file,
            out_doc  => $out_doc,
            msgids   => $msgids
        }
    );

    $out_doc->pos( $out_doc->root() );
    foreach my $node ( $out_doc->look_down( 'processed', 1 ) ) {
        $node->attr( 'processed', undef );
    }

    $out_doc->pos( $out_doc->root() );
    my $type = $out_doc->attr("_tag");
    my $text = $out_doc->as_XML();

    $text =~ s/&#38;([a-zA-Z-_0-9]+;)/&$1/g;
    $text =~ s/&#38;/&amp;/g;
    $text =~ s/&#60;/&lt;/g;
    $text =~ s/&#62;/&gt;/g;
    $text =~ s/&#34;/"/g;
    $text =~ s/&#39;/'/g;
    $text =~ s/&quot;/"/g;
    $text =~ s/&apos;/'/g;

    $out_doc->root()->delete();

    my $OUTDOC;

    open( $OUTDOC, ">:encoding(UTF-8)", "$out_file" )
        || croak( maketext( "Could not open [_1] for output!", $out_file ) );
    print $OUTDOC Publican::Builder::dtd_string(
        {   tag      => $type,
            dtdver   => $dtdver,
            cleaning => 1,
            ent_file => $ent_file
        }
    );
    print( $OUTDOC $text );
    close($OUTDOC);

    return;
}

=head2 update_po

Update the PO files using internal process or msgmerge

=cut

sub update_po {
    my ( $self, $args ) = @_;

    my $langs = delete( $args->{langs} )
        || croak( maketext("langs is a mandatory argument") );

    my $msgmerge  = delete( $args->{msgmerge} );
    my $firstname = delete( $args->{firstname} )
        || croak( maketext("firstname is a mandatory argument") );
    my $surname = delete( $args->{surname} )
        || croak( maketext("surname is a mandatory argument") );
    my $email = delete( $args->{email} )
        || croak( maketext("email is a mandatory argument") );
    my $previous = delete( $args->{previous} );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    my $docname    = $self->{publican}->param('docname');
    my $version    = $self->{publican}->param('version');
    my $type       = $self->{publican}->param('type');
    my $xml_lang   = $self->{publican}->param('xml_lang');
    my $source_dir = $xml_lang;
    $source_dir = 'trans_drop' if ( -d 'trans_drop' );

    my @pot_files = dir_list( 'pot', '*.pot' );

    foreach my $lang ( sort( split( /,/, $langs ) ) ) {
        next if ( $lang eq $xml_lang );
        next if ( $lang eq $source_dir );

        unless ( Publican::valid_lang($lang) ) {
            logger(
                maketext( "WARNING: Skipping invalid language: [_1]", $lang )
                    . "\n" );
            next;
        }

        my $lc_lang = $lang;
        $lc_lang =~ s/-/_/g;
        my $locale = Publican::Localise->get_handle($lc_lang)
            || croak(
            maketext(
                "Could not create a Publican::Localise object for language: [_1]",
                $lang
            )
            );
        $locale->encoding("UTF-8");
        $locale->textdomain("publican");
##        $locale->die_for_lookup_failures(1);

        # If asked to update a  non-existing language, create it
        mkdir $lang if ( !-d $lang );

        foreach my $pot_file ( sort(@pot_files) ) {
            my $po_file = $pot_file;

            # remove the t from .pot
            chop($po_file);
            $po_file =~ s/^pot/$lang/;
            logger(
                "\t"
                    . maketext( "Processing file [_1] -> [_2]",
                    $pot_file, $po_file )
                    . "\n"
            );

            # handle nested directories
            $pot_file =~ m|^(.*)/[^/]+$|;
            my $path = $1;
            mkpath($path) if ( !-d $path );
            if ( !-f $po_file || -z $po_file ) {
                fcopy( $pot_file, $po_file );
            }
            else {
                if ( !$msgmerge ) {
                    $self->merge_po(
                        { po_file => $po_file, pot_file => $pot_file } );
                }
                else {
                    my @cmd
                        = qw(msgmerge --no-wrap --quiet --backup=none --update);
                    push( @cmd, '--previous' ) if ($previous);
                    if ( system( @cmd, $po_file, $pot_file ) != 0 ) {
                        croak(
                            maketext(
                                "Fatal Error: msgmerge failed to merge updates. POT File: [_1]. Po File: [_2]",
                                $pot_file,
                                $po_file
                            )
                        );
                    }
                }
            }

            my $xml_file = $pot_file;
            $xml_file =~ s/^pot/$source_dir/;
            $xml_file =~ s/pot$/xml/;
            logger(
                maketext( "WARNING: No source xml file exists for [_1]",
                    $pot_file )
                    . "\n",
                CYAN
            ) unless ( -f $xml_file );
        }

        if ( $self->{publican}->param('type') ne 'brand' ) {
            my ( $edition, $release )
                = $self->{publican}->get_ed_rev( { lang => $source_dir } );

            my @members = (
                decode_utf8(
                    $locale->maketext(
                        "Translation files synchronised with XML sources [_1]-[_2]",
                        $edition,
                        $release
                    )
                )
            );

            my $rev_num = "$edition-$release.1";
            my ( $t_edition, $t_release );
            eval {
                ( $t_edition, $t_release )
                    = $self->{publican}->get_ed_rev( { lang => $lang } );
            };

            if (   ( !$@ )
                && ( $t_edition eq $edition )
                && ( $t_release =~ /^$release\.(\d+)$/ ) )
            {
                $rev_num = "$edition-$release." . ( 1 + $1 );
            }

            $self->{publican}->add_revision(
                {   lang      => $lang,
                    revnumber => "$rev_num",
                    members   => \@members,
                    email     => $email,
                    firstname => $firstname,
                    surname   => $surname
                }
            );
        }

    }

    return;
}

=head2 merge_po

Merge updated POT files in to existing PO files.

=cut

sub merge_po {
    my ( $self, $args ) = @_;

    my $po_file = delete( $args->{po_file} )
        || croak( maketext("po_file is a mandatory argument") );
    my $pot_file = delete( $args->{pot_file} )
        || croak( maketext("pot_file is a mandatory argument") );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    my $pot_arry = Locale::PO->load_file_asarray( $pot_file, 'UTF-8' );
    my $po_hash       = Locale::PO->load_file_ashash( $po_file, 'UTF-8' );
    my @po_keys       = keys( %{$po_hash} );
    my %po_start_keys = map { $_ => 1 } @po_keys;
    my @out_arry      = ();

POT:
    foreach my $pot ( @{$pot_arry} ) {
        my $pot_id  = $pot->msgid();
        my $matched = 0;
        my %highest = ();
        foreach my $po_id (@po_keys) {
            my $match = $self->match_strings( $pot_id, $po_id );
            if ( $match >= 1 ) {
                delete( $po_start_keys{$po_id} );
                $po_hash->{$po_id}->obsolete(0)
                    if ( $po_hash->{$po_id}->obsolete() );
                $po_hash->{$po_id}->fuzzy(0)
                    if ( $po_hash->{$po_id}->fuzzy() );
                push( @out_arry, $po_hash->{$po_id} );
                next POT;
            }
            elsif ( $match >= 0.8 ) {
                $matched = 1;
                delete( $po_start_keys{$po_id} );
                if (   ( !defined( $highest{match} ) )
                    || ( $match > $highest{match} ) )
                {
                    $highest{match}  = $match;
                    $highest{pot_id} = $pot_id;
                    $highest{po_id}  = $po_id;
                }
            }
        }

        if ( !$matched ) {
            push( @out_arry, $pot );
        }
        else {
            my $id = $highest{po_id};
            $po_hash->{$id}->fuzzy(1) unless ( $po_hash->{$id}->fuzzy() );
            $po_hash->{$id}->obsolete(0) if ( $po_hash->{$id}->obsolete() );
            $po_hash->{$id}
                ->msgid( $po_hash->{$id}->dequote( $highest{pot_id} ) );
            push( @out_arry, $po_hash->{$id} );
        }
    }

    foreach my $obsolete ( keys(%po_start_keys) ) {
        $po_hash->{$obsolete}->obsolete(1);
        push( @out_arry, $po_hash->{$obsolete} );
    }

    Locale::PO->save_file_fromarray( $po_file, \@out_arry, 'UTF-8' );

    return;
}

=head2 match_strings

Compare 2 strings and return how closely they match.

Returns a vlaue between 0 and 1, weighted for string length.

=cut

sub match_strings {
    my ( $self, $s1, $s2 ) = @_;

    croak(
        maketext(
            "match_strings requires 2 arguments [_1], [_2].", $s1, $s2
        )
    ) unless ( ($s1) && ($s2) && ( $s1 ne "" ) && ( $s2 ne "" ) );

    my $similarity = similarity( $s1, $s2 );

## TODO factor string length in to similarity?

    return ($similarity);
}

=head2 update_po_all

Update the PO files for all languages

=cut

sub update_po_all {
    my ( $self, $args ) = @_;

    my $msgmerge  = delete( $args->{msgmerge} );
    my $previous  = delete( $args->{previous} );
    my $firstname = delete( $args->{firstname} );
    my $surname   = delete( $args->{surname} );
    my $email     = delete( $args->{email} );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    $self->update_po(
        {   langs     => get_all_langs(),
            msgmerge  => $msgmerge,
            email     => $email,
            firstname => $firstname,
            surname   => $surname,
            previous  => $previous,
        }
    );
    return;
}

=head2 get_msgs

Get the strings to translate from an XML::TreeBuilder object

=cut

sub get_msgs {
    my ( $self, $args ) = @_;
    my $doc = delete( $args->{doc} ) || croak("doc is a mandatory argument");

    my $filename = delete( $args->{filename} )
        || croak("filename is a mandatory argument");

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    my $trans_tree = XML::TreeBuilder->new(
        { 'NoExpand' => "1", 'ErrorContext' => "2" } );

    my $trans_node;

    # Break strings up in to translatable blocks
    # some block level tags, $IGNOREBLOCKS, should be treated inline
    # indexterm is special as it's both translatable and ignorable >_<
    foreach my $child (
        $doc->look_down(
            '_tag',
            qr/$TRANSTAGS/,
            sub {
                my $inner = $_[0];
## an index term NOT in a translatable tag should be translated as a block.
## An indexterm in a translatable tag should be translated inline
                if ( $inner->tag() =~ /indexterm|orgname|productname|phrase/ )
                {
                    not defined(
                        $inner->look_up(
                            '_tag',
                            qr/$IGNOREBLOCKS/,
                            sub {
                                $_[0]->tag() =~ /$TRANSTAGS/
                                    && $inner->look_up( '_tag',
                                    qr/$TRANSTAGS/,
                                    sub { $_[0]->pos() != $inner->pos() } );
                            },
                        )
                    );
                }
## To allow External_Links to be translatable we need to translate the whole list as
## the attributes of then  members need to be translated.
                elsif ( $inner->tag() eq 'simplelist' ) {
                    $filename eq 'External_Links.pot';
                }
                elsif ( $filename eq 'External_Links.pot' ) {
                    0;
                }
                else {
## Other IGNOREBLOCKS tags are completely ignored for translation structure.
                    not defined(
                        $inner->look_up( '_tag', qr/$IGNOREBLOCKS/ ) );

                }
            }
        )
        )
    {
        next if ( $child->is_empty );

        $trans_node = XML::Element->new( $child->tag() );

     # Have to be inside a translatable tag here, so don't need to check again
        my @matches;
        if ( $filename ne 'External_Links.pot' ) {
            @matches = $child->look_down(
                '_tag',
                qr/$TRANSTAGS/,
                sub {
                    not defined(
                        $_[0]->look_up( '_tag', qr/$IGNOREBLOCKS/ ) );
                }
            );
        }

    # No Nesting so push all of this nodes content on to the output trans_tree
        if ( $#matches == -1 ) {
            $trans_node->push_content( $child->content_list() );
        }
        else {

            #debug_msg("processing a $child->tag()\n");

            # Nesting, need to start a new output node
            $trans_tree->push_content($trans_node)
                if ( !$trans_node->is_empty );
            $trans_node = XML::Element->new( $child->tag() )
                ;    # Does this dupliacte new above?

            # Text nodes are not ref
            # any non-matching node should be pushed on to output with text
            # this catches inline tags
            foreach my $nested ( $child->content_list() ) {
                if (ref $nested

                    && $nested->look_down(
                        '_tag',
                        qr/$TRANSTAGS/,
                        sub {
                            not defined(
                                $_[0]->look_up( '_tag', qr/$IGNOREBLOCKS/ ) );
                        }
                    )
                    )
                {
                    $trans_tree->push_content($trans_node)
                        if ( !$trans_node->is_empty );
                    $trans_node = XML::Element->new( $child->tag() );
                    $trans_tree->push_content(
                        $self->get_msgs(
                            { doc => $nested, filename => $filename }
                        )->content_list()
                    );
                }
                else {
                    $trans_node->push_content($nested);
                }
            }

            $trans_tree->push_content($trans_node)
                if ( !$trans_node->is_empty );
        }
        $trans_tree->push_content($trans_node)
            if ( !$trans_node->is_empty );
        $child->delete();
    }

    return ($trans_tree);
}

=head2 merge_msgs

Merge translations in to XML

=cut

sub merge_msgs {
    my ( $self, $args ) = @_;
    my $out_doc = delete( $args->{out_doc} )
        || croak("out_doc is a mandatory argument");
    my $msgids = delete( $args->{msgids} )
        || croak("msgids is a mandatory argument");
    my $ent_file = delete( $args->{ent_file} );
    my $out_file = delete( $args->{out_file} )
        || croak( maketext("out_file is a mandatory argument") );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }
    foreach my $child (
        $out_doc->look_down(
            '_tag',
            qr/$TRANSTAGS/,
##            sub { not defined( $_[0]->look_up( '_tag', qr/$IGNOREBLOCKS/ ) ) }
            sub {
                my $inner = $_[0];
## an index term NOT in a translatable tag should be translated as a block.
## An indexterm in a translatable tag should be translated inline
                if ( $inner->tag() =~ /indexterm|productname|phrase/ ) {
                    not defined(
                        $inner->look_up(
                            '_tag',
                            qr/$IGNOREBLOCKS/,
                            sub {
                                $_[0]->tag() =~ /$TRANSTAGS/
                                    && $inner->parent()
                                    && $inner->parent()->tag()
                                    =~ /$TRANSTAGS/;
                            },
                        )
                    );
                }
## To allow External_Links to be translatable we need to translate the whole list as
## the attributes of then  members need to be translated.
                elsif ( $inner->tag() eq 'simplelist' ) {
                    $out_file =~ /External_Links\.xml/;
                }
                elsif ( $out_file =~ /External_Links\.xml/ ) {
                    0;
                }
                else {
## Other IGNOREBLOCKS tags are completely ignored for translation structure.
                    not defined(
                        $inner->look_up( '_tag', qr/$IGNOREBLOCKS/ ) );

                }
            }
        )
        )
    {

        next if ( $child->attr('processed') );
        $child->attr( 'processed', 1 );

        next if ( $child->is_empty );

     # Have to be inside a translatable tag here, so don't need to check again
        my @matches;
        if ( $out_file !~ /External_Links\.xml/ ) {
            @matches = $child->look_down(
                '_tag',
                qr/$TRANSTAGS/,
                sub {
                    not defined(
                        $_[0]->look_up( '_tag', qr/$IGNOREBLOCKS/ ) );
                }
            );
        }

    # No Nesting so push all of this nodes content on to the output trans_tree
        if ( $#matches == -1 ) {
            $self->translate(
                { ent_file => $ent_file, node => $child, msgids => $msgids }
            );
        }
        else {

            my $trans_node = XML::Element->new( $child->tag() );

            # have to recurse through children
            # pop off all children
            my @content = $child->detach_content();
            foreach my $nested (@content) {

                # No ref == text node
                if (ref $nested
                    && $nested->look_down(
                        '_tag',
                        qr/$TRANSTAGS/,
                        sub {
                            not defined(
                                $_[0]->look_up( '_tag', qr/$IGNOREBLOCKS/ ) );
                        }
                    )
                    )
                {
                    if ( $trans_node && !$trans_node->is_empty ) {
                        $self->translate(
                            {   ent_file => $ent_file,
                                node     => $trans_node,
                                msgids   => $msgids
                            }
                        );
                        $child->push_content( $trans_node->content_list() );
                        $trans_node->delete();
                        $trans_node = XML::Element->new( $child->tag() );
                    }
                    $self->merge_msgs(
                        {   out_file => $out_file,
                            out_doc  => $nested,
                            msgids   => $msgids
                        }
                    );
                    $child->push_content($nested);
                }
                else {
                    $trans_node->push_content($nested);
                }
            }

            if ( $trans_node && !$trans_node->is_empty ) {
                $self->translate(
                    {   ent_file => $ent_file,
                        node     => $trans_node,
                        msgids   => $msgids
                    }
                );
                $child->push_content( $trans_node->content_list() );
                $trans_node->delete();
            }
        }
    }

    return;
}

=head2 translate

Replace strings with translated strings.

=cut

sub translate {
    my ( $self, $args ) = @_;
    my $node = delete( $args->{node} )
        || croak("node is a mandatory argument");
    my $msgids = delete( $args->{msgids} )
        || croak("msgids is a mandatory argument");
    my $ent_file = delete( $args->{ent_file} );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    my $msgid = $node->as_XML();
    my $tag   = $node->tag();

    my $po = new Locale::PO( -msgid => detag( $msgid, $tag ), -msgstr => '' );
    $msgid = $po->msgid();

    my $attr_text = '';
    my %attrs     = $node->all_attr();
    foreach my $key ( keys(%attrs) ) {
        next if ( $key =~ /^_/ );
        $attr_text .= qq{ $key="$attrs{$key}"};
    }

    # mixed mode tags, para, caption, can be empty at this point
    if ( $msgid and ( $msgid eq '""' ) ) {

        #nop
    }
    elsif ( $msgid
        && defined $msgids->{$msgid} )
    {
        if ( $msgids->{$msgid}{msgstr} ne '""' ) {
            my $msgstr = $msgids->{$msgid}{msgstr};
            debug_msg("DANGER: found obsolete msg: $msgid\n")
                if ( $msgstr =~ /^#~/ );

            my $repl = $po->dequote($msgstr);

            my $dtd = Publican::Builder::dtd_string(
                {   tag      => $tag,
                    dtdver   => $self->{publican}->param('dtdver'),
                    cleaning => 1,
                    ent_file => $ent_file
                }
            );
            my $new_tree = Publican::Builder::new_tree();
            $new_tree->store_pis(1);
            $new_tree->parse(qq|$dtd<$tag$attr_text>$repl</$tag>|);
            $node->delete_content();
            $node->push_content( $new_tree->content_list() );
        }
        else {
            if ( $msgids->{$msgid}->fuzzy() )
            {    # BUGBUG TEST this is still set
                logger( maketext("WARNING: Fuzzy message in PO file."), RED );
            }
            else {
                logger(
                    maketext("WARNING: Un-translated message in PO file."),
                    RED );
            }
            my $str = $msgid;
            $str = substr( $str, 0, 64 ) . '...' if ( length($str) > 64 );
            logger(
                "\n" . $msgids->{$msgid}->loaded_line_number . ": $str\n\n",
                RED );
        }
    }
    else {
        logger(
            maketext(
                "WARNING: Message missing from PO file, consider updating your POT and PO files."
            ),
            RED
        );
        logger( "\n" . $msgid . "\n\n", RED );
    }
    return;
}

=head2 print_msgs

Print the translation strings in an XML::TreeBuilder object to a POT file

=cut

sub print_msgs {
    my ( $self, $args ) = @_;
    my $msg_list = delete( $args->{msg_list} )
        || croak("msg_list is a mandatory argument");
    my $pot_file = delete( $args->{pot_file} )
        || croak( maketext("pot_file is a mandatory argument") );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    my $fh;

    open( $fh, ">:encoding(UTF-8)", $pot_file )
        or croak(
        maketext(
            "Failed to open output file [_1]. Error: [_2]",
            $pot_file, $@
        )
        );

    my %msgs = ();
    my $po = new Locale::PO( -msgid => '', -msgstr => $self->header() );
    print( $fh $po->dump() );
    $msgs{''} = $po;

    foreach my $child ( $msg_list->content_list() ) {
        my $msg_id = detag( $child->as_XML(), $child->tag() );

        # This can be empty if a mixed mode tag only contains a block
        next if ( $msg_id eq '' );
        if ( !defined( $msgs{$msg_id} ) ) {
            my $po = new Locale::PO( -msgid => $msg_id, -msgstr => '' );
            print( $fh $po->dump() );
            $msgs{$msg_id} = $po;
        }
    }
    close($fh);

    return;
}

=head2 header

Returns a valid PO header string.

=cut

sub header {
    my $self = shift;

    my $date
        = DateTime->now( time_zone => "local" )->strftime("%Y-%m-%d %H:%M%z");

    my $lang = $self->{publican}->param('xml_lang');
    $lang =~ s/_/-/g;
    my $pver = $self->{publican}->VERSION;

    my $string = <<POT;
Project-Id-Version: 0
POT-Creation-Date: $date
PO-Revision-Date: $date
Last-Translator: Automatically generated
Language-Team: None
Language: $lang 
MIME-Version: 1.0
Content-Type: application/x-publican; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Generator: Publican $pver
POT

    return ($string);
}

=head2 detag

Format a string for use in a PO file.

=cut

sub detag {
    my $string = shift;
    my $name = shift || '';

    debug_msg("unknown tag for: $string") if $name eq '';

    if ( $name =~ /$VERBATIM/ ) {

        # remove start tag to reduce polution
        $string =~ s/^<$name[^>]*>//;

        # remove close tag to reduce polution
        $string =~ s/<\/$name>\s*$//;
        chomp($string);
    }
    else {
        chomp($string);

        # remove start tag & leading space
        $string =~ s/^<$name[^>]*>[ \t]*//;

        # remove close tag & trailing
        $string =~ s/[ \t]*<\/$name>\s*$//;

        $string =~ s/\n/ /g;        # CR
        $string =~ s/^[ \t]*//g;    # space at start of line
        $string =~ s/[ \t]*$//g;    # space at end of line
        $string =~ s/[ \t]+/ /g;    # collapse spacing
    }

    $string =~ s/&#38;/&amp;/g;
    $string =~ s/&#60;/&lt;/g;
    $string =~ s/&#62;/&gt;/g;
    $string =~ s/&#34;/"/g;
    $string =~ s/&#39;/'/g;
    $string =~ s/&quot;/"/g;
    $string =~ s/&apos;/'/g;

    return ($string);
}

=head2 po_report

Generate translation statistics for the supplied language.

=cut

sub po_report {
    my ( $self, $args ) = @_;

    my $lang = delete( $args->{lang} )
        || croak( maketext("'lang' is a mandatory argument") );

    if ( %{$args} ) {
        croak(
            maketext(
                "unknown arguments: [_1]", join( ", ", keys %{$args} )
            )
        );
    }

    my @po_files = dir_list( $lang, '*.po' );

    my %lang_stats = (
        msg_count     => 0,
        fuzzy_count   => 0,
        trans_count   => 0,
        untrans_count => 0,
        word_count    => 0,
    );
    my $sep   = '=' x 82;
    my $rate  = 250;
    my $frate = $rate * 2;

    my $file_name    = maketext("File Name");
    my $untranslated = maketext("Untranslated");
    my $fuzzy        = maketext("Fuzzy");
    my $translated   = maketext("Translated");

    logger("$sep\n");
    logger(
        sprintf(
            "%-40s %15s %10s %10s\n",
            $file_name, $untranslated, $fuzzy, $translated
        )
    );
    logger("$sep\n");

    foreach my $po_file ( sort(@po_files) ) {

        my $msgids = Locale::PO->load_file_ashash($po_file);

        #debug_msg( "hash: " . join( "\n\n", keys( %{$msgids} ) ) . "\n\n" );

        my %po_stats = (
            msg_count     => 0,
            fuzzy_count   => 0,
            trans_count   => 0,
            untrans_count => 0,
            word_count    => 0,
        );

        foreach my $key ( keys( %{$msgids} ) ) {
            my $msgref = $msgids->{$key};
            $po_stats{msg_count}++;
            next unless $msgref->msgid();

            if ( $msgref->obsolete() ) {
                $po_stats{msg_count}--;
                next;
            }

            my $count = ()
                = $msgref->msgid()
                =~ /(?:\s+|<\/[a-zA-Z]+><[a-zA-Z]+>\S|-|.$)/g;
            $po_stats{word_count} += $count;
            if ( $msgref->msgstr() =~ /^""$/ ) {
                $po_stats{untrans_count} += $count;
            }
            elsif ( $msgref->fuzzy() ) {
                $po_stats{fuzzy_count} += $count;
            }
            else {
                $po_stats{trans_count} += $count;
            }
        }

        logger(
            sprintf(
                "%-45s %10d %10d %10d\n",
                $po_file,               $po_stats{untrans_count},
                $po_stats{fuzzy_count}, $po_stats{trans_count}
            )
        );

        $lang_stats{msg_count}     += $po_stats{msg_count};
        $lang_stats{fuzzy_count}   += $po_stats{fuzzy_count};
        $lang_stats{trans_count}   += $po_stats{trans_count};
        $lang_stats{untrans_count} += $po_stats{untrans_count};
        $lang_stats{word_count}    += $po_stats{word_count};
    }

    logger("$sep\n");

    my $total = maketext( "Total for [_1]", $lang );
    logger(
        sprintf(
            "%-45s %10d %10d %10d\n",
            $total,                   $lang_stats{untrans_count},
            $lang_stats{fuzzy_count}, $lang_stats{trans_count}
        )
    );

    my $remaining = maketext( "Remaining hours for [_1]", $lang );

    logger(
        sprintf(
            "%-45s %10.2f %10.2f\n",
            $remaining,
            ( $lang_stats{untrans_count} / $rate ),
            ( $lang_stats{fuzzy_count} / $frate )
        )
    );
    logger("$sep\n");

    return;
}

1;    # Magic true value required at end of module
__END__

=head1 DIAGNOSTICS

=over

=item C<< unknown args %s >>

All subs with named parameters will return this error when unexpected named arguments are provided.

=item C<< %s is a required argument >>

Any sub with a mandatory parameter will return this error if the parameter is undef.

=back


=head1 CONFIGURATION AND ENVIRONMENT

Publican requires no configuration files or environment variables.


=head1 DEPENDENCIES

Carp
version
Publican
File::Path
Term::ANSIColor
DateTime
Locale::PO
XML::TreeBuilder
String::Similarity

=head1 INCOMPATIBILITIES

None reported.

=head1 BUGS AND LIMITATIONS

No bugs have been reported.

Please report any bugs or feature requests to
C<publican-list@redhat.com>, or through the web interface at
L<https://bugzilla.redhat.com/bugzilla/enter_bug.cgi?product=Publican&amp;component=publican>.


=head1 AUTHOR

Jeff Fearn  C<< <jfearn@redhat.com> >>
publican 4.3.2-1 / usr / share / perl5 / Publican / Translate.pm
