# file KLEIDER/web/src/localization/Pipe.pm
# symlink KLEIDER/web/src/localization/Translate/Pipe.pm
# Übersetzer in separatem Prozess über Pipes ansprechen
# 2015-08-09 Herbert Schiemann <h.schiemann@herbaer.de>
# GPL Version 2 oder neuer

package Herbaer::Translate::Pipe ;
use parent Herbaer::Translate::Base ;
use Cwd qw(getcwd) ;
use File::Spec::Functions qw(catfile) ;
use utf8;

sub new {
   my ($class
       , $base
       , $trname
       , $debug
      ) = @_;
   $base ||= getcwd();
   if ($debug) {
      print STDERR "Herbaer::Translate::Pipe::new\n";
   }
   my $self = {
      "dbg"  => $debug,
      "req"  => catfile ($base, "request"),
      "resp" => catfile ($base, "response"),
   };
   trname ($self, $trname) if $trname;
   return bless ($self, $class);
}

sub _send_request {
   my ($self, $request) = @_;
   my $debug = $self -> {"dbg"};
   my $reqp  = $self -> {"req"};
   my $respp = $self -> {"resp"};
   print STDERR "_send_request $request\n" if $debug;
   if (! -p $reqp) {
      # Der Server-Prozess braucht die Zeit, die Pipes anzulegen.
      sleep (1);
      if (! -p $reqp) {
         print STDERR "$reqp ist keine Pipe\n" if $debug;
         return;
      }
   }
   if (! -p $respp) {
      print STDERR "$respp ist keine Pipe\n" if $debug;
      return;
   }
   my $reqh;   # request handle
   if (!open ($reqh, ">:encoding(utf-8)", $reqp)) {
      print STDERR "Kann request-Pipe $reqp nicht öffnen: $!\n" if $debug;
      return;
   }
   my $resph; # response handle
   if (!open ($resph, "<:encoding(utf-8)", $respp)) {
      print STDERR "Kann response-Pipe $respp nicht öffnen: $!\n" if $debug;
      close $reqh;
      return;
   }
   print $reqh $request;
   close $reqh;
   my $response = <$resph>;
   close $resph;
   $response =~ s/\n$// ;
   return $response;
} # _send_request

# "\" 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 translate {
   my ($self, $text, $srl, $tgl) = @_ ;
   if ($self -> {"dbg"}) {
      print STDERR "Herbaer::Translate::Pipe::translate\n";
   }
   # Parameter prüfen
   $text || return;
   $srl  || return;
   $tgl  || return;
   $srl =~ s/-.*// ;
   $srl = lc ($srl);
   $tgl =~ s/-.*// ;
   $tgl = lc ($tgl);
   return _decode ($self -> _send_request (join (":",
      "translate", _encode ($text), $srl, $tgl
   )));
} # translate

sub learn {
   my ($self, $text, $srl, $tgl, $tt) = @_ ;
   if ($self -> {"dbg"}) {
      print STDERR "Herbaer::Translate::Pipe::learn\n";
   }
   return $self -> _send_request (join (":",
      "learn", _encode ($text), $srl, $tgl, _encode ($tt)
   ));
} # learn

sub finish {
   my $self = shift;
   if ($self -> {"dbg"}) {
      print STDERR "Herbaer::Translate::Pipe::finish\n";
   }
   return $self -> _send_request ("finish");
} # finish

# setzt die Übersetzer-Kennung
sub trname {
   my ($self, $trname) = @_;
   if ($self -> {"dbg"}) {
      print STDERR "Herbaer::Translate::Pipe::trname $trname\n";
   }
   return _send_request ($self, "trname:$trname");
} # trname

# liefert den Übersetzer-Namen
sub translator_name {
   my $self = shift;
   if ($self -> {"dbg"}) {
      print STDERR "Herbaer::Translate::Pipe::translator_name\n";
   }
   my $r = _send_request ($self, "translator_name") || "";
   if ( $r =~ s/^OK\s+// ) {
      return "pipe_$r";
   }
   else {
      return "pipe_error";
   }
} # translator_name

sub stop {
   my $self = shift;
   if ($self -> {"dbg"}) {
      print STDERR "Herbaer::Translate::Pipe::stop\n";
   }
   return $self -> _send_request ("stop");
} # stop

1;
# end of file KLEIDER/web/src/localization/Pipe.pm