#  Copyright (c) 1997-2005
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  This program is free software; you can redistribute it and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation; either version 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#----------------------------------------------------------------------------
#  $Project: polymake $$Id: Server.pm 7556 2007-01-12 17:36:36Z gawrilow $

use strict;
use namespaces;
use integer;

package Poly::Server;
use Socket;
use Fcntl;
use POSIX qw( :signal_h );
use Poly::File;
use Poly::Pipe;

####################################################################################

my $sa_pipe=new POSIX::SigAction
   sub {
      die "\n";		# leave eval{} in serve()
   };
my $sa_pipe_save=new POSIX::SigAction('DEFAULT');

my $expand_unsigned=$Config::Config{use64bitint};
my $unsigned_minus_one=$expand_unsigned && (1<<32)-1;

sub serve($;$$) {
   my ($socket, $objects, $loose)=@_;
   $objects ||= [ ];
   $loose ||= [ ];

   my $sel=select;  select $socket;  $|=1;
   sigaction SIGPIPE, $sa_pipe, $sa_pipe_save;

   eval {
      local $_;

      while (<$socket>) {
	 $_ .= <$socket> while length($_)<=5;	# the packed index can occasionally contain \n
	 chomp;
	 my ($prefix, $index, $command)=unpack 'ANA4', $_;
	 $index=-1 if $expand_unsigned && $index==$unsigned_minus_one;
	 dbg_print( "client> $command (#$index)" ) if $Switches::d;

	 if ($prefix ne "\e") {
	    die "unrecognized client output: '$_'\n";
	 }

	 if ($command eq "open") {
	    my $arg=<$socket>; chomp $arg;
	    my ($file, $proto_name)=split /\s+/, $arg;
	    dbg_print( "client> file=($file) ", $proto_name ? "type=($proto_name)" : "" ) if $Switches::d;

	    eval {
	       my $proto=defined($proto_name) && do {
		  Poly::Application::prototype_lookup($proto_name)
		     or die "unknown object type $proto_name\n";
	       };
	       $objects->[$index]=load Object($file);
	       die "object stored in $file does not match the required object type ", $proto->name, "\n"
	          if $proto && !$objects->[$index]->isa($proto->object_type);
	    };
	    if ($@) {
	       print "\c@$@\n";
	    } else {
	       print "\cA";
	       $objects->[$index]->begin_transaction->keep_overwritten=1;
	    }

	 } elsif ($command eq "new_") {
	    my $arg=<$socket>; chomp $arg;
	    my ($file, $proto_name)=((split /\s+/, $arg), "default");
	    dbg_print( "client> file=($file) type=($proto_name)" ) if $Switches::d;

	    eval {
	       my $proto=Poly::Application::prototype_lookup($proto_name)
	       or die "unknown object type $proto_name\n";
	       $objects->[$index]=$proto->object_type->new(length($file) ? new File($file) : ());
	    };
	    if ($@) {
	       print "\c@$@\n";
	    } else {
	       print "\cA";
	       $objects->[$index]->begin_transaction;
	    }

	 } elsif ($index > $#$objects) {
	    die "$command: index $index out of range\n";

	 } elsif ($command eq "give") {
	    my $req=<$socket>; chomp $req;
	    dbg_print( "client> req=($req)" ) if $Switches::d;

	    my ($prop_name, @data);
	    if ($req =~ /^\#(\d+)$/) {
	       die "invalid scratch property '$req'\n" if $1>$#$loose;
	       my $data=$loose->[$1];
	       my $header=pack 'cNZ*', 1, scalar(@$data), $req;
	       print $header, @$data, "\n";
	    } else {
	       if (defined (my $pv=eval { $objects->[$index]->give_pv($req) })) {
		  my $header=pack 'cNZ*', 1, scalar($pv->toStringArray), $pv->property->name;
		  print $header, $pv->toStringArray, "\n";
	       } elsif (length($@)) {
		  print "\c@$@\n";
	       } else {
		  my $header=pack 'cNZ*', 1, 0, "";
		  print $header, "\n";
	       }
	    }

	 } elsif ($command eq "take") {
	    my $req=<$socket>; chomp $req;
	    dbg_print( "client> req=($req)" ) if $Switches::d;
	    my ($data, $comments)=read_block($socket);
	    undef $data if @$data==1 and $data->[0] =~ $Poly::PropertyValue::UNDEF_re;
	    if ($req =~ /^\#(\d+)$/) {
	       die "invalid scratch property '$req'\n" if $1>$#$loose;
	       @{$loose->[$1]}=@$data;
	    } else {
	       $objects->[$index]->take($req, $data);
	    }

	 } elsif ($command eq "look") {
	    my $req=<$socket>; chomp $req;
	    dbg_print( "client> req=($req)" ) if $Switches::d;

	    if (defined (my $pv=eval { $objects->[$index]->lookup_pv($req) })) {
	       my $header=pack 'cNZ*', 1, scalar($pv->toStringArray), $pv->property->name;
	       print $header, $pv->toStringArray, "\n";
	    } elsif (length($@)) {
	       print "\c@$@\n";
	    } else {
	       my $header=pack 'cNZ*', 1, 0, "";
	       print $header, "\n";
	    }

	 } elsif ($command eq "comm") {
	    $objects->[$index]->commit;
	    undef $objects->[$index];

	 } elsif ($command eq "roll") {
	    undef $objects->[$index];

	 } elsif ($command eq "remo") {
	    my $list=read_block_chomp($socket);
	    dbg_print( "client> req=(", join(",", @$list), ")" ) if $Switches::d;

	    foreach my $prop_name (@$list) {
	       $objects->[$index]->remove($prop_name);
	    }

	 } elsif ($command eq "defi") {
	    my $req=<$socket>; chomp $req;
	    dbg_print( "client> req=($req)" ) if $Switches::d;

	    my $answer=defined($objects->[$index]->lookup($req));
	    print pack 'C', $answer;

	 } elsif ($command eq "prov") {
	    my $list=read_block_chomp($socket);
	    dbg_print( "client> req=(", join(",", @$list), ")" ) if $Switches::d;

	    my @props=eval { $objects->[$index]->give_pv(@$list) };
	    my $answer=!$@;
	    if ($answer) {
	       foreach (@props) {
		  $answer=0, last unless defined $_;
	       }
	    }
	    print pack 'C', $answer;

	 } elsif ($command eq "exis") {
	    my $req=<$socket>; chomp $req;
	    dbg_print( "client> req=($req)" ) if $Switches::d;

	    my $answer=$objects->[$index]->exists($req);
	    print pack 'C', $answer;

	 } elsif ($command eq "type") {
	    my $type=ref($objects->[$index]);
	    $type =~ s/^Apps::\w+:://;
	    print "$type\n";

	 } elsif ($command eq "isa_") {
	    my $type=<$socket>; chomp $type;
	    dbg_print( "client> type=($type)" ) if $Switches::d;
	    my $answer=$objects->[$index]->isa($type);
	    print pack 'C', $answer;

	 } else {
	    die "unknown client command <$command>\n";
	 }
      }
   };
   select $sel;
   sigaction SIGPIPE, $sa_pipe_save;
}
####################################################################################
sub new_skp {
   my ($local, $remote);
   socketpair $local, $remote, AF_UNIX, SOCK_STREAM, PF_UNSPEC
      or die "socketpair failed: $!\n";
   fcntl $remote, F_SETFD, 0		# keep opened in the client
      or die "fcntl(F_SETFD) failed: $!\n";
   return (new Pipe($local), $remote);
}
####################################################################################
sub Modules::client {
   my $client=shift;
   my (@objects, @loose);
   my ($local, $remote)=new_skp;

   my @args=map {
      if (ref($_)) {
	 if (!is_object($_) || UNIVERSAL::isa($_,"Visual::Embedding")) {
	    # scratch property
	    push @loose, $_;
	    '#'.$#loose

	 } elsif (UNIVERSAL::isa($_,"Poly::Object")) {
	    push @objects, $_;
	    '#'.fileno($remote).".".$#objects

	 } elsif (defined (my $deref=overload::Method($_,'@{}'))) {
	    push @loose, $deref->($_);
	    '#'.$#loose

	 } else {
	    croak( "don't know how to pass an object '", ref($_), "' to a client program" );
	 }

      } elsif (defined $_) {
	 # an usual scalar
	 $_

      } else {
	 # special case for a dummy object without properties
	 '#'.fileno($remote).".-1"
      }
   } @_;

   if ($Switches::d) {
      if (defined(my $debug=$ENV{POLYMAKE_DEBUG_CLIENTS})) {
	 if ($debug =~ m{(?:^|/)valgrind\b}) {
	    unshift @args, split(/\s+/, $debug), "--suppressions=$main::InstallTop/support/test_suppressions",
	                   "--leak-check=yes", "$client-d";
	    $client=shift @args;
	 } elsif ($client =~ qr/^(?:$debug)$/o) {
	    $client.="-d";
	 }
      }
      dbg_print( "running client $client(@args)" );
   }

   my $client_pid;
   unless ($client_pid=fork()) {
      die "fork failed: $!\n" unless defined $client_pid;
      $SIG{INT}='DEFAULT';
      $SIG{ALRM}='DEFAULT';
      if ($client =~ /\bvalgrind/) {
         $ENV{GLIBCXX_FORCE_NEW}="y";
      }
      exec $client, @args
      or do {
	 print STDERR "could not run client $client: $!\n";
	 exec "false";	# avoid executing global destructors
      }
   }

   close $remote
   or die "close(socket) failed: $!\n";

   serve($local, \@objects, \@loose);
   close $local;

   waitpid $client_pid, 0;
   my $rc=$?;
   if (my $sig=$rc & 127) {
      $@ ||= "client $client killed by signal $sig\n";
   } elsif ($rc) {
      $@ ||= "client $client exited with code ". ($rc>>8) ."\n";
   }
   die $@ if $@;
   undef;
}

####################################################################################
if (exists $DB::{DB}) {
   $DB::CreateTTY=2;	# prevent tracing in forked children
}

1