# 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
syntax highlighted by Code2HTML, v. 0.9.1