is => 'ro',
lazy => 1,
required => 1,
- default => sub { $_[0]->pidbase . '/' . $_[0]->progname . '.pid' },
+ default => sub {
+ die 'Cannot write to ' . $_[0]->pidbase unless -w $_[0]->pidbase;
+ $_[0]->pidbase . '/' . $_[0]->progname . '.pid';
+ },
);
has foreground => (
sub check {
my ($self) = @_;
- my $pidfile = $self->pidfile;
- if ( -e $pidfile ) {
+ if ( my $pid = $self->get_pid ) {
my $prog = $self->progname;
- chomp( my $pid = read_file($pidfile) );
- if ( kill 0 => $pid ) {
+ if ( CORE::kill 0 => $pid ) {
croak "$prog already running ($pid).";
}
- carp "$prog not running but $pidfile exists. Perhaps it is stale?";
+ carp "$prog not running but $pid exists. Perhaps it is stale?";
return 1;
}
return 0;
$self->daemonize unless $self->foreground;
+ # Avoid 'stdin reopened for output' warning with newer perls
+ open( NULL, '/dev/null' );
+ <NULL> if (0);
+
+ $self->save_pid;
+ $self->setup_signals;
+ return $$;
+}
+
+sub save_pid {
+ my ($self) = @_;
my $pidfile = $self->pidfile;
lock( $pidfile, undef, 'nonblocking' )
or croak "Could not lock PID file $pidfile: $!";
write_file( $pidfile, "$$\n" );
unlock($pidfile);
- $self->setup_signals;
return;
}
-sub stop {
+sub remove_pid {
my ($self) = @_;
my $pidfile = $self->pidfile;
- unless ( -e $pidfile ) {
- carp $self->progname . ' is not currently running.';
- return;
- }
- chomp( my $pid = read_file($pidfile) );
- $self->kill($pid) unless $self->foreground();
lock( $pidfile, undef, 'nonblocking' )
or croak "Could not lock PID file $pidfile: $!";
unlink($pidfile);
return;
}
+sub get_pid {
+ my ($self) = @_;
+ my $pidfile = $self->pidfile;
+ return unless -e $pidfile;
+ chomp( my $pid = read_file($pidfile) );
+ return $pid;
+}
+
+sub stop {
+ my ( $self, %args ) = @_;
+ my $pid = $self->get_pid;
+ $self->kill($pid) unless $self->foreground();
+ $self->remove_pid;
+ return 1 if $args{no_exit};
+ exit;
+}
+
sub restart {
my ($self) = @_;
- $self->stop();
+ $self->stop( noexit => 1 );
$self->start();
}
sub setup_signals {
- my $self = @_;
- $SIG{INT} = sub { $_[0]->handle_sigint; };
- $SIG{HUP} = sub { $_[0]->handle_sighup };
+ my ($self) = @_;
+ $SIG{INT} = sub { $self->handle_sigint; };
+ $SIG{HUP} = sub { $self->handle_sighup };
}
-sub handle_sigint { $_[0]->stop; }
+sub handle_sigint { $_[0]->stop }
sub handle_sighup { return; }
sub kill {
my ( $self, $pid ) = @_;
- unless ( kill 0 => $pid ) {
- carp "$pid already appears dead.";
+ unless ( CORE::kill 0 => $pid ) {
+
+ # warn "$pid already appears dead.";
+ return;
+ }
+
+ if ( $pid eq $$ ) {
+
+ # warn "$pid is us! Can't commit suicied.";
return;
}
- kill( 2, $pid ); # Try SIGINT
- sleep(1) if kill( 0, $pid );
+ CORE::kill( 2, $pid ); # Try SIGINT
+ sleep(1) if CORE::kill( 0, $pid );
- unless ( kill 0 => $pid or $!{EPERM} ) { # IF it is still running
- kill( 15, $pid ); # try SIGTERM
- sleep(1) if kill( 0, $pid );
+ unless ( CORE::kill 0 => $pid or $!{EPERM} ) { # IF it is still running
+ CORE::kill( 15, $pid ); # try SIGTERM
+ sleep(1) if CORE::kill( 0, $pid );
}
- unless ( kill 0 => $pid or $!{EPERM} ) { # IF it is still running
- kill( 9, $pid ); # finally try SIGKILL
- sleep(1) if kill( 0, $pid );
+ unless ( CORE::kill 0 => $pid or $!{EPERM} ) { # IF it is still running
+ CORE::kill( 9, $pid ); # finally try SIGKILL
+ sleep(1) if CORE::kill( 0, $pid );
}
- unless ( kill 0 => $pid or $!{EPERM} ) { # IF it is still running
- carp "$pid doesn't seem to want to die."; # AHH EVIL DEAD!
+ unless ( CORE::kill 0 => $pid or $!{EPERM} ) { # IF it is still running
+ carp "$pid doesn't seem to want to die."; # AHH EVIL DEAD!
}
return;
Handle a HUP signal. Nothing is done by default.
+=item get_pid
+
+=item save_pid
+
+=item remove_pid
+
=item meta()
the C<meta()> method from L<Class::MOP::Class>
package Test::MooseX::Daemonize;
use Proc::Daemon;
+use File::Slurp;
# BEGIN CARGO CULTING
use Sub::Exporter;
our $AUTHORITY = 'cpan:PERIGRIN';
my @exports = qw[
- daemonize_ok
+ daemonize_ok
+ check_test_output
];
-Sub::Exporter::setup_exporter({
- exports => \@exports,
- groups => { default => \@exports }
-});
+Sub::Exporter::setup_exporter(
+ {
+ exports => \@exports,
+ groups => { default => \@exports }
+ }
+);
our $Test = Test::Builder->new;
exit;
}
else {
- sleep(5); # Punt on sleep time, 5 seconds should be enough
- $Test->ok( kill(0 => $pid or $!{EPERM}), $msg );
- return $pid;
+ sleep(1); # Punt on sleep time, 1 seconds should be enough
+ $Test->ok( -e $daemon->pidfile, $msg )
+ || $Test->diag( 'Pidfile (' . $daemon->pidfile . ') not found.' );
+ }
+}
+
+sub check_test_output {
+ my ($app) = @_;
+ open( my $stdout_in, '<', $app->test_output )
+ or die "can't open test output: $!";
+ while ( my $line = <$stdout_in> ) {
+ $line =~ s/\s+\z//;
+ my $label;
+ if ( $line =~ /\A((not\s+)?ok)(?:\s+-)(?:\s+(.*))\z/ ) {
+ my ( $status, $not, $text ) = ( $1, $2, $3 );
+ $text ||= '';
+
+ # We don't just call ok(!$not), because that generates diagnostics of
+ # its own for failures. We only want the diagnostics from the child.
+ my $num = $Test->current_test;
+ $Test->current_test( ++$num );
+ $Test->_print("$status $num - $text\n");
+ }
+ elsif ( $line =~ s/\A#\s?// ) {
+ $Test->diag($line);
+ }
+ else {
+ $Test->_print_diag("$label: $line (unrecognised)\n");
+ }
}
}
use Moose::Role;
has test_output => (
- isa => 'Str',
- is => 'ro',
+ isa => 'Str',
+ is => 'ro',
required => 1,
);
after daemonize => sub {
$Test->use_numbers(0);
$Test->no_ending(1);
- open my $stdout_out, '>', $_[0]->test_output;
- my $fileno = fileno $stdout_out;
- open STDERR, ">&=$fileno"
+ open my $out, '>', $_[0]->test_output or die "Cannot open test output: $!";
+ my $fileno = fileno $out;
+ open STDERR, ">&=", $fileno
or die "Can't redirect STDERR";
- open STDOUT, ">&=$fileno"
+ open STDOUT, ">&=", $fileno
or die "Can't redirect STDOUT";
- $Test->output($stdout_out);
- $Test->failure_output($stdout_out);
- $Test->todo_output($stdout_out);
+ $Test->output($out);
+ $Test->failure_output($out);
+ $Test->todo_output($out);
};
1;
the C<meta()> method from L<Class::MOP::Class>
+=item daemonize_ok()
+
+=item check_test_output()
+
=back
=head1 DEPENDENCIES
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGES.
\ No newline at end of file
+SUCH DAMAGES.
-use Test::More tests => 2;
+use Test::More tests => 4;
use Test::MooseX::Daemonize;
+use MooseX::Daemonize;
## Since a daemon will not be able to print terminal output, we
## have a test daemon create a file, and another process test for
with qw(MooseX::Daemonize);
has filename => ( isa => 'Str', is => 'ro' );
-
after start => sub { $_[0]->create_file( $_[0]->filename ) };
sub create_file {
my ( $self, $file ) = @_;
- open( FILE, ">$file" ) || die $!;
- close(FILE);
+ open( my $FILE, ">$file" ) || die $!;
+ close($FILE);
}
no Moose;
}
-
package main;
use Cwd;
chdir 't' if ( Cwd::cwd() !~ m|/t$| );
my $cwd = Cwd::cwd();
-my $file = join( '/', $cwd, 'im_alive' );
-my $daemon = FileMaker->new( pidbase => '.', filename => $file );
-
-daemonize_ok( $daemon, 'child forked okay' );
-ok( -e $file, "$file exists" );
-unlink($file);
-
+my $app = FileMaker->new(
+ pidbase => $cwd,
+ filename => "$cwd/im_alive",
+);
+daemonize_ok( $app, 'child forked okay' );
+ok( -e $app->filename, "$file exists" );
+ok( $app->stop( no_exit => 1 ), 'app stopped' );
+ok( -e $app->pidfile == undef, 'pidfile gone' );
+unlink( $app->filename );
use Test::More no_plan => 1;
use Test::Builder;
use Test::MooseX::Daemonize;
+use MooseX::Daemonize;
my $Test = Test::Builder->new;
-chdir 't' if ( Cwd::cwd() !~ m|/t$| );
-my $cwd = Cwd::cwd();
-
-my $file = join( '/', $cwd, 'results' );
{
package TestOutput;
use Moose;
with qw(MooseX::Daemonize);
- with qw(Test::MooseX::Daemonize::Testable); # setup our test environment
-
- has max => ( isa => 'Int', is => 'ro', default => sub { 5 } );
-
+ with qw(Test::MooseX::Daemonize::Testable); # setup our test environment
+
after start => sub {
my ($self) = @_;
- $self->output_ok(1);
+ $self->output_ok();
};
sub output_ok {
- my ( $self, $count ) = @_;
- $Test->ok( $count, "$count output_ok" );
- if ( $count++ > $self->max ) {
- $self->stop();
- return;
+ my ($self) = @_;
+ my $count = 1;
+ while (1) {
+ $Test->ok( $count++, "$count output_ok" );
+ sleep(1);
}
- $self->output_ok($count);
+
}
no Moose;
}
## Try to make sure we are in the test directory
chdir 't' if ( Cwd::cwd() !~ m|/t$| );
my $cwd = Cwd::cwd();
-
-my $daemon = TestOutput->new( pidbase => $cwd, test_output => $file);
-
-daemonize_ok( $daemon, 'child forked okay' );
-
-open (my $stdout_in, '<', 'results');
-while ( my $line = <$stdout_in> ) {
- $line =~ s/\s+\z//;
- if ( $line =~ /\A((not\s+)?ok)(?:\s+-)(?:\s+(.*))\z/ ) {
- my ( $status, $not, $text ) = ( $1, $2, $3 );
- $text ||= '';
-
- # We don't just call ok(!$not), because that generates diagnostics of
- # its own for failures. We only want the diagnostics from the child.
- my $num = $Test->current_test;
- $Test->current_test( ++$num );
- $Test->_print("$status $num - $label: $text\n");
- }
- elsif ( $line =~ s/\A#\s?// ) {
- $Test->diag($line);
- }
- else {
- $Test->_print_diag("$label: $line (unrecognised)\n");
- }
-}
-
-unlink($file);
\ No newline at end of file
+my $app = TestOutput->new(
+ pidbase => $cwd,
+ test_output => join( '/', $cwd, 'results' ),
+);
+daemonize_ok( $app, 'child forked okay' );
+sleep(5); # give ourself a chance to produce some output
+$app->stop( no_exit => 1 );
+
+check_test_output($app);
+unlink( $app->test_output );
projects / gitmo/MooseX-Daemonize.git / commitdiff