From: Chris Prather Date: Tue, 26 Jun 2007 19:02:43 +0000 (+0000) Subject: got 01.filecreate.t passing ... X-Git-Tag: 0.01~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3543c999585655814699a2bbe30cb308823a5c6d;p=gitmo%2FMooseX-Daemonize.git got 01.filecreate.t passing ... r23687@alice-3: perigrin | 2007-06-26 02:18:34 -0500 got 02 passing r23688@alice-3: perigrin | 2007-06-26 02:23:34 -0500 all tests pass again --- diff --git a/lib/MooseX/Daemonize.pm b/lib/MooseX/Daemonize.pm index bd9c203..4e857d8 100644 --- a/lib/MooseX/Daemonize.pm +++ b/lib/MooseX/Daemonize.pm @@ -35,7 +35,10 @@ has pidfile => ( 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 => ( @@ -48,14 +51,12 @@ 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; @@ -72,24 +73,28 @@ sub start { $self->daemonize unless $self->foreground; + # Avoid 'stdin reopened for output' warning with newer perls + open( NULL, '/dev/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); @@ -97,43 +102,67 @@ sub stop { 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; @@ -243,6 +272,12 @@ Handle a INT signal, by default calls C<$self->stop()>; Handle a HUP signal. Nothing is done by default. +=item get_pid + +=item save_pid + +=item remove_pid + =item meta() the C method from L diff --git a/lib/Test/MooseX/Daemonize.pm b/lib/Test/MooseX/Daemonize.pm index 33033ab..a11c1bf 100644 --- a/lib/Test/MooseX/Daemonize.pm +++ b/lib/Test/MooseX/Daemonize.pm @@ -2,6 +2,7 @@ use strict; package Test::MooseX::Daemonize; use Proc::Daemon; +use File::Slurp; # BEGIN CARGO CULTING use Sub::Exporter; @@ -10,13 +11,16 @@ our $VERSION = '0.01'; 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; @@ -27,9 +31,35 @@ sub daemonize_ok { 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"); + } } } @@ -37,25 +67,25 @@ package Test::MooseX::Daemonize::Testable; 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; @@ -162,6 +192,10 @@ Handle a HUP signal. Nothing is done by default. the C method from L +=item daemonize_ok() + +=item check_test_output() + =back =head1 DEPENDENCIES @@ -241,4 +275,4 @@ THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 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. diff --git a/t/01.filecreate.t b/t/01.filecreate.t index e6a161b..fba64ec 100644 --- a/t/01.filecreate.t +++ b/t/01.filecreate.t @@ -1,5 +1,6 @@ -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 @@ -12,19 +13,17 @@ use Test::MooseX::Daemonize; 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; @@ -32,10 +31,12 @@ 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 ); diff --git a/t/02.stdout.t b/t/02.stdout.t index dcf2706..b506f25 100644 --- a/t/02.stdout.t +++ b/t/02.stdout.t @@ -1,35 +1,30 @@ 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; } @@ -40,30 +35,13 @@ use Cwd; ## 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 );