Attachment #169564 for bug #37472

View | Details | Raw Unified | Return to bug 37472
Collapse All | Expand All




use Modern::Perl;

use C4::Context;

# WARNING: Any other tested YAML library fails to work properly in this
# script content
# FIXME Really?
use YAML::XS;
use Locale::PO;
use FindBin    qw( $Bin );
use File::Path qw( make_path );
use File::Copy;
use File::Slurp qw( read_file );
use JSON        qw( decode_json encode_json );

use Koha::Plugins;

sub set_lang {
    my ( $self, $lang ) = @_;

    $self->{lang}         = $lang;
    $self->{po_path_lang} = C4::Context->config('intrahtdocs') . "/prog/$lang/modules/admin/preferences";
                            "/prog/$lang/modules/admin/preferences";
}

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

    my $lang      = $args->{lang};
    my $pref_only = $args->{pref_only};
    my $verbose   = $args->{verbose};

    my $self = {};

    $self->{path_pref_en} = C4::Context->config('intrahtdocs') . '/prog/en/modules/admin/preferences';
                               '/prog/en/modules/admin/preferences';
    set_lang( $self, $lang ) if $lang;
    $self->{pref_only}   = $pref_only;
    $self->{verbose}     = $verbose;
    $self->{process}     = "$Bin/tmpl_process3.pl " . ( $verbose ? '' : '-q' );
    $self->{path_po}     = "$Bin/po";
    $self->{po}          = {};
    $self->{domain}      = 'Koha';
    $self->{msgfmt}      = `which msgfmt`;
    $self->{po2json}     = "yarn run po2json";
    $self->{gzip}        = `which gzip`;
    $self->{gunzip}      = `which gunzip`;
    $self->{plugin_dirs} = _identify_translatable_plugins();
    chomp $self->{msgfmt};
    chomp $self->{gzip};
    chomp $self->{gunzip};


    # Get all available language codes
    opendir $fh, $self->{path_po};
    my @langs = map { ($_) =~ /(.*)-pref/ }
        grep { $_ =~ /.*-pref/ } readdir($fh);
    closedir $fh;
    $self->{langs} = \@langs;

    # OPAC themes
    opendir my $dh, C4::Context->config('opachtdocs');
    for my $theme ( grep { not /^\.|lib|xslt/ } readdir($dh) ) {
        push @{ $self->{interface} }, {
            name   => "OPAC $theme",
            dir    => "$opachtdocs/$theme",
            suffix => "-opac-$theme.po",


    # MARC flavours (hardcoded list)
    for ( "MARC21", "UNIMARC" ) {

        # search for strings on staff & opac marc files
        my $dirs = C4::Context->config('intrahtdocs') . '/prog';
        opendir $fh, C4::Context->config('opachtdocs');
        for ( grep { not /^\.|\.\.|lib$|xslt/ } readdir($fh) ) {
            $dirs .= ' ' . "$opachtdocs/$_";
        }
        push @{ $self->{interface} }, {
            name   => "$_",
            dir    => $dirs,
            suffix => "-marc-$_.po",

    }

    # EN YAML installer files
    push @{ $self->{installer} }, {
        name => "YAML installer files",
        dirs => [
            'installer/data/mysql/en/mandatory',
            'installer/data/mysql/en/optional'
        ],
        suffix => "-installer.po",
    };

    # EN MARC21 YAML installer files
    push @{ $self->{installer} }, {
        name => "MARC21 YAML installer files",
        dirs => [
            'installer/data/mysql/en/marcflavour/marc21/mandatory',
            'installer/data/mysql/en/marcflavour/marc21/optional'
        ],
        suffix => "-installer-MARC21.po",
    };

    # EN UNIMARC YAML installer files
    push @{ $self->{installer} }, {
        name => "UNIMARC YAML installer files",
        dirs => [
            'installer/data/mysql/en/marcflavour/unimarc/mandatory',
            'installer/data/mysql/en/marcflavour/unimarc/optional'
        ],
        suffix => "-installer-UNIMARC.po",
    };


    bless $self, $class;
}


}

sub get_trans_text {
    my ( $self, $msgid, $default ) = @_;

    my $po = $self->{po}->{ Locale::PO->quote($msgid) };
    if ( $po and not defined( $po->fuzzy() ) ) {
        my $msgstr = Locale::PO->dequote( $po->msgstr );
        if ( $msgstr and length($msgstr) > 0 ) {
            return $msgstr;
        }
    }

}

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

    if ( ref($tab_content) eq 'ARRAY' ) {
        return $self->get_translated_prefs( $file, $tab_content );
    }

    my $translated_tab_content = {
        map {
            my $section  = $_;
            my $sysprefs = $tab_content->{$section};
            my $msgid    = sprintf( '%s %s', $file, $section );

            $self->get_trans_text( $msgid, $section ) => $self->get_translated_prefs( $file, $sysprefs );
        } keys %$tab_content
    };

    if ( keys %$translated_tab_content != keys %$tab_content ) {
        my %duplicates;
        for my $section ( keys %$tab_content ) {
            push @{ $duplicates{ $self->get_trans_text( "$file $section", $section ) } }, $section;
        }
        for my $translation ( keys %duplicates ) {
            if ( @{ $duplicates{$translation} } > 1 ) {
                warn qq(In file "$file", "$translation" is a translation for sections ")
                    . join( '", "', @{ $duplicates{$translation} } ) . '"';
            }
        }
    }

}

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

    my $translated_prefs = [
        map {
            my ($pref_elt) = grep { ref($_) eq 'HASH' && exists $_->{pref} } @$_;
            my $pref_name = $pref_elt ? $pref_elt->{pref} : '';

            my $translated_syspref = [ map { $self->get_translated_pref( $file, $pref_name, $_ ); } @$_ ];
                map {
                    $self->get_translated_pref($file, $pref_name, $_);
                } @$_
            ];

            $translated_syspref;
        } @$sysprefs

}

sub get_translated_pref {
    my ( $self, $file, $pref_name, $syspref ) = @_;

    unless ( ref($syspref) ) {
        $syspref //= '';
        my $msgid = sprintf( '%s#%s# %s', $file, $pref_name, $syspref );
        return $self->get_trans_text( $msgid, $syspref );
    }

    my $translated_pref = {
        map {
            my $key   = $_;
            my $value = $syspref->{$key};

            my $translated_value = $value;
            if ( ( $key eq 'choices' || $key eq 'multiple' ) && ref($value) eq 'HASH' ) {
                $translated_value = {
                    map {
                        my $msgid = sprintf( '%s#%s# %s', $file, $pref_name, $value->{$_} );
                        $_ => $self->get_trans_text( $msgid, $value->{$_} )
                    } keys %$value
                };
            }

            $key => $translated_value

        exit;
    }

    $self->{po} = Locale::PO->load_file_ashash( $self->po_filename("-pref.po"), 'utf8' );

    for my $file ( @{ $self->{pref_files} } ) {
        my $pref = YAML::XS::LoadFile( $self->{path_pref_en} . "/$file" );

        my $translated_pref = {
            map {
                my $tab         = $_;
                my $tab_content = $pref->{$tab};

                $self->get_trans_text( $file, $tab ) => $self->get_translated_tab_content( $file, $tab_content );
            } keys %$pref
        };

        if ( keys %$translated_pref != keys %$pref ) {
            my %duplicates;
            for my $tab ( keys %$pref ) {
                push @{ $duplicates{ $self->get_trans_text( $file, $tab ) } }, $tab;
            }
            for my $translation ( keys %duplicates ) {
                if ( @{ $duplicates{$translation} } > 1 ) {
                    warn qq(In file "$file", "$translation" is a translation for tabs ")
                        . join( '", "', @{ $duplicates{$translation} } ) . '"';
                }
            }
        }

        my $file_trans = $self->{po_path_lang} . "/$file";
        print "Write $file\n" if $self->{verbose};
        YAML::XS::DumpFile( $file_trans, $translated_pref );
    }
}


sub install_tmpl {
    my ( $self, $files ) = @_;
    say "Install templates" if $self->{verbose};
    for my $trans ( @{ $self->{interface} } ) {
        my @t_dirs = split( " ", $trans->{dir} );
        for my $t_dir (@t_dirs) {
            my @files  = @$files;
            my @nomarc = ();
            print
                "  Install templates '$trans->{name}'\n",

            my $lang_dir  = "$t_dir/$self->{lang}";
            $lang_dir =~ s|/en/|/$self->{lang}/|;
            mkdir $lang_dir unless -d $lang_dir;

            # if installing MARC po file, only touch corresponding files
            my $marc = ( $trans->{name} =~ /MARC/ ) ? "-m \"$trans->{name}\"" : "";    # for MARC translations
                # if not installing MARC po file, ignore all MARC files
            @nomarc = ( 'marc21', 'unimarc' ) if ( $trans->{name} !~ /MARC/ );    # hardcoded MARC variants

            system "$self->{process} install "
                . "-i $trans_dir "
                . "-o $lang_dir  "
                . "-s $self->{path_po}/$self->{lang}$trans->{suffix} -r "
                . "$marc "
                . ( @files  ? ' -f ' . join ' -f ', @files  : '' )
                . ( @nomarc ? ' -n ' . join ' -n ', @nomarc : '' );
                ( @nomarc  ? ' -n ' . join ' -n ', @nomarc : '');
        }
    }


    my $po_file = $self->po_filename( $target->{suffix} );
    return $srcyml unless ( -e $po_file );

    my $po_ref = Locale::PO->load_file_ashash( $po_file, 'utf8' );

    my $dstyml = YAML::XS::LoadFile($srcyml);

    # translate fields in table rows
    my @tables = @{ $dstyml->{'tables'} };
    for my $table (@tables) {    # each table
        my $table_name   = ( keys %$table )[0];
        my @translatable = @{ $table->{$table_name}->{translatable} };
        my @rows         = @{ $table->{$table_name}->{rows} };
        my @multiline    = @{ $table->{$table_name}->{'multiline'} };    # to check multiline values
        for my $row (@rows) {                                            # each row
            for my $field (@translatable) {                              # each translatable field
                if ( @multiline and grep { $_ eq $field } @multiline ) {    # multiline fields, only notices ATM
                    foreach my $line ( @{ $row->{$field} } ) {
                        my @ttvar;
                        while ( $line =~ s/(<<.*?>>|\[\%.*?\%\]|<.*?>)/\%s/ ) {    # put placeholders, save matches
                            my $var = $1;
                            push @ttvar, $var;
                        }

                        if ( $line =~ /^(\s|%s|-|[[:punct:]]|\(|\))*$/ ) {         # ignore non strings
                            while (@ttvar) {                                       # restore placeholders
                                my $var = shift @ttvar;
                                $line =~ s/\%s/$var/;
                            }
                            next;
                        } else {
                            my $po = $po_ref->{"\"$line\""};                       # quoted key
                            if (
                                $po and not defined( $po->fuzzy() )                # not fuzzy
                                and length( $po->msgid() ) > 2                     # not empty msgid
                                and length( $po->msgstr() ) > 2
                                )
                            {                                                      # not empty msgstr
                                $line = $po->dequote( $po->msgstr() );
                            }
                            while (@ttvar) {                                       # restore placeholders
                                my $var = shift @ttvar;
                                $line =~ s/\%s/$var/;
                            }
                        }
                    }
                } else {
                    next unless defined $row->{$field};          # next if null value
                    my $po = $po_ref->{"\"$row->{$field}\""};    # quoted key
                    if (
                        $po and not defined( $po->fuzzy() )      # not fuzzy
                        and length( $po->msgid() ) > 2           # not empty msgid
                        and length( $po->msgstr() ) > 2
                        )
                    {                                            # not empty msgstr
                        $row->{$field} = $po->dequote( $po->msgstr() );
                    }
                }

    # translate descriptions
    for my $description ( @{ $dstyml->{'description'} } ) {
        my $po = $po_ref->{"\"$description\""};
        if (    $po
            and not defined( $po->fuzzy() )
            and length( $po->msgid() ) > 2
            and length( $po->msgstr() ) > 2 )
        {
            $description = $po->dequote( $po->msgstr() );
        }
    }


    my $intradir  = C4::Context->config('intranetdir');
    my $db_scheme = C4::Context->config('db_scheme');
    my $langdir   = "$intradir/installer/data/$db_scheme/$self->{lang}";

    say "Install installer files\n" if $self->{verbose};


            ( my $tdir = "$dir" ) =~ s|/en/|/$self->{lang}/|;
            make_path("$intradir/$tdir");

            opendir( my $dh, "$intradir/$dir" ) or die("Can't open $intradir/$dir");
            my @files = grep { !/^\.+$/ } readdir($dh);
            close($dh);

            for my $file (@files) {
                if ( $file =~ /yml$/ ) {
                    my $translated_yaml = translate_yaml( $self, $target, "$intradir/$dir/$file" );
                    YAML::XS::DumpFile( "$intradir/$tdir/$file", $translated_yaml );

sub locale_name {
    my $self = shift;

    my ( $language, $region, $country ) = split /-/, $self->{lang};
    $country //= $region;
    my $locale = $language;
    if ( $country && length($country) == 2 ) {
        $locale .= '_' . $country;
    }


sub install_messages {
    my ($self) = @_;

    my $locale    = $self->locale_name();
    my $modir     = "$self->{path_po}/$locale/LC_MESSAGES";
    my $pofile    = "$self->{path_po}/$self->{lang}-messages.po";
    my $mofile    = "$modir/$self->{domain}.mo";
    my $js_pofile = "$self->{path_po}/$self->{lang}-messages-js.po";

    unless ( -f $pofile && -f $js_pofile ) {

    make_path($modir);
    system "$self->{msgfmt} -o $mofile $pofile";

    my $tmp_po      = sprintf '/tmp/%s-messages.po', $self->{lang};
    my $po2json_cmd = sprintf '%s %s %s', $self->{po2json}, $js_pofile, $tmp_po;
    `$po2json_cmd`;
    my $json = read_file($tmp_po);

    my $combined_json = encode_json($js_po_data);

    my $js_locale_data = sprintf 'var json_locale_data = {"Koha":%s};', $combined_json;
    my $progdir        = C4::Context->config('intrahtdocs') . '/prog';
    mkdir "$progdir/$self->{lang}/js";
    open my $fh, '>', "$progdir/$self->{lang}/js/locale_data.js";
    print $fh $js_locale_data;
    close $fh;

    my $opachtdocs = C4::Context->config('opachtdocs');
    opendir( my $dh, $opachtdocs );
    for my $theme ( grep { not /^\.|lib|xslt/ } readdir($dh) ) {
        mkdir "$opachtdocs/$theme/$self->{lang}/js";
        open my $fh, '>', "$opachtdocs/$theme/$self->{lang}/js/locale_data.js";

}

sub compress {
    my ( $self, $files ) = @_;
    my @langs = $self->{lang} ? ( $self->{lang} ) : $self->get_all_langs();
    for my $lang (@langs) {
        $self->set_lang($lang);
        opendir( my $dh, $self->{path_po} );
        my @files = grep { $_ =~ /^$self->{lang}.*po$/ } readdir $dh;
        foreach my $file (@files) {
            say "Compress file $file" if $self->{verbose};
            system "$self->{gzip} -9 $self->{path_po}/$file";
        }

}

sub uncompress {
    my ( $self, $files ) = @_;
    my @langs = $self->{lang} ? ( $self->{lang} ) : $self->get_all_langs();
    for my $lang (@langs) {
        opendir( my $dh, $self->{path_po} );
        $self->set_lang($lang);
        my @files = grep { $_ =~ /^$self->{lang}.*po.gz$/ } readdir $dh;
        foreach my $file (@files) {
            say "Uncompress file $file" if $self->{verbose};
            system "$self->{gunzip} $self->{path_po}/$file";
        }

}

sub install {
    my ( $self, $files ) = @_;
    return unless $self->{lang};
    $self->uncompress();

    if ( $self->{pref_only} ) {
        $self->install_prefs();
    } else {
        $self->install_tmpl($files);

    }
}


sub get_all_langs {
    my $self = shift;
    opendir( my $dh, $self->{path_po} );
    my @files = grep { $_ =~ /-pref.(po|po.gz)$/ } readdir $dh;
        readdir $dh;
    @files = map { $_ =~ s/-pref.(po|po.gz)$//r } @files;
}


    return \@plugin_dirs;
}


1;


=head1 NAME

LangInstaller.pm - Handle templates and preferences translation
- 

Return to bug 37472