X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FMooseX%2FDaemonize.pm;h=2841cd7f04dbb7c8cd04c0c5fa64c939b9393615;hb=69186a4879a2ddfed228c03e7a25d5455921dfb0;hp=33033ab8e30ed33ec5d08e0afdf707594f04e786;hpb=3c3db18cb8874d075ad834a5a473b13cab751350;p=gitmo%2FMooseX-Daemonize.git diff --git a/lib/Test/MooseX/Daemonize.pm b/lib/Test/MooseX/Daemonize.pm index 33033ab..2841cd7 100644 --- a/lib/Test/MooseX/Daemonize.pm +++ b/lib/Test/MooseX/Daemonize.pm @@ -1,35 +1,67 @@ +package Test::MooseX::Daemonize; use strict; -package Test::MooseX::Daemonize; -use Proc::Daemon; +our $VERSION = '0.09'; +our $AUTHORITY = 'cpan:PERIGRIN'; # BEGIN CARGO CULTING use Sub::Exporter; use Test::Builder; -our $VERSION = '0.01'; -our $AUTHORITY = 'cpan:PERIGRIN'; -my @exports = qw[ - daemonize_ok -]; -Sub::Exporter::setup_exporter({ - exports => \@exports, - groups => { default => \@exports } -}); +{ + my @exports = qw[ + daemonize_ok + check_test_output + ]; + + Sub::Exporter::setup_exporter( + { + exports => \@exports, + groups => { default => \@exports } + } + ); +} our $Test = Test::Builder->new; sub daemonize_ok { my ( $daemon, $msg ) = @_; - unless ( my $pid = Proc::Daemon::Fork ) { + unless ( my $pid = fork ) { $daemon->start(); 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( $daemon->pidfile->does_file_exist, $msg ) + || $Test->diag( + 'Pidfile (' . $daemon->pidfile->file . ') 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,166 +69,86 @@ 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; __END__ +=pod =head1 NAME -Test::MooseX::Daemonize - provides a Role that daemonizes your Moose based application. - +Test::MooseX::Daemonize - Tool to help test MooseX::Daemonize applications =head1 VERSION This document describes MooseX::Daemonize version 0.0.1 - =head1 SYNOPSIS - package main; - use Cwd; + use File::Spec::Functions; + use File::Temp qw(tempdir); + + my $dir = tempdir( CLEANUP => 1 ); ## Try to make sure we are in the test directory - chdir 't' if ( Cwd::cwd() !~ m|/t$| ); - my $cwd = Cwd::cwd(); - my $file = join( '/', $cwd, 'im_alive' ); - my $daemon = FileMaker->new( pidbase => '.', filename => $file ); + my $file = catfile( $dir, "im_alive" ); + my $daemon = FileMaker->new( pidbase => $dir, filename => $file ); daemonize_ok( $daemon, 'child forked okay' ); ok( -e $file, "$file exists" ); - unlink($file); =head1 DESCRIPTION -Often you want to write a persistant daemon that has a pid file, and responds appropriately to Signals. -This module helps provide the basic infrastructure to do that. - -=head1 ATTRIBUTES - -=over - -=item progname Str - -The name of our daemon, defaults to $0 - -=item pidbase Str - -The base for our bid, defaults to /var/run/$progname - -=item pidfile Str - -The file we store our PID in, defaults to /var/run/$progname/ - -=item foreground Bool - -If true, the process won't background. Useful for debugging. This option can be set via Getopt's -f. - -=back - -=head1 METHODS +This module provides some basic Test::Builder compatible test methods to +use when writing tests for you MooseX::Daemonize based modules. -=over +=head1 EXPORTED FUNCTIONS -=item check() +=over 4 -Check to see if an instance is already running. +=item B -=item start() +This will attempt to daemonize your C<$daemon> returning ok on +success and not ok on failure. -Setup a pidfile, fork, then setup the signal handlers. +=item B -=item stop() - -Stop the process matching the pidfile, and unlinks the pidfile. - -=item restart() - -Litterally - - $self->stop(); - $self->start(); - -=item daemonize() - -Calls C to daemonize this process. - -=item kill($pid) - -Kills the process for $pid. This will try SIGINT, and SIGTERM before falling back to SIGKILL and finally giving up. - -=item setup_signals() - -Setup the signal handlers, by default it only sets up handlers for SIGINT and SIGHUP - -=item handle_sigint() - -Handle a INT signal, by default calls C<$self->stop()>; - -=item handle_sighup() - -Handle a HUP signal. Nothing is done by default. - -=item meta() - -the C method from L +This is expected to be used with a C<$daemon> which does the +B role (included in this package +see the source for more info). It will collect the test output +from your daemon and apply it in the parent process by mucking +around with L stuff, again, read the source for +more info. If we get time we will document this more thoroughly. =back -=head1 DEPENDENCIES - -=for author to fill in: - A list of all the other modules that this module relies upon, - including any restrictions on versions, and an indication whether - the module is part of the standard Perl distribution, part of the - module's distribution, or must be installed separately. ] - -Obviously L, also L, L, L, L - =head1 INCOMPATIBILITIES -=for author to fill in: - A list of any modules that this module cannot be used in conjunction - with. This may be due to name conflicts in the interface, or - competition for system or program resources, or due to internal - limitations of Perl (for example, many modules that use source code - filters are mutually incompatible). - None reported. - =head1 BUGS AND LIMITATIONS -=for author to fill in: - A list of known problems with the module, together with some - indication Whether they are likely to be fixed in an upcoming - release. Also a list of restrictions on the features the module - does provide: data types that cannot be handled, performance issues - and the circumstances in which they may arise, practical - limitations on the size of data sets, special cases that are not - (yet) handled, etc. - No bugs have been reported. Please report any bugs or feature requests to @@ -205,21 +157,19 @@ L. =head1 SEE ALSO -L, L, L +L =head1 AUTHOR Chris Prather C<< >> - =head1 LICENCE AND COPYRIGHT -Copyright (c) 2007, Chris Prather C<< >>. All rights reserved. +Copyright (c) 2007-2008, Chris Prather C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. - =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY @@ -241,4 +191,6 @@ 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. + +=cut