misc/translator/LangInstaller.pm

   1 package LangInstaller;
   2
   3 # Copyright (C) 2010 Tamil s.a.r.l.
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 use C4::Context;
  23 # WARNING: Any other tested YAML library fails to work properly in this
  24 # script content
  25 use YAML::Syck qw( Dump LoadFile DumpFile );
  26 use Locale::PO;
  27 use FindBin qw( $Bin );
  28 use File::Basename;
  29 use File::Find;
  30 use File::Path qw( make_path );
  31 use File::Copy;
  32 use File::Slurp;
  33 use File::Spec;
  34 use File::Temp qw( tempdir tempfile );
  35 use Template::Parser;
  36 use PPI;
  37
  38
  39 $YAML::Syck::ImplicitTyping = 1;
  40
  41
  42 # Default file header for .po syspref files
  43 my $default_pref_po_header = Locale::PO->new(-msgid => '', -msgstr =>
  44     "Project-Id-Version: PACKAGE VERSION\\n" .
  45     "PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n" .
  46     "Last-Translator: FULL NAME <EMAIL\@ADDRESS>\\n" .
  47     "Language-Team: Koha Translate List <koha-translate\@lists.koha-community.org>\\n" .
  48     "MIME-Version: 1.0\\n" .
  49     "Content-Type: text/plain; charset=UTF-8\\n" .
  50     "Content-Transfer-Encoding: 8bit\\n" .
  51     "Plural-Forms: nplurals=2; plural=(n > 1);\\n"
  52 );
  53
  54
  55 sub set_lang {
  56     my ($self, $lang) = @_;
  57
  58     $self->{lang} = $lang;
  59     $self->{po_path_lang} = $self->{context}->config('intrahtdocs') .
  60                             "/prog/$lang/modules/admin/preferences";
  61 }
  62
  63
  64 sub new {
  65     my ($class, $lang, $pref_only, $verbose) = @_;
  66
  67     my $self                 = { };
  68
  69     my $context              = C4::Context->new();
  70     $self->{context}         = $context;
  71     $self->{path_pref_en}    = $context->config('intrahtdocs') .
  72                                '/prog/en/modules/admin/preferences';
  73     set_lang( $self, $lang ) if $lang;
  74     $self->{pref_only}       = $pref_only;
  75     $self->{verbose}         = $verbose;
  76     $self->{process}         = "$Bin/tmpl_process3.pl " . ($verbose ? '' : '-q');
  77     $self->{path_po}         = "$Bin/po";
  78     $self->{po}              = { '' => $default_pref_po_header };
  79     $self->{domain}          = 'Koha';
  80     $self->{cp}              = `which cp`;
  81     $self->{msgmerge}        = `which msgmerge`;
  82     $self->{msgfmt}          = `which msgfmt`;
  83     $self->{msginit}         = `which msginit`;
  84     $self->{msgattrib}       = `which msgattrib`;
  85     $self->{xgettext}        = `which xgettext`;
  86     $self->{sed}             = `which sed`;
  87     $self->{po2json}         = "$Bin/po2json";
  88     $self->{gzip}            = `which gzip`;
  89     $self->{gunzip}          = `which gunzip`;
  90     chomp $self->{cp};
  91     chomp $self->{msgmerge};
  92     chomp $self->{msgfmt};
  93     chomp $self->{msginit};
  94     chomp $self->{msgattrib};
  95     chomp $self->{xgettext};
  96     chomp $self->{sed};
  97     chomp $self->{gzip};
  98     chomp $self->{gunzip};
  99
 100     unless ($self->{xgettext}) {
 101         die "Missing 'xgettext' executable. Have you installed the gettext package?\n";
 102     }
 103
 104     # Get all .pref file names
 105     opendir my $fh, $self->{path_pref_en};
 106     my @pref_files = grep { /\.pref$/ } readdir($fh);
 107     close $fh;
 108     $self->{pref_files} = \@pref_files;
 109
 110     # Get all available language codes
 111     opendir $fh, $self->{path_po};
 112     my @langs =  map { ($_) =~ /(.*)-pref/ }
 113         grep { $_ =~ /.*-pref/ } readdir($fh);
 114     closedir $fh;
 115     $self->{langs} = \@langs;
 116
 117     # Map for both interfaces opac/intranet
 118     my $opachtdocs = $context->config('opachtdocs');
 119     $self->{interface} = [
 120         {
 121             name   => 'Intranet prog UI',
 122             dir    => $context->config('intrahtdocs') . '/prog',
 123             suffix => '-staff-prog.po',
 124         },
 125     ];
 126
 127     # OPAC themes
 128     opendir my $dh, $context->config('opachtdocs');
 129     for my $theme ( grep { not /^\.|lib|xslt/ } readdir($dh) ) {
 130         push @{$self->{interface}}, {
 131             name   => "OPAC $theme",
 132             dir    => "$opachtdocs/$theme",
 133             suffix => "-opac-$theme.po",
 134         };
 135     }
 136
 137     # MARC flavours (hardcoded list)
 138     for ( "MARC21", "UNIMARC", "NORMARC" ) {
 139         # search for strings on staff & opac marc files
 140         my $dirs = $context->config('intrahtdocs') . '/prog';
 141         opendir $fh, $context->config('opachtdocs');
 142         for ( grep { not /^\.|\.\.|lib$|xslt/ } readdir($fh) ) {
 143             $dirs .= ' ' . "$opachtdocs/$_";
 144         }
 145         push @{$self->{interface}}, {
 146             name   => "$_",
 147             dir    => $dirs,
 148             suffix => "-marc-$_.po",
 149         };
 150     }
 151
 152     # EN YAML installer files
 153     push @{$self->{installer}}, {
 154         name   => "YAML installer files",
 155         dirs   => [ 'installer/data/mysql/en/mandatory',
 156                     'installer/data/mysql/en/optional'],
 157         suffix => "-installer.po",
 158     };
 159
 160     # EN MARC21 YAML installer files
 161     push @{$self->{installer}}, {
 162         name   => "MARC21 YAML installer files",
 163         dirs   => [ 'installer/data/mysql/en/marcflavour/marc21/mandatory',
 164                     'installer/data/mysql/en/marcflavour/marc21/optional'],
 165         suffix => "-installer-MARC21.po",
 166     };
 167
 168     # EN UNIMARC YAML installer files
 169     push @{$self->{installer}}, {
 170         name   => "UNIMARC YAML installer files",
 171         dirs   => [ 'installer/data/mysql/en/marcflavour/unimarc/mandatory', ],
 172         suffix => "-installer-UNIMARC.po",
 173     };
 174
 175     bless $self, $class;
 176 }
 177
 178
 179 sub po_filename {
 180     my $self   = shift;
 181     my $suffix = shift;
 182
 183     my $context    = C4::Context->new;
 184     my $trans_path = $Bin . '/po';
 185     my $trans_file = "$trans_path/" . $self->{lang} . $suffix;
 186     return $trans_file;
 187 }
 188
 189
 190 sub po_append {
 191     my ($self, $id, $comment) = @_;
 192     my $po = $self->{po};
 193     my $p = $po->{$id};
 194     if ( $p ) {
 195         $p->comment( $p->comment . "\n" . $comment );
 196     }
 197     else {
 198         $po->{$id} = Locale::PO->new(
 199             -comment => $comment,
 200             -msgid   => $id,
 201             -msgstr  => ''
 202         );
 203     }
 204 }
 205
 206
 207 sub add_prefs {
 208     my ($self, $comment, $prefs) = @_;
 209
 210     for my $pref ( @$prefs ) {
 211         my $pref_name = '';
 212         for my $element ( @$pref ) {
 213             if ( ref( $element) eq 'HASH' ) {
 214                 $pref_name = $element->{pref};
 215                 last;
 216             }
 217         }
 218         for my $element ( @$pref ) {
 219             if ( ref( $element) eq 'HASH' ) {
 220                 while ( my ($key, $value) = each(%$element) ) {
 221                     next unless $key eq 'choices' or $key eq 'multiple';
 222                     next unless ref($value) eq 'HASH';
 223                     for my $ckey ( keys %$value ) {
 224                         my $id = $self->{file} . "#$pref_name# " . $value->{$ckey};
 225                         $self->po_append( $id, $comment );
 226                     }
 227                 }
 228             }
 229             elsif ( $element ) {
 230                 $self->po_append( $self->{file} . "#$pref_name# $element", $comment );
 231             }
 232         }
 233     }
 234 }
 235
 236
 237 sub get_trans_text {
 238     my ($self, $id) = @_;
 239
 240     my $po = $self->{po}->{$id};
 241     return unless $po;
 242     return Locale::PO->dequote($po->msgstr);
 243 }
 244
 245
 246 sub update_tab_prefs {
 247     my ($self, $pref, $prefs) = @_;
 248
 249     for my $p ( @$prefs ) {
 250         my $pref_name = '';
 251         next unless $p;
 252         for my $element ( @$p ) {
 253             if ( ref( $element) eq 'HASH' ) {
 254                 $pref_name = $element->{pref};
 255                 last;
 256             }
 257         }
 258         for my $i ( 0..@$p-1 ) {
 259             my $element = $p->[$i];
 260             if ( ref( $element) eq 'HASH' ) {
 261                 while ( my ($key, $value) = each(%$element) ) {
 262                     next unless $key eq 'choices' or $key eq 'multiple';
 263                     next unless ref($value) eq 'HASH';
 264                     for my $ckey ( keys %$value ) {
 265                         my $id = $self->{file} . "#$pref_name# " . $value->{$ckey};
 266                         my $text = $self->get_trans_text( $id );
 267                         $value->{$ckey} = $text if $text;
 268                     }
 269                 }
 270             }
 271             elsif ( $element ) {
 272                 my $id = $self->{file} . "#$pref_name# $element";
 273                 my $text = $self->get_trans_text( $id );
 274                 $p->[$i] = $text if $text;
 275             }
 276         }
 277     }
 278 }
 279
 280
 281 sub get_po_from_prefs {
 282     my $self = shift;
 283
 284     for my $file ( @{$self->{pref_files}} ) {
 285         my $pref = LoadFile( $self->{path_pref_en} . "/$file" );
 286         $self->{file} = $file;
 287         # Entries for tab titles
 288         $self->po_append( $self->{file}, $_ ) for keys %$pref;
 289         while ( my ($tab, $tab_content) = each %$pref ) {
 290             if ( ref($tab_content) eq 'ARRAY' ) {
 291                 $self->add_prefs( $tab, $tab_content );
 292                 next;
 293             }
 294             while ( my ($section, $sysprefs) = each %$tab_content ) {
 295                 my $comment = "$tab > $section";
 296                 $self->po_append( $self->{file} . " " . $section, $comment );
 297                 $self->add_prefs( $comment, $sysprefs );
 298             }
 299         }
 300     }
 301 }
 302
 303
 304 sub save_po {
 305     my $self = shift;
 306
 307     # Create file header if it doesn't already exist
 308     my $po = $self->{po};
 309     $po->{''} ||= $default_pref_po_header;
 310
 311     # Write .po entries into a file put in Koha standard po directory
 312     Locale::PO->save_file_fromhash( $self->po_filename("-pref.po"), $po );
 313     say "Saved in file: ", $self->po_filename("-pref.po") if $self->{verbose};
 314 }
 315
 316
 317 sub get_po_merged_with_en {
 318     my $self = shift;
 319
 320     # Get po from current 'en' .pref files
 321     $self->get_po_from_prefs();
 322     my $po_current = $self->{po};
 323
 324     # Get po from previous generation
 325     my $po_previous = Locale::PO->load_file_ashash( $self->po_filename("-pref.po") );
 326
 327     for my $id ( keys %$po_current ) {
 328         my $po =  $po_previous->{Locale::PO->quote($id)};
 329         next unless $po;
 330         my $text = Locale::PO->dequote( $po->msgstr );
 331         $po_current->{$id}->msgstr( $text );
 332     }
 333 }
 334
 335
 336 sub update_prefs {
 337     my $self = shift;
 338     print "Update '", $self->{lang},
 339           "' preferences .po file from 'en' .pref files\n" if $self->{verbose};
 340     $self->get_po_merged_with_en();
 341     $self->save_po();
 342 }
 343
 344
 345 sub install_prefs {
 346     my $self = shift;
 347
 348     unless ( -r $self->{po_path_lang} ) {
 349         print "Koha directories hierarchy for ", $self->{lang}, " must be created first\n";
 350         exit;
 351     }
 352
 353     # Get the language .po file merged with last modified 'en' preferences
 354     $self->get_po_merged_with_en();
 355
 356     for my $file ( @{$self->{pref_files}} ) {
 357         my $pref = LoadFile( $self->{path_pref_en} . "/$file" );
 358         $self->{file} = $file;
 359         # First, keys are replaced (tab titles)
 360         $pref = do {
 361             my %pref = map {
 362                 $self->get_trans_text( $self->{file} ) || $_ => $pref->{$_}
 363             } keys %$pref;
 364             \%pref;
 365         };
 366         while ( my ($tab, $tab_content) = each %$pref ) {
 367             if ( ref($tab_content) eq 'ARRAY' ) {
 368                 $self->update_tab_prefs( $pref, $tab_content );
 369                 next;
 370             }
 371             while ( my ($section, $sysprefs) = each %$tab_content ) {
 372                 $self->update_tab_prefs( $pref, $sysprefs );
 373             }
 374             my $ntab = {};
 375             for my $section ( keys %$tab_content ) {
 376                 my $id = $self->{file} . " $section";
 377                 my $text = $self->get_trans_text($id);
 378                 my $nsection = $text ? $text : $section;
 379                 if( exists $ntab->{$nsection} ) {
 380                     # When translations collide (see BZ 18634)
 381                     push @{$ntab->{$nsection}}, @{$tab_content->{$section}};
 382                 } else {
 383                     $ntab->{$nsection} = $tab_content->{$section};
 384                 }
 385             }
 386             $pref->{$tab} = $ntab;
 387         }
 388         my $file_trans = $self->{po_path_lang} . "/$file";
 389         print "Write $file\n" if $self->{verbose};
 390         open my $fh, ">", $file_trans;
 391         print $fh Dump($pref);
 392     }
 393 }
 394
 395
 396 sub install_tmpl {
 397     my ($self, $files) = @_;
 398     say "Install templates" if $self->{verbose};
 399     for my $trans ( @{$self->{interface}} ) {
 400         my @t_dirs = split(" ", $trans->{dir});
 401         for my $t_dir ( @t_dirs ) {
 402             my @files   = @$files;
 403             my @nomarc = ();
 404             print
 405                 "  Install templates '$trans->{name}'\n",
 406                 "    From: $t_dir/en/\n",
 407                 "    To  : $t_dir/$self->{lang}\n",
 408                 "    With: $self->{path_po}/$self->{lang}$trans->{suffix}\n"
 409                 if $self->{verbose};
 410
 411             my $trans_dir = "$t_dir/en/";
 412             my $lang_dir  = "$t_dir/$self->{lang}";
 413             $lang_dir =~ s|/en/|/$self->{lang}/|;
 414             mkdir $lang_dir unless -d $lang_dir;
 415             # if installing MARC po file, only touch corresponding files
 416             my $marc     = ( $trans->{name} =~ /MARC/ )?"-m \"$trans->{name}\"":"";            # for MARC translations
 417             # if not installing MARC po file, ignore all MARC files
 418             @nomarc      = ( 'marc21', 'unimarc', 'normarc' ) if ( $trans->{name} !~ /MARC/ ); # hardcoded MARC variants
 419
 420             system
 421                 "$self->{process} install " .
 422                 "-i $trans_dir " .
 423                 "-o $lang_dir  ".
 424                 "-s $self->{path_po}/$self->{lang}$trans->{suffix} -r " .
 425                 "$marc " .
 426                 ( @files   ? ' -f ' . join ' -f ', @files : '') .
 427                 ( @nomarc  ? ' -n ' . join ' -n ', @nomarc : '');
 428         }
 429     }
 430 }
 431
 432
 433 sub update_tmpl {
 434     my ($self, $files) = @_;
 435
 436     say "Update templates" if $self->{verbose};
 437     for my $trans ( @{$self->{interface}} ) {
 438         my @files   = @$files;
 439         my @nomarc = ();
 440         print
 441             "  Update templates '$trans->{name}'\n",
 442             "    From: $trans->{dir}/en/\n",
 443             "    To  : $self->{path_po}/$self->{lang}$trans->{suffix}\n"
 444                 if $self->{verbose};
 445
 446         my $trans_dir = join("/en/ -i ",split(" ",$trans->{dir}))."/en/"; # multiple source dirs
 447         # if processing MARC po file, only use corresponding files
 448         my $marc      = ( $trans->{name} =~ /MARC/ )?"-m \"$trans->{name}\"":"";            # for MARC translations
 449         # if not processing MARC po file, ignore all MARC files
 450         @nomarc       = ( 'marc21', 'unimarc', 'normarc' ) if ( $trans->{name} !~ /MARC/ );      # hardcoded MARC variants
 451
 452         system
 453             "$self->{process} update " .
 454             "-i $trans_dir " .
 455             "-s $self->{path_po}/$self->{lang}$trans->{suffix} -r " .
 456             "$marc "     .
 457             ( @files   ? ' -f ' . join ' -f ', @files : '') .
 458             ( @nomarc  ? ' -n ' . join ' -n ', @nomarc : '');
 459     }
 460 }
 461
 462
 463 sub create_prefs {
 464     my $self = shift;
 465
 466     if ( -e $self->po_filename("-pref.po") ) {
 467         say "Preferences .po file already exists. Delete it if you want to recreate it.";
 468         return;
 469     }
 470     $self->get_po_from_prefs();
 471     $self->save_po();
 472 }
 473
 474 sub get_po_from_target {
 475     my $self   = shift;
 476     my $target = shift;
 477
 478     my $po;
 479     my $po_head = new Locale::PO;
 480     $po_head->{msgid}  = "\"\"";
 481     $po_head->{msgstr} = "".
 482         "Project-Id-Version: Koha Project - Installation files\\n" .
 483         "PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n" .
 484         "Last-Translator: FULL NAME <EMAIL\@ADDRESS>\\n" .
 485         "Language-Team: Koha Translation Team\\n" .
 486         "Language: ".$self->{lang}."\\n" .
 487         "MIME-Version: 1.0\\n" .
 488         "Content-Type: text/plain; charset=UTF-8\\n" .
 489         "Content-Transfer-Encoding: 8bit\\n";
 490
 491     my @dirs = @{ $target->{dirs} };
 492     my $intradir = $self->{context}->config('intranetdir');
 493     for my $dir ( @dirs ) {                                                     # each dir
 494         opendir( my $dh, "$intradir/$dir" ) or die ("Can't open $intradir/$dir");
 495         my @filelist = grep { $_ =~ m/\.yml/ } readdir($dh);                    # Just yaml files
 496         close($dh);
 497         for my $file ( @filelist ) {                                            # each file
 498             my $yaml   = LoadFile( "$intradir/$dir/$file" );
 499             my @tables = @{ $yaml->{'tables'} };
 500             my $tablec;
 501             for my $table ( @tables ) {                                         # each table
 502                 $tablec++;
 503                 my $table_name = ( keys %$table )[0];
 504                 my @translatable = @{ $table->{$table_name}->{translatable} };
 505                 my @rows = @{ $table->{$table_name}->{rows} };
 506                 my @multiline = @{ $table->{$table_name}->{'multiline'} };      # to check multiline values
 507                 my $rowc;
 508                 for my $row ( @rows ) {                                         # each row
 509                     $rowc++;
 510                     for my $field ( @translatable ) {                           # each field
 511                         if ( @multiline and grep { $_ eq $field } @multiline ) {    # multiline fields, only notices ATM
 512                             my $mulc;
 513                             foreach my $line ( @{$row->{$field}} ) {
 514                                 $mulc++;
 515                                 next if ( $line =~ /^(\s*<.*?>\s*$|^\s*\[.*?\]\s*|\s*)$/ );                     # discard pure html, TT, empty
 516                                 $line =~ s/(<<.*?>>|\[\%.*?\%\]|<.*?>)/\%s/g;                                   # put placeholders
 517                                 next if ( $line =~ /^(\s|%s|-|[[:punct:]]|\(|\))*$/ or length($line) < 2 );     # discard non strings
 518                                 if ( not $po->{ $line } ) {
 519                                     my $msg = new Locale::PO(
 520                                                 -msgid => $line, -msgstr => '',
 521                                                 -reference => "$dir/$file:$table_name:$tablec:row:$rowc:mul:$mulc" );
 522                                     $po->{ $line } = $msg;
 523                                 }
 524                             }
 525                         } else {
 526                             if ( defined $row->{$field} and length($row->{$field}) > 1                         # discard null values and small strings
 527                                  and not $po->{ $row->{$field} } ) {
 528                                 my $msg = new Locale::PO(
 529                                             -msgid => $row->{$field}, -msgstr => '',
 530                                             -reference => "$dir/$file:$table_name:$tablec:row:$rowc" );
 531                                 $po->{ $row->{$field} } = $msg;
 532                             }
 533                         }
 534                     }
 535                 }
 536             }
 537             my $desccount;
 538             for my $description ( @{ $yaml->{'description'} } ) {
 539                 $desccount++;
 540                 if ( length($description) > 1 and not $po->{ $description } ) {
 541                     my $msg = new Locale::PO(
 542                                 -msgid => $description, -msgstr => '',
 543                                 -reference => "$dir/$file:description:$desccount" );
 544                     $po->{ $description } = $msg;
 545                 }
 546             }
 547         }
 548     }
 549     $po->{''} = $po_head if ( $po );
 550
 551     return $po;
 552 }
 553
 554 sub create_installer {
 555     my $self = shift;
 556     return unless ( $self->{installer} );
 557
 558     say "Create installer translation files\n" if $self->{verbose};
 559
 560     my @targets = @{ $self->{installer} };             # each installer target (common,marc21,unimarc)
 561
 562     for my $target ( @targets ) {
 563         if ( -e $self->po_filename( $target->{suffix} ) ) {
 564             say "$self->{lang}$target->{suffix} file already exists. Delete it if you want to recreate it.";
 565             return;
 566         }
 567     }
 568
 569     for my $target ( @targets ) {
 570         my $po = get_po_from_target( $self, $target );
 571         # create output file only if there is something to write
 572         if ( $po ) {
 573             my $po_file = $self->po_filename( $target->{suffix} );
 574             Locale::PO->save_file_fromhash( $po_file, $po );
 575             say "Saved in file: ", $po_file if $self->{verbose};
 576         }
 577     }
 578 }
 579
 580 sub update_installer {
 581     my $self = shift;
 582     return unless ( $self->{installer} );
 583
 584     say "Update installer translation files\n" if $self->{verbose};
 585
 586     my @targets = @{ $self->{installer} };             # each installer target (common,marc21,unimarc)
 587
 588     for my $target ( @targets ) {
 589         return unless ( -e $self->po_filename( $target->{suffix} ) );
 590         my $po = get_po_from_target( $self, $target );
 591         # update file only if there is something to update
 592         if ( $po ) {
 593             my ( $fh, $po_temp ) = tempfile();
 594             binmode( $fh, ":encoding(UTF-8)" );
 595             Locale::PO->save_file_fromhash( $po_temp, $po );
 596             my $po_file = $self->po_filename( $target->{suffix} );
 597             eval {
 598                 my $st = system($self->{msgmerge}." ".($self->{verbose}?'':'-q').
 599                          " -s $po_file $po_temp -o - | ".$self->{msgattrib}." --no-obsolete -o $po_file");
 600             };
 601             say "Updated file: ", $po_file if $self->{verbose};
 602         }
 603     }
 604 }
 605
 606 sub translate_yaml {
 607     my $self   = shift;
 608     my $target = shift;
 609     my $srcyml = shift;
 610
 611     my $po_file = $self->po_filename( $target->{suffix} );
 612     return $srcyml unless ( -e $po_file );
 613
 614     my $po_ref  = Locale::PO->load_file_ashash( $po_file );
 615
 616     my $dstyml   = LoadFile( $srcyml );
 617
 618     # translate fields in table rows
 619     my @tables = @{ $dstyml->{'tables'} };
 620     for my $table ( @tables ) {                                                         # each table
 621         my $table_name = ( keys %$table )[0];
 622         my @translatable = @{ $table->{$table_name}->{translatable} };
 623         my @rows = @{ $table->{$table_name}->{rows} };
 624         my @multiline = @{ $table->{$table_name}->{'multiline'} };                      # to check multiline values
 625         for my $row ( @rows ) {                                                         # each row
 626             for my $field ( @translatable ) {                                           # each translatable field
 627                 if ( @multiline and grep { $_ eq $field } @multiline ) {                # multiline fields, only notices ATM
 628                     foreach my $line ( @{$row->{$field}} ) {
 629                         next if ( $line =~ /^(\s*<.*?>\s*$|^\s*\[.*?\]\s*|\s*)$/ );     # discard pure html, TT, empty
 630                         my @ttvar;
 631                         while ( $line =~ s/(<<.*?>>|\[\%.*?\%\]|<.*?>)/\%s/ ) {         # put placeholders, save matches
 632                             my $var = $1;
 633                             push @ttvar, $var;
 634                         }
 635
 636                         if ( $line =~ /^(\s|%s|-|[[:punct:]]|\(|\))*$/ ) {              # ignore non strings
 637                             while ( @ttvar ) {                                          # restore placeholders
 638                                 my $var = shift @ttvar;
 639                                 $line =~ s/\%s/$var/;
 640                             }
 641                             next;
 642                         } else {
 643                             my $po = $po_ref->{"\"$line\""};                            # quoted key
 644                             if ( $po  and not defined( $po->fuzzy() )                   # not fuzzy
 645                                       and length( $po->msgid() ) > 2                    # not empty msgid
 646                                       and length( $po->msgstr() ) > 2 ) {               # not empty msgstr
 647                                 $line = $po->dequote( $po->msgstr() );
 648                             }
 649                             while ( @ttvar ) {                                          # restore placeholders
 650                                 my $var = shift @ttvar;
 651                                 $line =~ s/\%s/$var/;
 652                             }
 653                         }
 654                     }
 655                 } else {
 656                     next unless defined $row->{$field};                                 # next if null value
 657                     my $po = $po_ref->{"\"$row->{$field}\""};                           # quoted key
 658                     if ( $po  and not defined( $po->fuzzy() )                           # not fuzzy
 659                               and length( $po->msgid() ) > 2                            # not empty msgid
 660                               and length( $po->msgstr() ) > 2 ) {                       # not empty msgstr
 661                         $row->{$field} = $po->dequote( $po->msgstr() );
 662                     }
 663                 }
 664             }
 665         }
 666     }
 667
 668     # translate descriptions
 669     for my $description ( @{ $dstyml->{'description'} } ) {
 670         my $po = $po_ref->{"\"$description\""};
 671         if ( $po  and not defined( $po->fuzzy() )
 672                   and length( $po->msgid() ) > 2
 673                   and length( $po->msgstr() ) > 2 ) {
 674             $description = $po->dequote( $po->msgstr() );
 675         }
 676     }
 677
 678     return $dstyml;
 679 }
 680
 681 sub install_installer {
 682     my $self = shift;
 683     return unless ( $self->{installer} );
 684
 685     my $intradir  = $self->{context}->config('intranetdir');
 686     my $db_scheme = $self->{context}->config('db_scheme');
 687     my $langdir  = "$intradir/installer/data/$db_scheme/$self->{lang}";
 688     if ( -d $langdir ) {
 689         say "$self->{lang} installer dir $langdir already exists.\nDelete it if you want to recreate it." if $self->{verbose};
 690         return;
 691     }
 692
 693     say "Install installer files\n" if $self->{verbose};
 694
 695     for my $target ( @{ $self->{installer} } ) {
 696         return unless ( -e $self->po_filename( $target->{suffix} ) );
 697         for my $dir ( @{ $target->{dirs} } ) {
 698             ( my $tdir = "$dir" ) =~ s|/en/|/$self->{lang}/|;
 699             make_path("$intradir/$tdir");
 700
 701             opendir( my $dh, "$intradir/$dir" ) or die ("Can't open $intradir/$dir");
 702             my @files = grep { ! /^\.+$/ } readdir($dh);
 703             close($dh);
 704
 705             for my $file ( @files ) {
 706                 if ( $file =~ /yml$/ ) {
 707                     my $translated_yaml = translate_yaml( $self, $target, "$intradir/$dir/$file" );
 708                     open(my $fh, ">:encoding(UTF-8)", "$intradir/$tdir/$file");
 709                     DumpFile( $fh, $translated_yaml );
 710                     close($fh);
 711                 } else {
 712                     File::Copy::copy( "$intradir/$dir/$file", "$intradir/$tdir/$file" );
 713                 }
 714             }
 715         }
 716     }
 717 }
 718
 719 sub create_tmpl {
 720     my ($self, $files) = @_;
 721
 722     say "Create templates\n" if $self->{verbose};
 723     for my $trans ( @{$self->{interface}} ) {
 724         my @files   = @$files;
 725         my @nomarc = ();
 726         print
 727             "  Create templates .po files for '$trans->{name}'\n",
 728             "    From: $trans->{dir}/en/\n",
 729             "    To  : $self->{path_po}/$self->{lang}$trans->{suffix}\n"
 730                 if $self->{verbose};
 731
 732         my $trans_dir = join("/en/ -i ",split(" ",$trans->{dir}))."/en/"; # multiple source dirs
 733         # if processing MARC po file, only use corresponding files
 734         my $marc      = ( $trans->{name} =~ /MARC/ )?"-m \"$trans->{name}\"":"";            # for MARC translations
 735         # if not processing MARC po file, ignore all MARC files
 736         @nomarc       = ( 'marc21', 'unimarc', 'normarc' ) if ( $trans->{name} !~ /MARC/ ); # hardcoded MARC variants
 737
 738         system
 739             "$self->{process} create " .
 740             "-i $trans_dir " .
 741             "-s $self->{path_po}/$self->{lang}$trans->{suffix} -r " .
 742             "$marc " .
 743             ( @files  ? ' -f ' . join ' -f ', @files   : '') .
 744             ( @nomarc ? ' -n ' . join ' -n ', @nomarc : '');
 745     }
 746 }
 747
 748 sub locale_name {
 749     my $self = shift;
 750
 751     my ($language, $region, $country) = split /-/, $self->{lang};
 752     $country //= $region;
 753     my $locale = $language;
 754     if ($country && length($country) == 2) {
 755         $locale .= '_' . $country;
 756     }
 757
 758     return $locale;
 759 }
 760
 761 sub create_messages {
 762     my $self = shift;
 763
 764     my $pot = "$Bin/$self->{domain}.pot";
 765     my $po = "$self->{path_po}/$self->{lang}-messages.po";
 766     my $js_pot = "$self->{domain}-js.pot";
 767     my $js_po = "$self->{path_po}/$self->{lang}-messages-js.po";
 768
 769     unless ( -f $pot && -f $js_pot ) {
 770         $self->extract_messages();
 771     }
 772
 773     say "Create messages ($self->{lang})" if $self->{verbose};
 774     my $locale = $self->locale_name();
 775     system "$self->{msginit} -i $pot -o $po -l $locale --no-translator 2> /dev/null";
 776     warn "Problems creating $pot ".$? if ( $? == -1 );
 777     system "$self->{msginit} -i $js_pot -o $js_po -l $locale --no-translator 2> /dev/null";
 778     warn "Problems creating $js_pot ".$? if ( $? == -1 );
 779
 780     # If msginit failed to correctly set Plural-Forms, set a default one
 781     system "$self->{sed} --in-place "
 782         . "--expression='s/Plural-Forms: nplurals=INTEGER; plural=EXPRESSION/Plural-Forms: nplurals=2; plural=(n != 1)/' "
 783         . "$po $js_po";
 784 }
 785
 786 sub update_messages {
 787     my $self = shift;
 788
 789     my $pot = "$Bin/$self->{domain}.pot";
 790     my $po = "$self->{path_po}/$self->{lang}-messages.po";
 791     my $js_pot = "$self->{domain}-js.pot";
 792     my $js_po = "$self->{path_po}/$self->{lang}-messages-js.po";
 793
 794     unless ( -f $pot && -f $js_pot ) {
 795         $self->extract_messages();
 796     }
 797
 798     if ( -f $po && -f $js_pot ) {
 799         say "Update messages ($self->{lang})" if $self->{verbose};
 800         system "$self->{msgmerge} --backup=off --quiet -U $po $pot";
 801         system "$self->{msgmerge} --backup=off --quiet -U $js_po $js_pot";
 802     } else {
 803         $self->create_messages();
 804     }
 805 }
 806
 807 sub extract_messages_from_templates {
 808     my ($self, $tempdir, $type, @files) = @_;
 809
 810     my $htdocs = $type eq 'intranet' ? 'intrahtdocs' : 'opachtdocs';
 811     my $dir = $self->{context}->config($htdocs);
 812     my @keywords = qw(t tx tn txn tnx tp tpx tnp tnpx);
 813     my $parser = Template::Parser->new();
 814
 815     foreach my $file (@files) {
 816         say "Extract messages from $file" if $self->{verbose};
 817         my $template = read_file(File::Spec->catfile($dir, $file));
 818
 819         # No need to process a file that doesn't use the i18n.inc file.
 820         next unless $template =~ /i18n\.inc/;
 821
 822         my $data = $parser->parse($template);
 823         unless ($data) {
 824             warn "Error at $file : " . $parser->error();
 825             next;
 826         }
 827
 828         my $destfile = $type eq 'intranet' ?
 829             File::Spec->catfile($tempdir, 'koha-tmpl', 'intranet-tmpl', $file) :
 830             File::Spec->catfile($tempdir, 'koha-tmpl', 'opac-tmpl', $file);
 831
 832         make_path(dirname($destfile));
 833         open my $fh, '>', $destfile;
 834
 835         my @blocks = ($data->{BLOCK}, values %{ $data->{DEFBLOCKS} });
 836         foreach my $block (@blocks) {
 837             my $document = PPI::Document->new(\$block);
 838
 839             # [% t('foo') %] is compiled to
 840             # $output .= $stash->get(['t', ['foo']]);
 841             # We try to find all nodes corresponding to keyword (here 't')
 842             my $nodes = $document->find(sub {
 843                 my ($topnode, $element) = @_;
 844
 845                 # Filter out non-valid keywords
 846                 return 0 unless ($element->isa('PPI::Token::Quote::Single'));
 847                 return 0 unless (grep {$element->content eq qq{'$_'}} @keywords);
 848
 849                 # keyword (e.g. 't') should be the first element of the arrayref
 850                 # passed to $stash->get()
 851                 return 0 if $element->sprevious_sibling;
 852
 853                 return 0 unless $element->snext_sibling
 854                     && $element->snext_sibling->snext_sibling
 855                     && $element->snext_sibling->snext_sibling->isa('PPI::Structure::Constructor');
 856
 857                 # Check that it's indeed a call to $stash->get()
 858                 my $statement = $element->statement->parent->statement->parent->statement;
 859                 return 0 unless grep { $_->isa('PPI::Token::Symbol') && $_->content eq '$stash' } $statement->children;
 860                 return 0 unless grep { $_->isa('PPI::Token::Operator') && $_->content eq '->' } $statement->children;
 861                 return 0 unless grep { $_->isa('PPI::Token::Word') && $_->content eq 'get' } $statement->children;
 862
 863                 return 1;
 864             });
 865
 866             next unless $nodes;
 867
 868             # Write the Perl equivalent of calls to t* functions family, so
 869             # xgettext can extract the strings correctly
 870             foreach my $node (@$nodes) {
 871                 my @args = map {
 872                     $_->significant && !$_->isa('PPI::Token::Operator') ? $_->content : ()
 873                 } $node->snext_sibling->snext_sibling->find_first('PPI::Statement')->children;
 874
 875                 my $keyword = $node->content;
 876                 $keyword =~ s/^'t(.*)'$/__$1/;
 877
 878                 # Only keep required args to have a clean output
 879                 my @required_args = shift @args;
 880                 push @required_args, shift @args if $keyword =~ /n/;
 881                 push @required_args, shift @args if $keyword =~ /p/;
 882
 883                 say $fh "$keyword(" . join(', ', @required_args) . ");";
 884             }
 885
 886         }
 887
 888         close $fh;
 889     }
 890
 891     return $tempdir;
 892 }
 893
 894 sub extract_messages {
 895     my $self = shift;
 896
 897     say "Extract messages into POT file" if $self->{verbose};
 898
 899     my $intranetdir = $self->{context}->config('intranetdir');
 900     my $opacdir = $self->{context}->config('opacdir');
 901
 902     # Find common ancestor directory
 903     my @intranetdirs = File::Spec->splitdir($intranetdir);
 904     my @opacdirs = File::Spec->splitdir($opacdir);
 905     my @basedirs;
 906     while (@intranetdirs and @opacdirs) {
 907         my ($dir1, $dir2) = (shift @intranetdirs, shift @opacdirs);
 908         last if $dir1 ne $dir2;
 909         push @basedirs, $dir1;
 910     }
 911     my $basedir = File::Spec->catdir(@basedirs);
 912
 913     my @files_to_scan;
 914     my @directories_to_scan = ('.');
 915     my @blacklist = map { File::Spec->catdir(@intranetdirs, $_) } qw(blib koha-tmpl skel tmp t);
 916     while (@directories_to_scan) {
 917         my $dir = shift @directories_to_scan;
 918         opendir DIR, File::Spec->catdir($basedir, $dir) or die "Unable to open $dir: $!";
 919         foreach my $entry (readdir DIR) {
 920             next if $entry =~ /^\./;
 921             my $relentry = File::Spec->catfile($dir, $entry);
 922             my $abspath = File::Spec->catfile($basedir, $relentry);
 923             if (-d $abspath and not grep { $_ eq $relentry } @blacklist) {
 924                 push @directories_to_scan, $relentry;
 925             } elsif (-f $abspath and $relentry =~ /\.(pl|pm)$/) {
 926                 push @files_to_scan, $relentry;
 927             }
 928         }
 929     }
 930
 931     my $intrahtdocs = $self->{context}->config('intrahtdocs');
 932     my $opachtdocs = $self->{context}->config('opachtdocs');
 933
 934     my @intranet_tt_files;
 935     find(sub {
 936         if ($File::Find::dir =~ m|/en/| && $_ =~ m/\.(tt|inc)$/) {
 937             my $filename = $File::Find::name;
 938             $filename =~ s|^$intrahtdocs/||;
 939             push @intranet_tt_files, $filename;
 940         }
 941     }, $intrahtdocs);
 942
 943     my @opac_tt_files;
 944     find(sub {
 945         if ($File::Find::dir =~ m|/en/| && $_ =~ m/\.(tt|inc)$/) {
 946             my $filename = $File::Find::name;
 947             $filename =~ s|^$opachtdocs/||;
 948             push @opac_tt_files, $filename;
 949         }
 950     }, $opachtdocs);
 951
 952     my $tempdir = tempdir('Koha-translate-XXXX', TMPDIR => 1, CLEANUP => 1);
 953     $self->extract_messages_from_templates($tempdir, 'intranet', @intranet_tt_files);
 954     $self->extract_messages_from_templates($tempdir, 'opac', @opac_tt_files);
 955
 956     @intranet_tt_files = map { File::Spec->catfile('koha-tmpl', 'intranet-tmpl', $_) } @intranet_tt_files;
 957     @opac_tt_files = map { File::Spec->catfile('koha-tmpl', 'opac-tmpl', $_) } @opac_tt_files;
 958     my @tt_files = grep { -e File::Spec->catfile($tempdir, $_) } @intranet_tt_files, @opac_tt_files;
 959
 960     push @files_to_scan, @tt_files;
 961
 962     my $xgettext_common_args = "--force-po --from-code=UTF-8 "
 963         . "--package-name=Koha --package-version='' "
 964         . "-k -k__ -k__x -k__n:1,2 -k__nx:1,2 -k__xn:1,2 -k__p:1c,2 "
 965         . "-k__px:1c,2 -k__np:1c,2,3 -k__npx:1c,2,3 -kN__ -kN__n:1,2 "
 966         . "-kN__p:1c,2 -kN__np:1c,2,3 ";
 967     my $xgettext_cmd = "$self->{xgettext} -L Perl $xgettext_common_args "
 968         . "-o $Bin/$self->{domain}.pot -D $tempdir -D $basedir";
 969     $xgettext_cmd .= " $_" foreach (@files_to_scan);
 970
 971     if (system($xgettext_cmd) != 0) {
 972         die "system call failed: $xgettext_cmd";
 973     }
 974
 975     my @js_dirs = (
 976         "$intrahtdocs/prog/js",
 977         "$opachtdocs/bootstrap/js",
 978     );
 979
 980     my @js_files;
 981     find(sub {
 982         if ($_ =~ m/\.js$/) {
 983             my $filename = $File::Find::name;
 984             $filename =~ s|^$intranetdir/||;
 985             push @js_files, $filename;
 986         }
 987     }, @js_dirs);
 988
 989     $xgettext_cmd = "$self->{xgettext} -L JavaScript $xgettext_common_args "
 990         . "-o $Bin/$self->{domain}-js.pot -D $intranetdir";
 991     $xgettext_cmd .= " $_" foreach (@js_files);
 992
 993     if (system($xgettext_cmd) != 0) {
 994         die "system call failed: $xgettext_cmd";
 995     }
 996
 997     my $replace_charset_cmd = "$self->{sed} --in-place " .
 998         "--expression='s/charset=CHARSET/charset=UTF-8/' " .
 999         "$Bin/$self->{domain}.pot $Bin/$self->{domain}-js.pot";
1000     if (system($replace_charset_cmd) != 0) {
1001         die "system call failed: $replace_charset_cmd";
1002     }
1003 }
1004
1005 sub install_messages {
1006     my ($self) = @_;
1007
1008     my $locale = $self->locale_name();
1009     my $modir = "$self->{path_po}/$locale/LC_MESSAGES";
1010     my $pofile = "$self->{path_po}/$self->{lang}-messages.po";
1011     my $mofile = "$modir/$self->{domain}.mo";
1012     my $js_pofile = "$self->{path_po}/$self->{lang}-messages-js.po";
1013
1014     unless ( -f $pofile && -f $js_pofile ) {
1015         $self->create_messages();
1016     }
1017     say "Install messages ($locale)" if $self->{verbose};
1018     make_path($modir);
1019     system "$self->{msgfmt} -o $mofile $pofile";
1020
1021     my $js_locale_data = 'var json_locale_data = {"Koha":' . `$self->{po2json} $js_pofile` . '};';
1022     my $progdir = $self->{context}->config('intrahtdocs') . '/prog';
1023     mkdir "$progdir/$self->{lang}/js";
1024     open my $fh, '>', "$progdir/$self->{lang}/js/locale_data.js";
1025     print $fh $js_locale_data;
1026     close $fh;
1027
1028     my $opachtdocs = $self->{context}->config('opachtdocs');
1029     opendir(my $dh, $opachtdocs);
1030     for my $theme ( grep { not /^\.|lib|xslt/ } readdir($dh) ) {
1031         mkdir "$opachtdocs/$theme/$self->{lang}/js";
1032         open my $fh, '>', "$opachtdocs/$theme/$self->{lang}/js/locale_data.js";
1033         print $fh $js_locale_data;
1034         close $fh;
1035     }
1036 }
1037
1038 sub remove_pot {
1039     my $self = shift;
1040
1041     unlink "$Bin/$self->{domain}.pot";
1042     unlink "$Bin/$self->{domain}-js.pot";
1043 }
1044
1045 sub compress {
1046     my ($self, $files) = @_;
1047     my @langs = $self->{lang} ? ($self->{lang}) : $self->get_all_langs();
1048     for my $lang ( @langs ) {
1049         $self->set_lang( $lang );
1050         opendir( my $dh, $self->{path_po} );
1051         my @files = grep { $_ =~ /^$self->{lang}.*po$/ } readdir $dh;
1052         foreach my $file ( @files ) {
1053             say "Compress file $file" if $self->{verbose};
1054             system "$self->{gzip} -9 $self->{path_po}/$file";
1055         }
1056     }
1057 }
1058
1059 sub uncompress {
1060     my ($self, $files) = @_;
1061     my @langs = $self->{lang} ? ($self->{lang}) : $self->get_all_langs();
1062     for my $lang ( @langs ) {
1063         opendir( my $dh, $self->{path_po} );
1064         $self->set_lang( $lang );
1065         my @files = grep { $_ =~ /^$self->{lang}.*po.gz$/ } readdir $dh;
1066         foreach my $file ( @files ) {
1067             say "Uncompress file $file" if $self->{verbose};
1068             system "$self->{gunzip} $self->{path_po}/$file";
1069         }
1070     }
1071 }
1072
1073 sub install {
1074     my ($self, $files) = @_;
1075     return unless $self->{lang};
1076     $self->uncompress();
1077     $self->install_tmpl($files) unless $self->{pref_only};
1078     $self->install_prefs();
1079     $self->install_messages();
1080     $self->remove_pot();
1081     $self->install_installer();
1082 }
1083
1084
1085 sub get_all_langs {
1086     my $self = shift;
1087     opendir( my $dh, $self->{path_po} );
1088     my @files = grep { $_ =~ /-pref.(po|po.gz)$/ }
1089         readdir $dh;
1090     @files = map { $_ =~ s/-pref.(po|po.gz)$//r } @files;
1091 }
1092
1093
1094 sub update {
1095     my ($self, $files) = @_;
1096     my @langs = $self->{lang} ? ($self->{lang}) : $self->get_all_langs();
1097     for my $lang ( @langs ) {
1098         $self->set_lang( $lang );
1099         $self->uncompress();
1100         $self->update_tmpl($files) unless $self->{pref_only};
1101         $self->update_prefs();
1102         $self->update_messages();
1103         $self->update_installer();
1104     }
1105     $self->remove_pot();
1106 }
1107
1108
1109 sub create {
1110     my ($self, $files) = @_;
1111     return unless $self->{lang};
1112     $self->create_tmpl($files) unless $self->{pref_only};
1113     $self->create_prefs();
1114     $self->create_messages();
1115     $self->remove_pot();
1116     $self->create_installer();
1117 }
1118
1119
1120
1121 1;
1122
1123
1124 =head1 NAME
1125
1126 LangInstaller.pm - Handle templates and preferences translation
1127
1128 =head1 SYNOPSYS
1129
1130   my $installer = LangInstaller->new( 'fr-FR' );
1131   $installer->create();
1132   $installer->update();
1133   $installer->install();
1134   for my $lang ( @{$installer->{langs} ) {
1135     $installer->set_lang( $lan );
1136     $installer->install();
1137   }
1138
1139 =head1 METHODS
1140
1141 =head2 new
1142
1143 Create a new instance of the installer object.
1144
1145 =head2 create
1146
1147 For the current language, create .po files for templates and preferences based
1148 of the english ('en') version.
1149
1150 =head2 update
1151
1152 For the current language, update .po files.
1153
1154 =head2 install
1155
1156 For the current langage C<$self->{lang}, use .po files to translate the english
1157 version of templates and preferences files and copy those files in the
1158 appropriate directory.
1159
1160 =over
1161
1162 =item translate create F<lang>
1163
1164 Create 4 kinds of .po files in F<po> subdirectory:
1165 (1) one from each theme on opac pages templates,
1166 (2) intranet templates,
1167 (3) preferences, and
1168 (4) one for each MARC dialect.
1169
1170
1171 =over
1172
1173 =item F<lang>-opac-{theme}.po
1174
1175 Contains extracted text from english (en) OPAC templates found in
1176 <KOHA_ROOT>/koha-tmpl/opac-tmpl/{theme}/en/ directory.
1177
1178 =item F<lang>-staff-prog.po
1179
1180 Contains extracted text from english (en) intranet templates found in
1181 <KOHA_ROOT>/koha-tmpl/intranet-tmpl/prog/en/ directory.
1182
1183 =item F<lang>-pref.po
1184
1185 Contains extracted text from english (en) preferences. They are found in files
1186 located in <KOHA_ROOT>/koha-tmpl/intranet-tmpl/prog/en/admin/preferences
1187 directory.
1188
1189 =item F<lang>-marc-{MARC}.po
1190
1191 Contains extracted text from english (en) files from opac and intranet,
1192 related with MARC dialects.
1193
1194 =back
1195
1196 =item pref-trans update F<lang>
1197
1198 Update .po files in F<po> directory, named F<lang>-*.po.
1199
1200 =item pref-trans install F<lang>
1201
1202 =back
1203
1204 =cut
1205