From: Tyler Riddle Date: Wed, 10 Oct 2012 02:17:34 +0000 (-0700) Subject: all tests run at trace log level with a null log output; new tests for watchdog,... X-Git-Tag: v0.003001_01~101 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FObject-Remote.git;a=commitdiff_plain;h=f129bfaf05b1ae0e2e2992cad47a70482dec9885 all tests run at trace log level with a null log output; new tests for watchdog, tied objects, and perl execution options --- diff --git a/lib/Object/Remote/FatNode.pm b/lib/Object/Remote/FatNode.pm index 6b65a25..a09680f 100644 --- a/lib/Object/Remote/FatNode.pm +++ b/lib/Object/Remote/FatNode.pm @@ -5,6 +5,8 @@ use Config; use B qw(perlstring); my @exclude_mods = qw(XSLoader.pm DynaLoader.pm); +#used by t/watchdog_fatnode +our $INHIBIT_RUN_NODE = 0; sub stripspace { my ($text) = @_; @@ -103,7 +105,11 @@ my $end = stripspace <<'END_END'; use strictures 1; use Object::Remote::Node; - Object::Remote::Node->run(watchdog_timeout => $WATCHDOG_TIMEOUT); + + unless ($Object::Remote::FatNode::INHIBIT_RUN_NODE) { + Object::Remote::Node->run(watchdog_timeout => $WATCHDOG_TIMEOUT); + } + END_END my %files = map +($mods{$_} => scalar do { local (@ARGV, $/) = ($_); <> }), diff --git a/lib/Object/Remote/Node.pm b/lib/Object/Remote/Node.pm index e769e58..93ca232 100644 --- a/lib/Object/Remote/Node.pm +++ b/lib/Object/Remote/Node.pm @@ -12,7 +12,7 @@ sub run { log_trace { "run() has been invoked on remote node" }; if ($args{watchdog_timeout}) { - Object::Remote::WatchDog->new(timeout => $args{watchdog_timeout}); + Object::Remote::WatchDog->new(timeout => $args{watchdog_timeout}); } my $c = Object::Remote::Connector::STDIO->new->connect; diff --git a/lib/Object/Remote/Role/Connector/PerlInterpreter.pm b/lib/Object/Remote/Role/Connector/PerlInterpreter.pm index 420707f..60c0dd4 100644 --- a/lib/Object/Remote/Role/Connector/PerlInterpreter.pm +++ b/lib/Object/Remote/Role/Connector/PerlInterpreter.pm @@ -16,6 +16,8 @@ with 'Object::Remote::Role::Connector'; has module_sender => (is => 'lazy'); has ulimit => ( is => 'ro' ); has nice => ( is => 'ro' ); +has watchdog_timeout => ( is => 'ro', required => 1, default => sub { undef } ); +has perl_command => (is => 'lazy'); #if no child_stderr file handle is specified then stderr #of the child will be connected to stderr of the parent @@ -28,13 +30,13 @@ sub _build_module_sender { return $hook ? $hook->sender : Object::Remote::ModuleSender->new; } -has perl_command => (is => 'lazy'); -has watchdog_timeout => ( is => 'ro', required => 1, default => sub { 0 } ); - #SSH requires the entire remote command to be #given as one single argument to the ssh #command line program so this jumps through #some hoops + +#TODO this is SSH's problem not perl's so move +#this to the SSH connector sub _build_perl_command { my ($self) = @_; my $nice = $self->nice; diff --git a/lib/Object/Remote/WatchDog.pm b/lib/Object/Remote/WatchDog.pm index 2a3fc61..170b2b2 100644 --- a/lib/Object/Remote/WatchDog.pm +++ b/lib/Object/Remote/WatchDog.pm @@ -4,16 +4,6 @@ use Object::Remote::MiniLoop; use Object::Remote::Logging qw ( :log :dlog ); use Moo; -BEGIN { - $SIG{ALRM} = sub { - #if the Watchdog is killing the process we don't want any chance of the - #process not actually exiting and die could be caught by an eval which - #doesn't do us any good - log_error { sprintf("Watchdog has expired, terminating the process at file %s line %s", __FILE__, __LINE__ + 1); }; - exit(1); - }; -}; - has timeout => ( is => 'ro', required => 1 ); around new => sub { @@ -28,6 +18,15 @@ around new => sub { #start the watchdog sub BUILD { my ($self) = @_; + + $SIG{ALRM} = sub { + #if the Watchdog is killing the process we don't want any chance of the + #process not actually exiting and die could be caught by an eval which + #doesn't do us any good + log_error { sprintf("Watchdog has expired, terminating the process at file %s line %s", __FILE__, __LINE__ + 1); }; + exit(1); + }; + Dlog_debug { "Initializing watchdog with timeout of $_ seconds" } $self->timeout; alarm($self->timeout); } diff --git a/t/await.t b/t/await.t index d96cf3d..c846637 100644 --- a/t/await.t +++ b/t/await.t @@ -3,6 +3,7 @@ use Test::More; use Test::Fatal; use FindBin; use lib "$FindBin::Bin/lib"; +require 't/logsetup.pl'; use Object::Remote; use Object::Remote::Future qw( await_all await_future ); diff --git a/t/basic.t b/t/basic.t index 1547c96..b8fee8e 100644 --- a/t/basic.t +++ b/t/basic.t @@ -2,6 +2,8 @@ use strictures 1; use Test::More; use Sys::Hostname qw(hostname); +require 't/logsetup.pl'; + use Object::Remote; $ENV{PERL5LIB} = join( diff --git a/t/basic_data.t b/t/basic_data.t index 081305d..e41ba55 100644 --- a/t/basic_data.t +++ b/t/basic_data.t @@ -2,6 +2,8 @@ use strictures 1; use Test::More; use Sys::Hostname qw(hostname); +require 't/logsetup.pl'; + use Object::Remote::FromData; my $connection = Object::Remote->connect('-'); diff --git a/t/bridged.t b/t/bridged.t index a244867..2a092b8 100644 --- a/t/bridged.t +++ b/t/bridged.t @@ -5,6 +5,8 @@ use FindBin; use lib "$FindBin::Bin/lib"; +require 't/logsetup.pl'; + use Object::Remote; is exception { diff --git a/t/lib/ORTestTiedRemote.pm b/t/lib/ORTestTiedRemote.pm new file mode 100644 index 0000000..e859b06 --- /dev/null +++ b/t/lib/ORTestTiedRemote.pm @@ -0,0 +1,46 @@ +package ORTestTiedRemote; + +use Moo; + +use Tie::Array; +use Tie::Hash; + +has hash => ( is => 'ro', builder => 1 ); +has array => ( is => 'ro', builder => 1 ); + +sub _build_hash { + tie(my %hash, 'Tie::StdHash'); + %hash = ( akey => 'a value'); + return \%hash; +} + +sub _build_array { + tie(my @array, 'Tie::StdArray'); + @array = ('another value'); + return \@array; +} + +sub sum_array { + my ($self) = @_; + my $sum = 0; + + foreach(@{$self->array}) { + $sum += $_; + } + + return $sum; +} + +sub sum_hash { + my ($self) = @_; + my $sum = 0; + + foreach(values(%{$self->hash})) { + $sum += $_; + } + + return $sum; +} + +1; + diff --git a/t/logsetup.pl b/t/logsetup.pl new file mode 100644 index 0000000..3eff7e1 --- /dev/null +++ b/t/logsetup.pl @@ -0,0 +1,24 @@ +#require this file in the test to initialize the logging framework +#so the tests can run + +package Object::Remote::Logger::TestOutput; + +use base qw ( Log::Contextual::SimpleLogger ); + +#we want the code blocks in the log lines to execute but not +#output anything so turn this into a null logger +sub _log { } + +package main; + +use Object::Remote::Logging qw( :log ); +use Object::Remote::LogDestination; +#make sure to enable execution of every logging code block +#by setting the log level as high as it can go + my $____LOG_DESTINATION = Object::Remote::LogDestination->new( + logger => Object::Remote::Logger::TestOutput->new({ levels_upto => 'trace' }), + ); + + $____LOG_DESTINATION->connect(Object::Remote::Logging->arg_router); +1; + diff --git a/t/perl_execute.t b/t/perl_execute.t new file mode 100644 index 0000000..3777485 --- /dev/null +++ b/t/perl_execute.t @@ -0,0 +1,32 @@ +use strictures 1; +use Test::More; + +use Data::Dumper; + +require 't/logsetup.pl'; + +use Object::Remote::Connector::Local; +use Object::Remote::Connector::SSH; + +my $defaults = Object::Remote::Connector::Local->new; + +my $normal = $defaults->final_perl_command; +my $ulimit = Object::Remote::Connector::Local->new(ulimit => 536)->final_perl_command; +my $nice = Object::Remote::Connector::Local->new(nice => 834)->final_perl_command; +my $both = Object::Remote::Connector::Local->new(nice => 612, ulimit => 913)->final_perl_command; +my $ssh = Object::Remote::Connector::SSH->new(nice => 494, ulimit => 782, ssh_to => 'testhost')->final_perl_command; + +is($defaults->timeout->{after}, 10, 'Default connection timeout value is correct'); +is($defaults->watchdog_timeout, undef, 'Watchdog is not enabled by default'); +is($defaults->nice, undef, 'Nice is not enabled by default'); +is($defaults->ulimit, undef, 'Ulimit is not enabled by default'); +is($defaults->stderr, undef, 'Child process STDERR is clone of parent process STDERR by default'); + +is_deeply($normal, ['sh -c "perl -"'], 'Default Perl interpreter arguments correct'); +is_deeply($ulimit, ['sh -c "ulimit -v 536; perl -"'], 'Arguments for ulimit are correct'); +is_deeply($nice, ['sh -c "nice -n 834 perl -"'], 'Arguments for nice are correct'); +is_deeply($both, ['sh -c "ulimit -v 913; nice -n 612 perl -"'], 'Arguments for nice and ulimit are correct'); +is_deeply($ssh, [qw(ssh -A testhost), 'sh -c "ulimit -v 782; nice -n 494 perl -"'], "Arguments using ssh are correct"); + +done_testing; + diff --git a/t/sender.t b/t/sender.t index d8b58e2..cd9c681 100644 --- a/t/sender.t +++ b/t/sender.t @@ -1,6 +1,8 @@ use strictures 1; use Test::More; +require 't/logsetup.pl'; + use Object::Remote::Connector::Local; use Object::Remote; use Object::Remote::ModuleSender; diff --git a/t/start_core.t b/t/start_core.t index a636e59..964a103 100644 --- a/t/start_core.t +++ b/t/start_core.t @@ -3,6 +3,8 @@ use Test::More; use Object::Remote; use File::Spec; +require 't/logsetup.pl'; + { package S1S; diff --git a/t/tied.t b/t/tied.t new file mode 100644 index 0000000..e22ee2e --- /dev/null +++ b/t/tied.t @@ -0,0 +1,45 @@ +use strictures 1; +use Test::More; + +use lib 't/lib'; + +use Tie::Array; +use Tie::Hash; + +require 't/logsetup.pl'; + +use Object::Remote; +use ORTestTiedRemote; + +my @test_data = qw(1 5 10 30 80); +my $test_sum; + +map { $test_sum += $_ } @test_data; + +my $conn = Object::Remote->connect('-'); +my $remote = ORTestTiedRemote->new::on($conn); + +isa_ok($remote, 'Object::Remote::Proxy'); + +my $remote_array = $remote->array; +my $remote_hash = $remote->hash; + +is(ref($remote_array), 'ARRAY', 'Array ref is array ref'); +is(ref(tied(@$remote_array)), 'Object::Remote::Proxy', 'Array is tied to proxy object'); +is_deeply($remote_array, ['another value'], 'Array is initialized properly'); + +@$remote_array = @test_data; +is($remote->sum_array, $test_sum, 'Sum of array data matches sum of test data'); + +is(ref($remote_hash), 'HASH', 'Hash ref is hash ref'); +is(ref(tied(%$remote_hash)), 'Object::Remote::Proxy', 'Hash is tied to proxy object'); +is_deeply($remote_hash, { akey => 'a value' }, 'Hash is initialized properly'); + +%$remote_hash = (); +do { my $i = 0; map { $remote_hash->{++$i} = $_ } @test_data }; +is($remote->sum_hash, $test_sum, 'Sum of hash values matches sum of test data'); + +done_testing; + + + \ No newline at end of file diff --git a/t/timeout.t b/t/timeout.t index dba6c62..c205b93 100644 --- a/t/timeout.t +++ b/t/timeout.t @@ -1,6 +1,8 @@ use strictures 1; use Test::More; +require 't/logsetup.pl'; + use Object::Remote; use Object::Remote::Connector::Local; diff --git a/t/transfer.t b/t/transfer.t index 0ce0846..1102194 100644 --- a/t/transfer.t +++ b/t/transfer.t @@ -3,6 +3,8 @@ use Test::More; use Test::Fatal; use FindBin; +require 't/logsetup.pl'; + $ENV{PERL5LIB} = join( ':', ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : ()), qw(lib t/lib) ); diff --git a/t/watchdog.t b/t/watchdog.t new file mode 100644 index 0000000..c7e2c1f --- /dev/null +++ b/t/watchdog.t @@ -0,0 +1,45 @@ +use strictures 1; +use Test::More; + +require 't/logsetup.pl'; + +use Object::Remote::Connection; +use Object::Remote::FromData; + +$SIG{ALRM} = sub { fail("Watchdog killed remote process in time"); die "test failed" }; + +my $conn = Object::Remote::Connection->conn_from_spec("-", watchdog_timeout => 1)->connect; + +my $remote = HangClass->new::on($conn); + +isa_ok($remote, 'Object::Remote::Proxy'); +is($remote->alive, 1, "Hanging test object is running"); + +alarm(3); + +eval { $remote->hang }; + +like($@, qr/^Object::Remote connection lost: eof/, "Correct error message"); + +done_testing; + +__DATA__ + +package HangClass; + +use Moo; + +sub alive { + return 1; +} + +sub hang { + while(1) { + sleep(1); + } +} + + + + + diff --git a/t/watchdog_fatnode.t b/t/watchdog_fatnode.t new file mode 100644 index 0000000..81e8c96 --- /dev/null +++ b/t/watchdog_fatnode.t @@ -0,0 +1,36 @@ +use strictures 1; +use Test::More; + +require 't/logsetup.pl'; + +use Object::Remote::Connector::Local; + +$SIG{ALRM} = sub { die "alarm signal\n" }; + +open(my $nullfh, '>', '/dev/null') or die "Could not open /dev/null: $!"; + +my $fatnode_text = Object::Remote::Connector::Local->new(watchdog_timeout => 1)->fatnode_text; + +#this simulates a node that has hung before it reaches +#the watchdog initialization - it's an edge case that +#could cause remote processes to not get cleaned up +#if it's not handled right +eval { + no warnings 'once'; + local *STDOUT = $nullfh; + $Object::Remote::FatNode::INHIBIT_RUN_NODE = 1; + eval $fatnode_text; + + if ($@) { + die "could not eval fatnode text: $@"; + } + + while(1) { + sleep(1); + } +}; + +is($@, "alarm signal\n", "Alarm handler was invoked"); + +done_testing; +