/Webface2.5/perl-lib/Webface/uniwrap.pm
Perl | 267 lines | 218 code | 33 blank | 16 comment | 29 complexity | 6a4f3099174ebeb26ee4473242bbaf75 MD5 | raw file
- package Webface::uniwrap;
- use strict;
- use IPC::PerlSSH;
- use POSIX;
- use Error qw(:try);
- use Sys::Hostname;
- use Webface::error;
- use vars qw/$config/;
- BEGIN {
- use JSON::Parse 'json_file_to_perl';
- our $config = json_file_to_perl('/configs/webface_config.json');
- }
- my @sshopt = ('-o', 'PasswordAuthentication no', '-o', 'KbdInteractiveDevices no');
- # resources ================================================================
- my $resources = $config->{'server_resources'};
- sub new
- {
- my $class = shift;
- my $self = {};
- bless($self, $class);
- my %opt = @_;
- $self->{retries} = $opt{retries} || 2;
- $self->{sleeptime} = $opt{sleeptime} || 2;
- $self->{user} = $opt{user} || $ENV{USER};
- $self->{server} = $opt{server} if exists $opt{server};
- $self->{arch} = $opt{arch} if exists $opt{arch};
- $self->{tmpdir} = $opt{tmpdir} || $ENV{TMPDIR} || '/tmp';
- $self->{host} = hostname();
- throw WebfaceSystemError(-text => "Specify server or arch") unless (exists $opt{server} or exists $opt{arch});
- throw WebfaceSystemError(-text => "Specify server OR arch")
- if (defined $self->{server} and defined $self->{arch});
- if (defined $self->{server}) {
- throw WebfaceSystemError(-text => "Resource $self->{server} unavailable")
- unless ($self->testserver($self->{server}) == 1);
- } else {
- $self->{server} = $self->findserver() unless defined $self->{server};
- }
- return $self;
- }
- sub execute
- {
- my $self = shift;
- my @args = @_;
- throw WebfaceSystemError(-text => "No arguments to uniwrap") unless (@args);
- # connect it ===============================================================
- my $st = -1;
- if ($self->{server} eq $self->{host}) {
- $st = system(@args);
- } else {
- try {
- $st = $self->client(@args);
- #warn("$self->{server}: process(@args) returned '$st'\n");
- }
- otherwise {
- my $e = shift;
- warn("Exception in execution on $self->{server}: $e\n");
- $st = -1;
- };
- }
- exit($st);
- }
- # run it =======================================================================
- sub client
- {
- my $self = shift;
- my @args = @_;
- my $st;
-
- # warn("run '" . join(' ', @args) . "' as $self->{user}\@$self->{server}\n");
- $self->open(Host => $self->{server}, User => $self->{user});
- $self->{ips}->use_library("IO", qw( open pclose getline ));
-
- # IPC::PerlSSH 'store' breaks for old perl, so we circumvent it below.
- # but lets ensure it works. To be expanded with compatible versions.
- throw WebfaceSystemError(-text => "IPC::PerlSSH incompatible version") unless ($IPC::PerlSSH::VERSION eq '0.16');
-
- # IPC::PerlSSH open pipe breaks for old perl, this is more portable.
- # (and actually more elegant!)
- $self->{ips}->eval('
- $stored_procedures{"popen"}= sub {
- use IO::Pipe;
- my $fh=new IO::Pipe();
- $fh->reader(@_);
- $fh->autoflush;
- $IPC::PerlSSH::Library::IO::handles{$fh->fileno}=$fh;
- return $fh->fileno;
- }
- ');
- $self->{ips}->{stored}{popen} = 1;
- $st = $self->{ips}->eval("chdir('$self->{tmpdir}')")
- or throw WebfaceSystemError(-text => "Could not chdir('$self->{tmpdir}') on $self->{server}");
- my $fd = $self->{ips}->call('popen', @args);
- throw WebfaceSystemError(-text => "Could not popen(@args) on $self->{server}")
- if (not defined $fd);
- throw WebfaceSystemError(-text => "Could not popen(@args) on $self->{server}")
- if ($fd < 0);
- while (1) {
- my $line;
- throw WebfaceSystemError(-text => "Lost connection") unless (defined $self->{ips});
- try {
- $line = $self->{ips}->call("getline", $fd);
- }
- catch WebfaceSystemError with {
- my $e = shift;
- throw WebfaceSystemError(-text => "Interrupted");
- }
- otherwise {
- # Unfortunately readline does not return empty as
- # stated in the manual, but throws an exception at EOF
- };
- last unless (defined $line);
- last if ($line eq "");
- print STDOUT "$line";
- }
-
- throw WebfaceSystemError(-text => "Lost connection to $self->{server}") unless exists $self->{ips};
-
- # warn("$self->{server}: closing\n");
- $st = $self->{ips}->call('pclose', $fd);
- $st = WEXITSTATUS($st);
- $self->close();
-
- return $st;
- }
- # utility =========================================================================
- sub testserver
- {
- my $self = shift;
- my $serv = shift;
- my $st;
- if ($serv eq $self->{host}) {
- warn("test $serv (local)");
- $st = chdir($self->{tmpdir});
- } else {
- try {
- warn("test $self->{user}\@$serv (remote) : chdir('$self->{tmpdir}')\n");
- my $ips = IPC::PerlSSH->new(Host => $serv, User => $self->{user});
- throw WebfaceSystemError(-text => "Unable to connect") unless $ips;
- $st = $ips->eval("chdir('$self->{tmpdir}')");
- throw WebfaceSystemError(-text => "Could not chdir('$self->{tmpdir}') on $serv") unless ($st);
- }
- otherwise {
- # silently mark error
- my $e = shift;
- warn("Exception in test of $serv: $e");
- $st = -1;
- };
- }
- warn("testserver($serv) returned '$st'\n");
- return $st;
- }
- sub findserver
- {
- my $self = shift;
- throw WebfaceSystemError(-text => "Unknown source host: $self->{host}") unless exists $resources->{ $self->{host} };
- throw WebfaceSystemError(-text => "Source host $self->{host} has no way to execute architecture $self->{arch}")
- unless exists $resources->{ $self->{host} }->{ $self->{arch} };
- my @serv = @{ $resources->{ $self->{host} }->{ $self->{arch} } };
- my $retries = $self->{retries};
- while ($retries) {
- # choose server
- foreach my $serv (@serv) {
- if ($self->testserver($serv) == 1) {
- return $serv;
- }
- }
- warn("zzz $self->{sleeptime} / $retries");
- sleep($self->{sleeptime});
- $retries--;
- }
- throw WebfaceSystemError(-text => "Unable to locate online resource (" . join(',', @serv) . ")");
- return undef;
- }
- sub open
- {
- my $self = shift;
- $self->{ips} = IPC::PerlSSH->new(@_, SshOptions => \@sshopt)
- or throw WebfaceSystemError(-text => "Cannot connect to $self->{server}");
- $self->{pgrp} = $self->{ips}->eval('getpgrp()');
- $self->{version} = $self->{ips}->eval('"$] $^X"');
- warn("remote perl version: $self->{version}");
- }
- sub close
- {
- my $self = shift;
- delete $self->{ips};
- delete $self->{pgrp};
- }
- sub interrupt
- {
- my $self = shift;
- $self->kill();
- $self->close();
- }
- sub kill
- {
- my $self = shift;
- try {
- if (defined $self->{ips} && defined $self->{pgrp}) {
- warn("Closing remote process $self->{pgrp}\@$self->{server}\n");
- my $ips = IPC::PerlSSH->new(Host => $self->{server}, User => $self->{user}, SshOptions => \@sshopt);
- throw WebfaceSystemError(-text => "Unable to connect") unless $ips;
- $ips->eval("kill(-2,$self->{pgrp})");
- } else {
- warn("No remote proc to kill at $self->{server}\n");
- }
- }
- otherwise {
- my $e = shift;
- warn("Exception killing remote proc $self->{pgrp}\@$self->{server}: $e");
- };
- }
- # static method
- sub args
- {
- my %opts;
- my @args;
- my $prog;
- while (@_) {
- my $opt = shift @_;
- if ($opt eq '-wraparch') {
- $opts{arch} = shift @_;
- } elsif ($opt eq '-wrapprog') {
- $prog = shift @_;
- } elsif ($opt eq '-wrapserv') {
- $opts{server} = shift @_;
- } elsif ($opt eq '-wrapuser') {
- $opts{user} = shift @_;
- } else {
- push @args, $opt;
- }
- }
- throw WebfaceConfigError(-text => "-wrapprog needed") unless (defined $prog);
- unshift @args, $prog;
- throw WebfaceConfigError(-text => "-wraparch or -wrapserv needed")
- unless (exists $opts{arch} or exists $opts{server});
- throw WebfaceConfigError(-text => "-wraparch OR -wrapserv") if (exists $opts{arch} and exists $opts{server});
- $opts{args} = \@args;
- return %opts;
- }