File Coverage

blib/lib/Child/Link/Proc.pm
Criterion Covered Total %
statement 49 50 98.0
branch 14 22 63.6
condition 2 3 66.6
subroutine 12 12 100.0
pod 5 5 100.0
total 82 92 89.1


line stmt bran cond sub pod time code
1             package Child::Link::Proc;
2 20     20   63 use strict;
  20         23  
  20         441  
3 20     20   56 use warnings;
  20         20  
  20         345  
4 20     20   60 use Carp;
  20         16  
  20         934  
5              
6 20     20   65 use Carp;
  20         24  
  20         962  
7 20     20   75 use Child::Util;
  20         23  
  20         795  
8              
9 20     20   72 use base 'Child::Link';
  20         52  
  20         7392  
10              
11             add_accessors qw/exit/;
12              
13             sub is_complete {
14 31     31 1 2001647 my $self = shift;
15 31         115 $self->_wait();
16 31         76 return defined($self->exit);
17             }
18              
19             sub wait {
20 18     18 1 112 my $self = shift;
21 18 50       74 return unless $self->_wait(1);
22 18         61 return !$self->exit;
23             }
24              
25             sub exit_status {
26 13     13 1 46 my $self = shift;
27 13 50       42 return unless $self->is_complete;
28 13         27 return ($self->exit >> 8);
29             }
30              
31             sub unix_exit {
32 3     3 1 9 my $self = shift;
33 3 50       12 return unless $self->is_complete;
34 3         21 return $self->exit;
35             }
36              
37             sub _wait {
38 49     49   70 my $self = shift;
39 49         63 my ( $block ) = @_;
40             #non-blocking to check if process was terminated
41             #blocking to wait until it finishes
42 49 100       270 unless ( defined $self->exit ) {
43 26         31 my @flags;
44 26 100       3772 require POSIX unless $block;
45 26         25594 my $ret;
46 26         39 my $x = 1;
47 26   66     34 do {
48 26 50       89 sleep(1) if defined $ret;
49 26 100       153 $ret = waitpid( $self->pid, $block ? 0 : &POSIX::WNOHANG );
50             } while ( $block && !$ret );
51 26 100       88 return 0 unless $ret;
52 19 50       170 if ($^O eq 'MSWin32') {
53 0 0       0 croak( "wait returned $ret: No such process " . $self->pid )
54             if $ret == -1; #forked threads on Win32 have negative pids
55             } else {
56 19 50       82 croak( "wait returned $ret: No such process " . $self->pid )
57             if $ret < 0;
58             }
59 19         194 Child->_clean_proc($self);
60 19         115 $self->_exit( $? );
61             }
62 42         119 return defined($self->exit);
63             }
64              
65             sub kill {
66 7     7 1 3004489 my $self = shift;
67 7         27 my ( $sig ) = @_;
68 7         69 kill( $sig, $self->pid );
69             }
70              
71             1;
72              
73             =head1 NAME
74              
75             Child::Link::Proc - Proc object used by L.
76              
77             =head1 SEE ALSO
78              
79             This class inherits from:
80              
81             =over 4
82              
83             =item L
84              
85             =back
86              
87             =head1 METHODS
88              
89             =over 4
90              
91             =item $bool = $proc->is_complete()
92              
93             Check if the child is finished (non-blocking)
94              
95             =item $proc->wait()
96              
97             Wait until child terminates, destroy remaining zombie process (blocking)
98              
99             =item $proc->kill($SIG)
100              
101             Send the $SIG signal to the child process.
102              
103             B: kill() is unpredictable on windows, strawberry perl sends the kill
104             signal to the parent as well as the child.
105              
106             =item $proc->pid()
107              
108             Returns the process PID.
109              
110             =item $proc->exit_status()
111              
112             Will be undef unless the process has exited, otherwise it will have the exit
113             status.
114              
115             B: When you call exit($N) the actual unix exit status will be bit shifted
116             with extra information added. exit_status() will shift the value back for you.
117             That means exit_status() will return 2 when your child calls exit(2) see
118             unix_exit() if you want the actual value wait() assigned to $?.
119              
120             =item $proc->unix_exit()
121              
122             When you call exit($N) the actual unix exit status will be bit shifted
123             with extra information added. See exit_status() if you want the actual value
124             used in exit() in the child.
125              
126             =back
127              
128             =head1 HISTORY
129              
130             Most of this was part of L intended for use in the L
131             project. Fennec is being broken into multiple parts, this is one such part.
132              
133             =head1 FENNEC PROJECT
134              
135             This module is part of the Fennec project. See L for more details.
136             Fennec is a project to develop an extendable and powerful testing framework.
137             Together the tools that make up the Fennec framework provide a potent testing
138             environment.
139              
140             The tools provided by Fennec are also useful on their own. Sometimes a tool
141             created for Fennec is useful outside the greater framework. Such tools are
142             turned into their own projects. This is one such project.
143              
144             =over 2
145              
146             =item L - The core framework
147              
148             The primary Fennec project that ties them all together.
149              
150             =back
151              
152             =head1 AUTHORS
153              
154             Chad Granum L
155              
156             =head1 COPYRIGHT
157              
158             Copyright (C) 2010 Chad Granum
159              
160             Child is free software; Standard perl licence.
161              
162             Child is distributed in the hope that it will be useful, but WITHOUT
163             ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
164             FOR A PARTICULAR PURPOSE. See the license for more details.