Permalink
Browse files

support callback function.

  • Loading branch information...
1 parent 49bbf14 commit 677739beff74ab330ef57e173aa476a29030f174 @tokuhirom committed Nov 30, 2010
Showing with 110 additions and 8 deletions.
  1. +21 −2 README.mkdn
  2. +46 −6 lib/Proc/Guard.pm
  3. +1 −0 t/{01_simple.t → 01_command.t}
  4. +42 −0 t/02_code.t
View
@@ -9,11 +9,18 @@ Proc::Guard - process runner with RAII pattern
use Proc::Guard;
my $port = empty_port();
- my $proc = proc_guard(which('memcached'), '-p', $port);
+ my $proc = proc_guard(scalar(which('memcached')), '-p', $port);
wait_port($port);
# your code here
+ # --------------
+ # or, use perl code
+ my $proc = proc_guard(sub {
+ ... # run this code in child process
+ });
+ ...
+
# DESCRIPTION
Proc::Guard runs process, and destroys it when the perl script exits.
@@ -22,14 +29,20 @@ This is useful for testing code working with server process.
# FUNCTIONS
-- proc_guard(@cmdline)
+- proc_guard(@cmdline|\&code)
This is shorthand for:
Proc::Guard->new(
command => \@cmdline,
);
+or
+
+ Proc::Guard->new(
+ code => \&code,
+ );
+
# METHODS
- my $proc = Proc::Guard->new(%args);
@@ -44,6 +57,12 @@ Create and run a process. The process is terminated when the returned object is
The command line.
+ - code
+
+ Proc::Guard->new(code => sub { ... });
+
+ 'code' or 'command' is required.
+
- auto_start
Proc::Guard->new(auto_start => 0);
View
@@ -3,26 +3,42 @@ use strict;
use warnings;
use 5.00800;
our $VERSION = '0.03';
+use Carp ();
# functional interface
our @EXPORT = qw/proc_guard/;
use Exporter 'import';
-sub proc_guard { Proc::Guard->new(command => [@_]) }
+sub proc_guard {
+ return Proc::Guard->new(do {
+ if (@_==1 && ref($_[0]) && ref($_[0]) eq 'CODE') {
+ +{ code => $_[0] }
+ } else {
+ +{ command => [@_] }
+ }
+ });
+}
# OOish interface
use POSIX;
use Class::Accessor::Lite;
Class::Accessor::Lite->mk_accessors(qw/pid/);
sub new {
- my ($class, %args) = @_;
+ my $class = shift;
+ my %args = @_==1 ? %{$_[0]} : @_;
my $self = bless {
_owner_pid => $$,
auto_start => 1,
%args,
}, $class;
- $self->{command} = [$self->{command}] unless ref $self->{command};
+
+ if ($self->{command} && !ref($self->{command})) {
+ $self->{command} = [$self->{command}];
+ }
+ unless ($self->{command} || $self->{code}) {
+ Carp::croak("'command' or 'code' is required.");
+ }
$self->start()
if $self->{auto_start};
@@ -36,8 +52,13 @@ sub start {
my $pid = fork();
die "fork failed: $!" unless defined $pid;
if ($pid == 0) { # child
- exec @{$self->{command}};
- die "cannot exec @{$self->{command}}: $!";
+ if ($self->{command}) {
+ exec @{$self->{command}};
+ die "cannot exec @{$self->{command}}: $!";
+ } else {
+ $self->{code}->();
+ exit(0); # exit after work
+ }
}
$self->pid($pid);
}
@@ -80,6 +101,13 @@ Proc::Guard - process runner with RAII pattern
# your code here
+ # --------------
+ # or, use perl code
+ my $proc = proc_guard(sub {
+ ... # run this code in child process
+ });
+ ...
+
=head1 DESCRIPTION
Proc::Guard runs process, and destroys it when the perl script exits.
@@ -90,14 +118,20 @@ This is useful for testing code working with server process.
=over 4
-=item proc_guard(@cmdline)
+=item proc_guard(@cmdline|\&code)
This is shorthand for:
Proc::Guard->new(
command => \@cmdline,
);
+or
+
+ Proc::Guard->new(
+ code => \&code,
+ );
+
=back
=head1 METHODS
@@ -118,6 +152,12 @@ Create and run a process. The process is terminated when the returned object is
The command line.
+=item code
+
+ Proc::Guard->new(code => sub { ... });
+
+'code' or 'command' is required.
+
=item auto_start
Proc::Guard->new(auto_start => 0);
@@ -3,6 +3,7 @@ use warnings;
use Test::More;
use Test::Requires qw/File::Which Test::TCP/;
use Proc::Guard;
+use IO::Socket::INET;
my $memcached_bin = File::Which::which('memcached');
plan skip_all => "This test requires memcached binary" unless $memcached_bin;
View
@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires qw/File::Which Test::TCP Test::SharedFork/;
+use Proc::Guard;
+use IO::Socket::INET;
+
+my $port = Test::TCP::empty_port();
+my $pid;
+{
+ my $proc = proc_guard(sub {
+ my $sock = IO::Socket::INET->new(
+ LocalHost => '127.0.0.1',
+ LocalPort => $port,
+ Proto => 'tcp',
+ ReuseAddr => 1,
+ Listen => 10,
+ ) or die $!;
+ while (my $csock = $sock->accept) {
+ my $msg = <$csock>;
+ defined($msg) or next;
+ is $msg, "ping\r\n";
+ print {$csock} "pong\r\n";
+ close $csock;
+ }
+ });
+ $pid = $proc->pid;
+ ok $proc->pid, 'memcached: ' . $proc->pid;
+ Test::TCP::wait_port($port);
+
+ my $sock = IO::Socket::INET->new(
+ PeerAddr => '127.0.0.1',
+ PeerPort => $port,
+ Proto => 'tcp',
+ ) or die $!;
+ print $sock "ping\r\n";
+ my $res = <$sock>;
+ is $res, "pong\r\n";
+}
+is scalar(kill($pid)), 0, 'already killed';
+
+done_testing;

0 comments on commit 677739b

Please sign in to comment.