Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

132 lines (105 sloc) 3.268 kb
#!/usr/bin/env perl
use strict; use warnings;
use Test::More 'no_plan';
my $count = 0;
my $max_sessions = 30;
my $half_sessions = int( $max_sessions / 2 );
my $fork_ran_at_least_once = 0;
my %english = (
lose => 'is losing',
gain => 'is gaining',
create => 'has created'
);
# silence the copious diag's this test produces :)
sub _diag {
diag( @_ ) if $ENV{TEST_VERBOSE};
}
# this is based on the forkbomb.perl example that comes with POE
# please check it out for better documentation
{
package ForkBomber;
use MooseX::POE;
has id => (
isa => 'Str',
is => 'ro',
default => sub { $count++ },
);
sub START {
$_[0]->yield('fork');
$poe_kernel->sig( 'INT', 'signal_handler' );
$poe_kernel->sig( 'ZOMBIE', 'signal_handler' );
::pass( 'Started ' . $_[0]->id );
}
sub STOP {
::pass( 'stopped ' . $_[OBJECT]->id );
}
sub CHILD {
my ( $kernel, $self, $direction, $child, $return ) =
@_[ KERNEL, OBJECT, ARG0, ARG1, ARG2 ];
::_diag printf(
"%4d %s child %s%s\n",
$self->id,
$english{$direction},
$kernel->call( $child, 'fetch_id' ),
(
$direction eq 'create' ?
" (child returned: " . ( defined $return ? $return : "UNDEF" ) . ")"
: ''
)
);
}
sub PARENT {
my ( $kernel, $self, $old_parent, $new_parent ) =
@_[ KERNEL, OBJECT, ARG0, ARG1 ];
::_diag printf(
"%4d parent is changing from %d to %d\n",
$self->id,
$poe_kernel->call( $old_parent, 'fetch_id' ),
$poe_kernel->call( $new_parent, 'fetch_id' )
);
}
event signal_handler => sub {
my ( $self, $signal_name ) = @_[ OBJECT, ARG0 ];
::_diag printf( "%4d has received SIG%s\n", $self->id, $signal_name );
# tell Kernel that this wasn't handled
return 0;
};
event fork => sub {
$fork_ran_at_least_once++;
my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
if ( $count < $max_sessions ) {
if ( rand() < 0.5 ) {
::_diag $self->id . " is starting a new child...";
ForkBomber->new;
}
# tails == don't spawn
else {
::_diag $self->id . " is just spinning its wheels this time...";
}
if ( ( $count < $half_sessions ) || ( rand() < 0.05 ) ) {
$kernel->yield('fork');
}
else {
::_diag $self->id . " has decided to die. Bye!";
if ( $self->id != 1 ) {
$kernel->yield('_stop');
}
}
}
else {
::_diag $self->id . " notes that the session limit is met. Bye!";
# Please see the two NOTEs above.
if ( $self->id != 1 ) {
$kernel->yield('_stop');
}
}
};
event fetch_id => sub {
return $_[OBJECT]->id;
}
}
ForkBomber->new;
POE::Kernel->run;
# A.k.a. 'the we actualy did something test'
ok($fork_ran_at_least_once, "We had at least one fork");
__END__
Jump to Line
Something went wrong with that request. Please try again.