Browse files

Merge branch 'refactor'

  • Loading branch information...
2 parents 651c90b + 2440745 commit 7154bd2358cd7e603ff45d67b61bb7a1e6c7184d @exodist committed Jul 24, 2010
Showing with 1,051 additions and 454 deletions.
  1. +57 −88 README
  2. +103 −301 lib/Child.pm
  3. +73 −0 lib/Child/IPC/Pipe.pm
  4. +68 −0 lib/Child/Link.pm
  5. +172 −0 lib/Child/Link/IPC.pm
  6. +83 −0 lib/Child/Link/IPC/Pipe.pm
  7. +70 −0 lib/Child/Link/IPC/Pipe/Parent.pm
  8. +70 −0 lib/Child/Link/IPC/Pipe/Proc.pm
  9. +84 −0 lib/Child/Link/Parent.pm
  10. +151 −0 lib/Child/Link/Proc.pm
  11. +87 −0 lib/Child/Util.pm
  12. +27 −56 t/Child.t
  13. +0 −4 t/Import.t
  14. +6 −5 t/Manage.t
View
145 README
@@ -17,136 +17,105 @@ SYNOPSIS
use Child;
my $child = Child->new(sub {
- my $self = shift;
+ my ( $parent ) = @_;
....
# exit() is called for you at the end.
});
+ my $proc = $child->start
+
+ # Kill the child if it is not done
+ $proc->complete || $proc->kill(9);
+
+ $proc->wait; #blocking
+ IPC
# Build with IPC
my $child2 = Child->new(sub {
my $self = shift;
$self->say("message1");
$self->say("message2");
my $reply = $self->read(1);
}, pipe => 1 );
+ my $proc2 = $child2->start;
# Read (blocking)
- my $message1 = $child2->read();
- my $message2 = $child2->read();
+ my $message1 = $proc2->read();
+ my $message2 = $proc2->read();
- $child2->say("reply");
-
- # Kill the child if it is not done
- $child->complete || $child->kill(9);
-
- $child->wait; #blocking
+ $proc2->say("reply");
SHORTCUT
- Child can export the child(&) shortcut function when requested. This
- function creates and starts the child process.
+ Child can export the child() shortcut function when requested. This
+ function creates and starts the child process in one action.
use Child qw/child/;
- my $child = child {
- my $self = shift;
+
+ my $proc = child {
+ my $parent = shift;
...
};
You can also request IPC:
use Child qw/child/;
+
my $child = child {
- my $self = shift;
+ my $parent = shift;
...
} pipe => 1;
- To add IPC to children created with child() by default, import with
- ':pipe'. How child() behaves regarding IPC is lexical to each importing
- class.
+DETAILS
+ First you define a child, you do this by constructing a Child object.
+ Defining a child does not start a new process, it is just the way to
+ define what the new process will look like. Once you have defined the
+ child you can start the process by calling $child->start(). One child
+ object can start as many processes as you like.
- use Child qw/child :pipe/;
+ When you start a child an Child::Link::Proc object is returned. This
+ object provides multiple useful methods for interacting with your
+ process. Within the process itself an Child::Link::Parent is created and
+ passed as the only parameter to the function used to define the child.
+ The parent object is how the child interacts with its parent.
- my $child = child {
- my $self = shift;
- $self->say("message1");
- };
+PROCESS MANAGEMENT METHODS
+ @procs = Child->all_procs()
+ Get a list of all the processes that have been started. This list is
+ cleared in processes when they are started; that is a child will not
+ list its siblings.
- my $message1 = $child->read();
-
-CLASS METHODS
- @children = Child->all_children()
- Get a list of all the children that have been started. This list is
- cleared in children when they are started.
-
- @pids = Child->all_child_pids()
- Get a list of all the pids of children that have been started.
+ @pids = Child->all_proc_pids()
+ Get a list of all the pids of processes that have been started.
Child->wait_all()
- Call wait() on all children.
+ Call wait() on all processes.
+
+EXPORTS
+ $proc = child( sub { ... } )
+ $proc = child { ... }
+ $proc = child( sub { ... }, $plugin, @data )
+ $proc = child { ... } $plugin => @data
+ Create and start a process in one action.
CONSTRUCTOR
- $class->new( sub { ... } )
- $class->new( sub { ... }, pipe => 1 )
+ $child = Child->new( sub { ... } )
+ $child = Child->new( sub { ... }, $plugin, @plugin_data )
Create a new Child object. Does not start the child.
OBJECT METHODS
- $child->start()
+ $proc = $child->start()
Start the child process.
- $bool = $child->is_complete()
- Check if the child is finished (non-blocking)
-
- $child->wait()
- Wait on the child (blocking)
-
- $child->kill($SIG)
- Send the $SIG signal to the child process.
-
- $child->read()
- Read a message from the child.
-
- $child->write( @MESSAGES )
- Send the messages to the child. works like print, you must add "\n".
-
- $child->say( @MESSAGES )
- Send the messages to the child. works like say, adds the seperator
- for you (usually "\n").
-
- $child->autoflush( $BOOL )
- Turn autoflush on/off for the current processes write handle. This
- is on by default.
-
- $child->flush()
- Flush the current processes write handle.
-
- $child->pid()
- Returns the child PID (only in parent process).
-
- $child->exit_status()
- Will be undef unless the process has exited, otherwise it will have
- the exit status.
-
- Note: When you call exit($N) the actual unix exit status will be bit
- shifed with extra information added. exit_status() will shift the
- value back for you. That means exit_status() will return 2 whun your
- child calls exit(2) see unix_exit() if you want the actual value
- wait() assigned to $?.
-
- $child->unix_exit()
- When you call exit($N) the actual unix exit status will be bit
- shifed with extra information added. See exit_status() if you want
- the actual value used in exit() in the child.
-
- $child->code()
- Returns the coderef used to construct the Child.
+SEE ALSO
+ Child::Link::Proc
+ The proc object that is returned by $child->start()
- $child->parent()
- Returns the parent processes PID. (Only in child)
+ Child::Link::Parent
+ The parent object that is provided as the argumunt to the function
+ used to define the child.
- $child->detach()
- Detach the child from the parent. uses POSIX::setsid(). When called
- in the child it simply calls setsid. When called from the parent the
- USR1 signal is sent to the child which triggers the child to call
- setsid.
+ Child::Link::IPC
+ The base class for IPC plugin link objects. This provides the IPC
+ methods.
HISTORY
Most of this was part of Parrallel::Runner intended for use in the
View
404 lib/Child.pm
@@ -2,246 +2,73 @@ package Child;
use strict;
use warnings;
use Carp;
+use Child::Util;
+use Child::Link::Proc;
+use Child::Link::Parent;
-our $VERSION = "0.006";
-our %META;
-our @CHILDREN;
+use base 'Exporter';
-for my $reader ( qw/pid ipc exit code parent detached/ ) {
- my $prop = "_$reader";
+our $VERSION = "0.007";
+our @PROCS;
+our @EXPORT_OK = qw/child/;
- my $psub = sub {
- my $self = shift;
- ($self->{ $prop }) = @_ if @_;
- return $self->{ $prop };
- };
-
- my $rsub = sub {
- my $self = shift;
- return $self->$prop();
- };
-
- no strict 'refs';
- *$reader = $rsub;
- *$prop = $psub;
-}
-
-sub import {
- my $class = shift;
- my $caller = caller;
- my @import;
- for ( @_ ) {
- if ( m/^:(.+)$/ ) {
- $META{$caller}->{$1}++
- }
- else {
- no strict 'refs';
- *{"$caller\::$_"} = $class->can( $_ )
- || croak "'$_' is not exported by $class.";
- }
- }
- 1;
-}
+add_accessors qw/code/;
sub child(&;@) {
- my ( $code, %params ) = @_;
+ my ( $code, @params ) = @_;
my $caller = caller;
- return __PACKAGE__->new($code, %{$META{$caller}}, %params )->start;
+ return __PACKAGE__->new( $code, @params )->start;
}
-sub all_children { @CHILDREN }
+sub all_procs { @PROCS }
-sub all_child_pids {
+sub all_proc_pids {
my $class = shift;
- map { $_->pid } $class->all_children;
+ map { $_->pid } $class->all_procs;
}
sub wait_all {
my $class = shift;
- $_->wait() for $class->all_children;
- 1;
+ $_->wait() for $class->all_procs;
}
sub new {
- my ( $class, $code, %params ) = @_;
- my %proto = ( _code => $code );
- $proto{_ipc} = $class->_gen_ipc()
- if $params{pipe};
- return bless( \%proto, $class );
-}
+ my ( $class, $code, $plugin, @data ) = @_;
-sub start {
- my $self = shift;
- my $parent = $$;
- if ( my $pid = fork() ) {
- $self->_pid( $pid );
- push @CHILDREN => $self;
- $self->_init_ipc if $self->ipc;
- }
- else {
- @CHILDREN = ();
- $self->_parent( $parent );
- $self->_init_ipc if $self->ipc;
- local $SIG{USR1} = sub { $self->detach };
- my $code = $self->code;
- $self->$code();
- exit;
- }
- return $self;
-}
+ return bless( { _code => $code }, $class )
+ unless $plugin;
-sub is_complete {
- my $self = shift;
- $self->_wait();
- return defined($self->exit);
-}
+ my $build = __PACKAGE__;
+ $build .= '::IPC::' . ucfirst $plugin;
-sub wait {
- my $self = shift;
- return unless $self->_wait(1);
- return !$self->exit;
-}
+ eval "require $build; 1"
+ || croak( "Could not load plugin '$plugin': $@" );
-sub exit_status {
- my $self = shift;
- return unless $self->is_complete;
- return ($self->exit >> 8);
+ return $build->new( $code, @data );
}
-sub unix_exit {
- my $self = shift;
- return unless $self->is_complete;
- return $self->exit;
-}
+sub shared_data {}
-sub _wait {
- my $self = shift;
- my ( $block ) = @_;
- unless ( defined $self->exit ) {
- my @flags;
- require POSIX unless $block;
- my $ret;
- my $x = 1;
- do {
- sleep(1) if defined $ret;
- $ret = waitpid( $self->pid, $block ? 0 : &POSIX::WNOHANG );
- } while ( $block && !$ret );
- return 0 unless $ret;
- croak( "wait returned $ret: No such process " . $self->pid )
- if $ret < 0;
- $self->_exit( $? );
- }
- return defined($self->exit);
-}
+sub child_class { 'Child::Link::Proc' }
+sub parent_class { 'Child::Link::Parent' }
-sub kill {
+sub start {
my $self = shift;
- my ( $sig ) = @_;
- kill( $sig, $self->pid );
-}
-
-sub _gen_ipc {
- my $class = shift;
- pipe( my ( $ain, $aout ));
- pipe( my ( $bin, $bout ));
- return [
- [ $ain, $aout ],
- [ $bin, $bout ],
- ];
-}
+ my $ppid = $$;
+ my @data = $self->shared_data;
-sub _init_ipc {
- my $self = shift;
- # Cross the pipes.
- if ( $self->parent ) {
- $self->_ipc([
- $self->_ipc->[1],
- $self->_ipc->[0],
- ]);
+ if ( my $pid = fork() ) {
+ my $proc = $self->child_class->new( $pid, @data );
+ push @PROCS => $proc;
+ return $proc;
}
- $self->_ipc->[0] = $self->_ipc->[0]->[0];
- $self->_ipc->[1] = $self->_ipc->[1]->[1];
- $self->autoflush(1);
-}
-
-sub _read_handle {
- my $self = shift;
- $self->_no_pipe unless $self->_ipc;
- return $self->_ipc->[0];
-}
-
-sub _write_handle {
- my $self = shift;
- $self->_no_pipe unless $self->_ipc;
- return $self->_ipc->[1];
-}
-
-sub _no_pipe {
- croak(
- "Child was created without IPC support.",
- "To enable IPC construct the child with Child->new( sub { ... }, pipe => 1 )",
- "If you use child { ... }; then import Child with the ':pipe' argumunt",
- "use Child qw/child :pipe/",
- );
-}
-
-sub autoflush {
- my $self = shift;
- my ( $value ) = @_;
- my $write = $self->_write_handle;
-
- my $selected = select( $write );
- $| = $value if @_;
- my $out = $|;
-
- select( $selected );
-
- return $out;
-}
-
-sub flush {
- my $self = shift;
- my $orig = $self->autoflush();
- $self->autoflush(1);
- my $write = $self->_write_handle;
- $self->autoflush($orig);
-}
-
-sub read {
- my $self = shift;
- my $handle = $self->_read_handle;
- return <$handle>;
-}
-
-sub say {
- my $self = shift;
- $self->write( map {$_ . $/} @_ );
-}
-
-sub write {
- my $self = shift;
- my $handle = $self->_write_handle;
- print $handle @_;
-}
-sub detach {
- my $self = shift;
- return $self->_detach_as_parent if $self->pid;
- return $self->_detach_as_child if $self->parent;
- croak( "Nothing to detach" )
-}
-
-sub _detach_as_parent {
- my $self = shift;
- require POSIX;
- $self->kill(POSIX::SIGUSR1());
-}
-
-sub _detach_as_child {
- my $self = shift;
- require POSIX;
- $self->_detached( POSIX::setsid() )
- || die "Cannot detach from parent $!";
+ # In the child
+ @PROCS = ();
+ my $parent = $self->parent_class->new( $ppid, @data );
+ my $code = $self->code;
+ $code->( $parent );
+ exit;
}
1;
@@ -270,10 +97,18 @@ waiting, killing, checking, and even communicating with a child process.
use Child;
my $child = Child->new(sub {
- my $self = shift;
+ my ( $parent ) = @_;
....
# exit() is called for you at the end.
});
+ my $proc = $child->start
+
+ # Kill the child if it is not done
+ $proc->complete || $proc->kill(9);
+
+ $proc->wait; #blocking
+
+=head2 IPC
# Build with IPC
my $child2 = Child->new(sub {
@@ -282,155 +117,122 @@ waiting, killing, checking, and even communicating with a child process.
$self->say("message2");
my $reply = $self->read(1);
}, pipe => 1 );
+ my $proc2 = $child2->start;
# Read (blocking)
- my $message1 = $child2->read();
- my $message2 = $child2->read();
+ my $message1 = $proc2->read();
+ my $message2 = $proc2->read();
- $child2->say("reply");
-
- # Kill the child if it is not done
- $child->complete || $child->kill(9);
-
- $child->wait; #blocking
+ $proc2->say("reply");
=head2 SHORTCUT
-Child can export the child(&) shortcut function when requested. This function
-creates and starts the child process.
+Child can export the child() shortcut function when requested. This function
+creates and starts the child process in one action.
use Child qw/child/;
- my $child = child {
- my $self = shift;
+
+ my $proc = child {
+ my $parent = shift;
...
};
You can also request IPC:
use Child qw/child/;
+
my $child = child {
- my $self = shift;
+ my $parent = shift;
...
} pipe => 1;
-To add IPC to children created with child() by default, import with ':pipe'.
-How child() behaves regarding IPC is lexical to each importing class.
-
- use Child qw/child :pipe/;
+=head1 DETAILS
- my $child = child {
- my $self = shift;
- $self->say("message1");
- };
+First you define a child, you do this by constructing a L<Child> object.
+Defining a child does not start a new process, it is just the way to define
+what the new process will look like. Once you have defined the child you can
+start the process by calling $child->start(). One child object can start as
+many processes as you like.
- my $message1 = $child->read();
+When you start a child an L<Child::Link::Proc> object is returned. This object
+provides multiple useful methods for interacting with your process. Within the
+process itself an L<Child::Link::Parent> is created and passed as the only
+parameter to the function used to define the child. The parent object is how
+the child interacts with its parent.
-=head1 CLASS METHODS
+=head1 PROCESS MANAGEMENT METHODS
=over 4
-=item @children = Child->all_children()
+=item @procs = Child->all_procs()
-Get a list of all the children that have been started. This list is cleared in
-children when they are started.
+Get a list of all the processes that have been started. This list is cleared in
+processes when they are started; that is a child will not list its siblings.
-=item @pids = Child->all_child_pids()
+=item @pids = Child->all_proc_pids()
-Get a list of all the pids of children that have been started.
+Get a list of all the pids of processes that have been started.
=item Child->wait_all()
-Call wait() on all children.
+Call wait() on all processes.
=back
-=head1 CONSTRUCTOR
+=head1 EXPORTS
=over 4
-=item $class->new( sub { ... } )
-
-=item $class->new( sub { ... }, pipe => 1 )
-
-Create a new Child object. Does not start the child.
-
-=back
-
-=head1 OBJECT METHODS
-
-=over
-
-=item $child->start()
-
-Start the child process.
-
-=item $bool = $child->is_complete()
+=item $proc = child( sub { ... } )
-Check if the child is finished (non-blocking)
+=item $proc = child { ... }
-=item $child->wait()
+=item $proc = child( sub { ... }, $plugin, @data )
-Wait on the child (blocking)
+=item $proc = child { ... } $plugin => @data
-=item $child->kill($SIG)
+Create and start a process in one action.
-Send the $SIG signal to the child process.
-
-=item $child->read()
-
-Read a message from the child.
-
-=item $child->write( @MESSAGES )
-
-Send the messages to the child. works like print, you must add "\n".
+=back
-=item $child->say( @MESSAGES )
+=head1 CONSTRUCTOR
-Send the messages to the child. works like say, adds the seperator for you
-(usually "\n").
+=over 4
-=item $child->autoflush( $BOOL )
+=item $child = Child->new( sub { ... } )
-Turn autoflush on/off for the current processes write handle. This is on by
-default.
+=item $child = Child->new( sub { ... }, $plugin, @plugin_data )
-=item $child->flush()
+Create a new Child object. Does not start the child.
-Flush the current processes write handle.
+=back
-=item $child->pid()
+=head1 OBJECT METHODS
-Returns the child PID (only in parent process).
+=over
-=item $child->exit_status()
+=item $proc = $child->start()
-Will be undef unless the process has exited, otherwise it will have the exit
-status.
+Start the child process.
-B<Note>: When you call exit($N) the actual unix exit status will be bit shifed
-with extra information added. exit_status() will shift the value back for you.
-That means exit_status() will return 2 whun your child calls exit(2) see
-unix_exit() if you want the actual value wait() assigned to $?.
+=back
-=item $child->unix_exit()
+=head1 SEE ALSO
-When you call exit($N) the actual unix exit status will be bit shifed
-with extra information added. See exit_status() if you want the actual value
-used in exit() in the child.
+=over 4
-=item $child->code()
+=item L<Child::Link::Proc>
-Returns the coderef used to construct the Child.
+The proc object that is returned by $child->start()
-=item $child->parent()
+=item L<Child::Link::Parent>
-Returns the parent processes PID. (Only in child)
+The parent object that is provided as the argumunt to the function used to
+define the child.
-=item $child->detach()
+=item L<Child::Link::IPC>
-Detach the child from the parent. uses POSIX::setsid(). When called in the
-child it simply calls setsid. When called from the parent the USR1 signal is
-sent to the child which triggers the child to call setsid.
+The base class for IPC plugin link objects. This provides the IPC methods.
=back
View
73 lib/Child/IPC/Pipe.pm
@@ -0,0 +1,73 @@
+package Child::IPC::Pipe;
+use strict;
+use warnings;
+
+use Child::Link::IPC::Pipe::Proc;
+use Child::Link::IPC::Pipe::Parent;
+
+use base 'Child';
+
+sub child_class { 'Child::Link::IPC::Pipe::Proc' }
+sub parent_class { 'Child::Link::IPC::Pipe::Parent' }
+
+sub shared_data {
+ pipe( my ( $ain, $aout ));
+ pipe( my ( $bin, $bout ));
+ return [
+ [ $ain, $aout ],
+ [ $bin, $bout ],
+ ];
+}
+
+sub new {
+ my ( $class, $code ) = @_;
+ return bless( { _code => $code }, $class );
+}
+
+1;
+
+=head1 NAME
+
+Child::IPC::Pipe - Pipe based IPC plugin for L<Child>
+
+=head1 DESCRIPTION
+
+Creates 2 pipes just before forking.
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
68 lib/Child/Link.pm
@@ -0,0 +1,68 @@
+package Child::Link;
+use strict;
+use warnings;
+
+use Child::Util;
+use Carp qw/croak/;
+
+add_accessors qw/pid/;
+
+sub ipc { undef }
+
+sub _no_ipc { croak "Child was created without IPC support" }
+
+sub new {
+ my $class = shift;
+ my ( $pid ) = @_;
+ return bless( { _pid => $pid }, $class );
+}
+
+{
+ no strict 'refs';
+ *{__PACKAGE__ . '::' . $_} = \&_no_ipc
+ for qw/autoflush flush read say write/;
+}
+
+1;
+
+=head1 NAME
+
+Child::Link - Base class for objects that link child and parent processes.
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
172 lib/Child/Link/IPC.pm
@@ -0,0 +1,172 @@
+package Child::Link::IPC;
+use strict;
+use warnings;
+
+use Child::Util;
+
+use base 'Child::Link';
+
+add_accessors qw/ipc/;
+add_abstract qw/
+ read_handle
+ write_handle
+/;
+
+sub init {}
+
+sub new {
+ my $class = shift;
+ my ( $pid, @shared ) = @_;
+ my $self = $class->SUPER::new($pid);
+ $self->init( @shared );
+ return $self;
+}
+
+sub autoflush {
+ my $self = shift;
+ my ( $value ) = @_;
+ my $write = $self->write_handle;
+
+ my $selected = select( $write );
+ $| = $value if @_;
+ my $out = $|;
+
+ select( $selected );
+
+ return $out;
+}
+
+sub flush {
+ my $self = shift;
+ my $orig = $self->autoflush();
+ $self->autoflush(1);
+ my $write = $self->write_handle;
+ $self->autoflush($orig);
+}
+
+sub read {
+ my $self = shift;
+ my $handle = $self->read_handle;
+ return <$handle>;
+}
+
+sub say {
+ my $self = shift;
+ $self->write( map {$_ . $/} @_ );
+}
+
+sub write {
+ my $self = shift;
+ my $handle = $self->write_handle;
+ print $handle @_;
+}
+
+1;
+
+=head1 NAME
+
+Child::Link::IPC - Base class for process links that provide IPC.
+
+=head1 SEE ALSO
+
+This class inherits from:
+
+=over 4
+
+=item L<Child::Link>
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $proc->new( $pid. @shared )
+
+Constructor
+
+=item $proc->read()
+
+Read a message from the child.
+
+=item $proc->write( @MESSAGES )
+
+Send the messages to the child. works like print, you must add "\n".
+
+=item $proc->say( @MESSAGES )
+
+Send the messages to the child. works like say, adds the seperator for you
+(usually "\n").
+
+=item $proc->autoflush( $BOOL )
+
+Turn autoflush on/off for the current processes write handle. This is on by
+default.
+
+=item $proc->flush()
+
+Flush the current processes write handle.
+
+=item $proc->ipc()
+
+=item $proc->_ipc( $new )
+
+Accessors for you to use or ignore.
+
+=back
+
+=head1 ABSTRACT METHODS
+
+=over 4
+
+=item $proc->read_handle()
+
+Should return a read handle for reading from the child.
+
+=item $proc->write_handle()
+
+Should return a write handle for writing to the child.
+
+=item $proc->init( @shared )
+
+Called by new during construction
+
+=back
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
83 lib/Child/Link/IPC/Pipe.pm
@@ -0,0 +1,83 @@
+package Child::Link::IPC::Pipe;
+use strict;
+use warnings;
+
+use Child::Util;
+
+use base 'Child::Link::IPC';
+
+add_abstract qw/cross_pipes/;
+
+sub read_handle { shift->ipc->[0] }
+sub write_handle { shift->ipc->[1] }
+
+sub init {
+ my $self = shift;
+ my ($pipes) = @_;
+
+ $pipes = [
+ $pipes->[1],
+ $pipes->[0],
+ ] if $self->cross_pipes;
+
+ $self->_ipc([
+ $pipes->[0]->[0],
+ $pipes->[1]->[1],
+ ]);
+ $self->autoflush(1);
+}
+
+1;
+
+=head1 NAME
+
+Child::Link::IPC::Pipe - Base class for link objects used by the
+L<Child::IPC::Pipe> plugin.
+
+=head1 SEE ALSO
+
+This class inherits from:
+
+=over 4
+
+=item L<Child::Link::IPC>
+
+=back
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
70 lib/Child/Link/IPC/Pipe/Parent.pm
@@ -0,0 +1,70 @@
+package Child::Link::IPC::Pipe::Parent;
+use strict;
+use warnings;
+
+use Child::Util;
+
+use base qw/
+ Child::Link::IPC::Pipe
+ Child::Link::Parent
+/;
+
+sub cross_pipes { 1 };
+
+1;
+
+=head1 NAME
+
+Child::Link::IPC::Pipe::Parent - Parent object used by the pipe plugin.
+
+=head1 SEE ALSO
+
+This class inherits from:
+
+=over 4
+
+=item L<Child::Link::Parent>
+
+=item L<Child::Link::IPC>
+
+=item L<Child::Link::IPC::Pipe>
+
+=back
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
70 lib/Child/Link/IPC/Pipe/Proc.pm
@@ -0,0 +1,70 @@
+package Child::Link::IPC::Pipe::Proc;
+use strict;
+use warnings;
+
+use Child::Util;
+
+use base qw/
+ Child::Link::IPC::Pipe
+ Child::Link::Proc
+/;
+
+sub cross_pipes { 0 };
+
+1;
+
+=head1 NAME
+
+Child::Link::IPC::Pipe::Proc - Proc object used by the pipe plugin.
+
+=head1 SEE ALSO
+
+This class inherits from:
+
+=over 4
+
+=item L<Child::Link::Proc>
+
+=item L<Child::Link::IPC>
+
+=item L<Child::Link::IPC::Pipe>
+
+=back
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
84 lib/Child/Link/Parent.pm
@@ -0,0 +1,84 @@
+package Child::Link::Parent;
+use strict;
+use warnings;
+
+use Child::Util;
+
+use base 'Child::Link';
+
+add_accessors qw/detached/;
+
+sub detach {
+ my $self = shift;
+ require POSIX;
+ $self->_detached( POSIX::setsid() )
+ || die "Cannot detach from parent $!";
+}
+
+1;
+
+=head1 NAME
+
+Child::Link::Proc - Proc object used by L<Child>.
+
+=head1 SEE ALSO
+
+This class inherits from:
+
+=over 4
+
+=item L<Child::Link>
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $proc->pid()
+
+Returns the parent process PID.
+
+=item $proc->detach()
+
+Detach the from the parent. uses POSIX::setsid().
+
+=back
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
151 lib/Child/Link/Proc.pm
@@ -0,0 +1,151 @@
+package Child::Link::Proc;
+use strict;
+use warnings;
+
+use Child::Util;
+
+use base 'Child::Link';
+
+add_accessors qw/exit/;
+
+sub is_complete {
+ my $self = shift;
+ $self->_wait();
+ return defined($self->exit);
+}
+
+sub wait {
+ my $self = shift;
+ return unless $self->_wait(1);
+ return !$self->exit;
+}
+
+sub exit_status {
+ my $self = shift;
+ return unless $self->is_complete;
+ return ($self->exit >> 8);
+}
+
+sub unix_exit {
+ my $self = shift;
+ return unless $self->is_complete;
+ return $self->exit;
+}
+
+sub _wait {
+ my $self = shift;
+ my ( $block ) = @_;
+ unless ( defined $self->exit ) {
+ my @flags;
+ require POSIX unless $block;
+ my $ret;
+ my $x = 1;
+ do {
+ sleep(1) if defined $ret;
+ $ret = waitpid( $self->pid, $block ? 0 : &POSIX::WNOHANG );
+ } while ( $block && !$ret );
+ return 0 unless $ret;
+ croak( "wait returned $ret: No such process " . $self->pid )
+ if $ret < 0;
+ $self->_exit( $? );
+ }
+ return defined($self->exit);
+}
+
+sub kill {
+ my $self = shift;
+ my ( $sig ) = @_;
+ kill( $sig, $self->pid );
+}
+
+1;
+
+=head1 NAME
+
+Child::Link::Proc - Proc object used by L<Child>.
+
+=head1 SEE ALSO
+
+This class inherits from:
+
+=over 4
+
+=item L<Child::Link>
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $bool = $proc->is_complete()
+
+Check if the child is finished (non-blocking)
+
+=item $proc->wait()
+
+Wait on the child (blocking)
+
+=item $proc->kill($SIG)
+
+Send the $SIG signal to the child process.
+
+=item $proc->pid()
+
+Returns the process PID.
+
+=item $proc->exit_status()
+
+Will be undef unless the process has exited, otherwise it will have the exit
+status.
+
+B<Note>: When you call exit($N) the actual unix exit status will be bit shifed
+with extra information added. exit_status() will shift the value back for you.
+That means exit_status() will return 2 whun your child calls exit(2) see
+unix_exit() if you want the actual value wait() assigned to $?.
+
+=item $proc->unix_exit()
+
+When you call exit($N) the actual unix exit status will be bit shifed
+with extra information added. See exit_status() if you want the actual value
+used in exit() in the child.
+
+=back
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
87 lib/Child/Util.pm
@@ -0,0 +1,87 @@
+package Child::Util;
+use strict;
+use warnings;
+use Carp qw/croak/;
+
+use base 'Exporter';
+our @EXPORT = qw/add_accessors add_abstract/;
+
+sub _abstract {
+ my $class = shift;
+ croak "$class does not implement this function."
+}
+
+sub add_abstract {
+ my $caller = caller;
+ no strict 'refs';
+ *{"$caller\::$_"} = \&_abstract for @_;
+}
+
+sub add_accessors {
+ my $class = caller;
+ _add_accessor( $class, $_ ) for @_;
+}
+
+sub _add_accessor {
+ my ( $class, $reader ) = @_;
+ my $prop = "_$reader";
+
+ my $psub = sub {
+ my $self = shift;
+ ($self->{ $prop }) = @_ if @_;
+ return $self->{ $prop };
+ };
+
+ my $rsub = sub {
+ my $self = shift;
+ return $self->$prop();
+ };
+
+ no strict 'refs';
+ *{"$class\::$reader"} = $rsub;
+ *{"$class\::$prop"} = $psub;
+}
+
+1;
+
+=head1 NAME
+
+Child::Util - Utility functions for L>Child>
+
+=head1 HISTORY
+
+Most of this was part of L<Parrallel::Runner> intended for use in the L<Fennec>
+project. Fennec is being broken into multiple parts, this is one such part.
+
+=head1 FENNEC PROJECT
+
+This module is part of the Fennec project. See L<Fennec> for more details.
+Fennec is a project to develop an extendable and powerful testing framework.
+Together the tools that make up the Fennec framework provide a potent testing
+environment.
+
+The tools provided by Fennec are also useful on their own. Sometimes a tool
+created for Fennec is useful outside the greator framework. Such tools are
+turned into their own projects. This is one such project.
+
+=over 2
+
+=item L<Fennec> - The core framework
+
+The primary Fennec project that ties them all together.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2010 Chad Granum
+
+Child is free software; Standard perl licence.
+
+Child is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+FOR A PARTICULAR PURPOSE. See the license for more details.
View
83 t/Child.t
@@ -7,66 +7,52 @@ our $CLASS = 'Child';
require_ok( $CLASS );
-can_ok(
- $CLASS,
- map {( $_, "_$_" )}
- qw/pid ipc exit code parent/
-);
-
-my $one = bless( {}, $CLASS );
-ok( !$one->ipc, "Not set" );
-ok( !$one->ipc(1), "Not setting" );
-ok( !$one->ipc, "Was not set" );
-
-is( $one->_ipc(1), 1, "setting" );
-is( $one->ipc, 1, "Was set" );
-
-$one = $CLASS->new( sub {
+my $child = $CLASS->new( sub {
my $self = shift;
$self->say( "Have self" );
- $self->say( "parent: " . $self->parent );
+ $self->say( "parent: " . $self->pid );
my $in = $self->read();
$self->say( $in );
}, pipe => 1 );
-$one->start;
-is( $one->read(), "Have self\n", "child has self" );
-is( $one->read(), "parent: $$\n", "child has parent PID" );
+my $proc = $child->start;
+is( $proc->read(), "Have self\n", "child has self" );
+is( $proc->read(), "parent: $$\n", "child has parent PID" );
{
local $SIG{ALRM} = sub { die "non-blocking timeout" };
alarm 5;
- ok( !$one->is_complete, "Not Complete" );
+ ok( !$proc->is_complete, "Not Complete" );
alarm 0;
}
-$one->say("XXX");
-is( $one->read(), "XXX\n", "Full IPC" );
-ok( $one->wait, "wait" );
-ok( $one->is_complete, "Complete" );
-is( $one->exit_status, 0, "Exit clean" );
+$proc->say("XXX");
+is( $proc->read(), "XXX\n", "Full IPC" );
+ok( $proc->wait, "wait" );
+ok( $proc->is_complete, "Complete" );
+is( $proc->exit_status, 0, "Exit clean" );
-$one = $CLASS->new( sub { sleep 100 } )->start;
+$proc = $CLASS->new( sub { sleep 100 } )->start;
-my $ret = eval { $one->say("XXX"); 1 };
+my $ret = eval { $proc->say("XXX"); 1 };
ok( !$ret, "Died, no IPC" );
like( $@, qr/Child was created without IPC support./, "No IPC" );
-$one->kill(2);
+$proc->kill(2);
-$one = $CLASS->new( sub {
+$proc = $CLASS->new( sub {
my $self = shift;
$SIG{INT} = sub { exit( 2 ) };
$self->say( "go" );
sleep 100;
}, pipe => 1 )->start;
-$one->read;
+$proc->read;
sleep 1;
-ok( $one->kill(2), "Send signal" );
-ok( !$one->wait, "wait" );
-ok( $one->is_complete, "Complete" );
-is( $one->exit_status, 2, "Exit 2" );
-ok( $one->unix_exit > 2, "Real exit" );
+ok( $proc->kill(2), "Send signal" );
+ok( !$proc->wait, "wait" );
+ok( $proc->is_complete, "Complete" );
+is( $proc->exit_status, 2, "Exit 2" );
+ok( $proc->unix_exit > 2, "Real exit" );
-$one = $CLASS->new( sub {
+$child = $CLASS->new( sub {
my $self = shift;
$self->autoflush(0);
$self->say( "A" );
@@ -76,35 +62,20 @@ $one = $CLASS->new( sub {
$self->flush;
}, pipe => 1 );
-$one->start;
-is( $one->read(), "A\n", "A" );
+$proc = $child->start;
+is( $proc->read(), "A\n", "A" );
my $start = time;
-is( $one->read(), "B\n", "B" );
+is( $proc->read(), "B\n", "B" );
my $end = time;
ok( $end - $start > 2, "No autoflush" );
-$one = $CLASS->new( sub {
+$proc = $CLASS->new( sub {
my $self = shift;
$self->detach;
$self->say( $self->detached );
}, pipe => 1 )->start;
-is( $one->read(), $one->pid . "\n", "Child detached" );
-
-
-$one = $CLASS->new( sub {
- my $self = shift;
- $self->say( "go" );
- $self->read;
- $self->say( $self->detached );
-}, pipe => 1 )->start;
-
-$one->read();
-$one->detach;
-sleep 1;
-$one->say("go");
-
-is( $one->read(), $one->pid . "\n", "Child detached remotely" );
+is( $proc->read(), $proc->pid . "\n", "Child detached" );
done_testing;
View
4 t/Import.t
@@ -17,8 +17,4 @@ ok( !$one->ipc, "no ipc by default" );
$one = child( sub { 1 }, pipe => 1 );
ok( $one->ipc, "ipc by param" );
-$CLASS->import(':pipe');
-$one = child( sub { 1 });
-ok( $one->ipc, "ipc added" );
-
done_testing;
View
11 t/Manage.t
@@ -6,18 +6,19 @@ use Test::More;
our $CLASS = 'Child';
require_ok( $CLASS );
-my @all = map { $CLASS->new(sub { 1 }) } 1 .. 4;
-my @get = $CLASS->all_children;
+my @children = map { $CLASS->new(sub { 1 }) } 1 .. 4;
+my @get = $CLASS->all_procs;
is( @get, 0, "0 children started" );
-$_->start for @all;
+my @all;
+push @all => $_->start for @children;
-@get = $CLASS->all_children;
+@get = $CLASS->all_procs;
is( @get, 4, "4 children" );
is_deeply( \@get, \@all, "Exact list" );
is_deeply(
- [ $CLASS->all_child_pids ],
+ [ $CLASS->all_proc_pids ],
[ map { $_->pid } @all ],
"pids"
);

0 comments on commit 7154bd2

Please sign in to comment.