#!/usr/bin/perl -w
# file KLEIDER/web/src/localization/pipe_srv.pl
# Server-Prozess für die maschinelle Übersetzung, Kommunikation mittels benannter Pipes
# 2015-08-07 Herbert Schiemann <h.schiemann@herbaer.de>
# 2020-04-02 Anpassung an Perl 5.24.1
# GPL Version 2 oder neuer

package main;

use utf8 ;
use Cwd qw(realpath) ;
use Herbaer::Readargs ;
use Herbaer::Replace ;
use Herbaer::Translate ;
use POSIX ;

binmode (STDOUT, "encoding(utf-8)");
binmode (STDERR, "encoding(utf-8)");

my $basedir = realpath ($0);
$basedir =~ s/\/src\/localization\/.*// ;

# Hash der Kommandozeilen-Argumente
my $args = {
   "[cnt]verbose" => 0,
   "base"         => "$basedir/pipe",     # Basisverzeichnis für Pipes
   "req"          => "\${base}/request",  # Request-Pfad
   "resp"         => "\${base}/response", # Response-Pfad
   "trname"       => "default",           # Übersetzer
   "errsleep"     => 1 ,                  # Warte-Sekunden im Fehlerfall
};

# gibt die Version nach STDOUT aus
sub version {
   print <<'VERSION' ;
pipe_srv.pl v20200402
Server-Prozess für die maschinelle Übersetzung, Kommunikation mittels benannter Pipes
(C) 2015 Herbert Schiemann <h.schiemann@herbaer.de>
VERSION
};
$args -> {"[sr]version"} = sub { version (); exit 0; };

$args -> {"[sr]help"} = sub {
   version ();
   set_default ($args);
   print_message_with_values (<<'HELP', $args);
pipe_srv.pl [Optionen]
--[no_]verbose      Umfang der Meldungen ${[cnt]verbose}
--base     BASE     Platzhalter in den anderen Argumenten ${base}
--req      REQ      Request-Pfad ${req}
--resp     RESP     Response-Pfad ${rest}
--trname   TRNAME   Übersetzer ${trname}
--errsleep ERRSLEEP Wartezeit in Sekunden, nachdem kein Request ansteht ${errsleep}
HELP
   exit 0;
};

# Platzhalter in den Argumenten einsetzen
sub set_default {
   my $args = shift;
   my $key;
   for $key (qw(base req resp trname)) {
      $args -> {$key} = replace ($args -> {$key}, $args);
   }
} # set_default

my $trans;             # der Übersetzer
my $wait_request = 1;  # auf einen weiteren Request warten?

read_args ($args);
set_default ($args);

# "\" wird durch "\\",
# ":" wird durch "\c",
# Zeilenende durch "\n" ersetzt
sub encode {
   my $t = shift;
   $t =~ s/\\/\\\\/g;
   $t =~ s/\n/\\n/g;
   $t =~ s/:/\\c/g;
   return $t;
} # encode

# macht _encode rückgängig
sub decode {
   my $t = shift;
   $t =~ s/\\(.)/$1 eq "n" ? "\n" : $1 eq "c" ? ":" : $1/ge;
   return $t;
} # decode

sub check_pipes {
   my $args = shift;
   my $verb = $args -> {"[cnt]verbose"};
   my $k;
   for $k (qw(req resp)) {
      my $p = $args -> {$k};
      if (! -p $p) {
         if (! mkfifo ($p, 0700)) {
            print STDERR "Kann Pipe $p nicht erstellen\n" if $verb;
            return 0;
         }
      }
   }
   1;
} # check_pipes

sub rm_pipes {
   my $args = shift;
   my $verb = $args -> {"[cnt]verbose"};
   my $k;
   for $k (qw(req resp)) {
      my $p = $args -> {$k};
      if (-p $p && ! unlink ($p)) {
         print STDERR "Kann Pipe $p nicht entfernen\n" if $verb;
      }
   }
   1;
} # rm_pipes

# behandelt eine Anfrage
sub handle_request  {
   my $args = shift ;
   my $verb = $args -> {"[cnt]verbose"};
   my $reqp  = $args -> {"req"};
   my $respp = $args -> {"resp"};
   my $reqh;
   print STDERR "wait for request\n" if $verb > 1;
   if (! open ($reqh, "<:encoding(utf-8)", $reqp)) {
      print STDERR "Kann Request-Pipe $reqp nicht öffnen\n" if $verb;
      sleep ($args -> {"errsleep"});
      return 0;
   }
   my $resph;
   if (! open ($resph, ">:encoding(utf-8)", $respp)) {
      print STDERR "Kann Response-Pipe $respp nicht öffnen\n" if $verb;
      return 0;
   }
   my $req = <$reqh>;
   close $reqh;
   if ($req) {
      print STDERR "REQUEST $req\n" if $verb;
      my $resp = response_to_request ($args, $req);
      print STDERR "RESPONSE $resp\n" if $verb;
      print $resph "$resp\n";
   }
   close $resph;
   return 1;
} # handle_request

sub response_to_request {
   my ($args, $req) = @_;
   my $p;
   my $st;
   my $sl;
   my $tt;
   my $tl;
   if ($req =~ /^trname:(.*)$/) {
      $p = $1;
      if ($args -> {"trname"} ne $p) {
         if ($trans) {
            $trans -> finish ();
            $trans = undef;
         }
         $args -> {"trname"} = $p;
         return "OK trname $p";
      }
   }
   elsif ($req =~ /^translate:([^:]+):([^:]+):([^:]+)$/) {
      $trans = new Herbaer::Translate ($args -> {"trname"}) unless $trans;
      if ($trans) {
         $st = $1;
         $sl = $2;
         $tl = $3;
         $tt = $trans -> translate (decode ($st), $sl, $tl) || "";
         return encode ($tt);
      }
      else {
         return "";
      }
   }
   elsif ($req =~ /^learn:([^:]+):([^:]+):([^:]+):([^:]+)$/) {
      $trans = new Herbaer::Translate ($args -> {"trname"}) unless $trans;
      if ($trans) {
         $st = $1;
         $sl = $2;
         $tl = $3;
         $tt = $4;
         $trans -> learn (decode ($st), $sl, $tl, decode ($tt));
         return "OK learn";
      }
      else {
         return "ERROR no translator";
      }
   }
   elsif ($req eq "finish") {
      if ($trans) {
         $trans -> finish ();
         return "OK finish";
      }
      else {
         return "WARNING no translator";
      }
   }
   elsif ($req eq "translator_name") {
      if ($trans) {
         return "OK " . $trans -> translator_name ();
      }
      else {
         return "WARNING no translator";
      }
   }
   elsif ($req eq "stop") {
      $trans -> finish () if $trans;
      $wait_request = 0;
      return "OK";
   }
   elsif ($req eq "verbose") {
      ++$args -> {"[cnt]verbose"};
      return "OK " . $args -> {"[cnt]verbose"};
   }
   elsif ($req eq "silent") {
      $args -> {"[cnt]verbose"} = 0;
      return "OK silent";
   }
   else {
      return "ERROR unknown command";
   }
} # response_to_request

check_pipes ($args);
while ($wait_request) {
  handle_request ($args);
}
rm_pipes ($args);
# end of file KLEIDER/web/src/localization/pipe_srv.pl