File Coverage

blib/lib/XAS/Lib/Process/Unix.pm
Criterion Covered Total %
statement 15 123 12.2
branch 0 46 0.0
condition 0 6 0.0
subroutine 5 16 31.2
pod 7 8 87.5
total 27 199 13.5


line stmt bran cond sub pod time code
1             package XAS::Lib::Process::Unix;
2              
3             our $VERSION = '0.02';
4              
5 1     1   1349 use POE;
  1         1  
  1         4  
6 1     1   209 use Socket;
  1         1  
  1         473  
7 1     1   4 use IO::Socket;
  1         2  
  1         9  
8 1     1   666 use POSIX qw(setsid);
  1         2  
  1         9  
9              
10             use XAS::Class
11 1         9 debug => 0,
12             version => $VERSION,
13             base => 'XAS::Base',
14             mixin => 'XAS::Lib::Mixins::Process',
15             utils => ':env dotid compress trim create_argv',
16             mixins => 'start_process stop_process pause_process resume_process
17             stat_process kill_process init_process _parse_command
18             _poll_child destroy',
19             constants => ':process',
20 1     1   75 ;
  1         1  
21              
22             #use Data::Dumper;
23              
24             # ----------------------------------------------------------------------
25             # Public Methods
26             # ----------------------------------------------------------------------
27              
28             sub start_process {
29 0     0 1   my $self = shift;
30              
31 0           my $pid;
32 0           my $alias = $self->alias;
33 0           my $umask = oct($self->umask);
34 0           my $env = $self->environment;
35 0           my @argv = $self->_parse_command;
36 0           my $priority = $self->priority;
37 0 0         my $uid = ($self->user eq 'root') ? 0 : getpwnam($self->user);
38 0 0         my $gid = ($self->group eq 'root') ? 0 : getgrnam($self->group);
39 0           my $directory = $self->directory->path;
40              
41             # save the current environment
42              
43 0           my $oldenv = env_store();
44 0           my $newenv = $self->merger->merge($oldenv, $env);
45              
46             my $spawn = sub {
47              
48 0     0     setsid(); # become a session lead
49              
50 0           eval { # set priority, fail silently
51 0           my $p = getpriority(0, $$);
52 0           setpriority(0, $$, $p + $priority);
53             };
54              
55 0           $( = $) = $gid; # set new group id
56 0           $< = $> = $uid; # set new user id
57              
58 0           env_create($newenv); # create the new environment
59              
60 0           chdir($directory); # change directory
61 0           umask($umask); # set protection mask
62 0           exec { $argv[0] } @argv; # become a new process
  0            
63              
64 0           exit 0;
65              
66 0           };
67            
68 0 0         if ($self->redirect) {
69              
70 0           my $child;
71             my $parent;
72              
73             # create a socket pair
74              
75 0 0         unless (($child, $parent) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC)) {
76              
77 0           $self->throw_msg(
78             dotid($self->class) . '.start_process.socketpair',
79             'unexpected',
80             "unable to create a socketpair, reason: $!"
81             );
82              
83             }
84              
85 0 0         unless ($pid = fork()) {
86              
87             # child
88              
89 0 0         unless (defined($pid)) {
90              
91 0           $self->throw_msg(
92             dotid($self->class) . '.start_process.creation',
93             'unexpected',
94             'unable to spawn a new process',
95             );
96              
97             }
98              
99             # close unneeded fd's
100              
101 0           close($child);
102              
103             # redirect stdin, stdout and stderr to the parent socket
104             # with stderr combined with stdout
105              
106 0           open(STDIN, '<&', $parent);
107 0           open(STDOUT, '>&', $parent);
108 0           open(STDERR, '>&', $parent);
109              
110             # not needed any longer
111              
112 0           close($parent);
113              
114 0           $spawn->();
115              
116             } else {
117              
118             # parent
119              
120             # close unneeded fd's
121              
122 0           close($parent);
123              
124             # listen on the child socket
125              
126 0           $self->input_handle($child);
127 0           $self->output_handle($child);
128              
129             # setup POE's I/O handling
130              
131 0           $self->_process_output();
132 0           $self->_process_input();
133              
134             }
135              
136             } else {
137              
138 0 0         unless ($pid = fork()) {
139              
140             # child
141              
142 0 0         unless (defined($pid)) {
143              
144 0           $self->throw_msg(
145             dotid($self->class) . '.start_process.creation',
146             'unexpected',
147             'unable to spawn a new process',
148             );
149              
150             }
151              
152             # redirect the standard file handles to dev null
153              
154 0           open(STDIN, '<', '/dev/null');
155 0           open(STDOUT, '>', '/dev/null');
156 0           open(STDERR, '>', '/dev/null');
157              
158 0           $spawn->();
159              
160             }
161              
162             }
163              
164 0           $self->status(PROC_STARTED);
165              
166 0           $poe_kernel->sig_child($pid, 'poll_child');
167 0           $self->{'pid'} = $pid;
168              
169             # recover the old environment
170              
171             # env_restore($oldenv);
172              
173             }
174              
175             sub stat_process {
176 0     0 1   my $self = shift;
177              
178 0           my $stat = 0;
179              
180 0 0         if (my $pid = $self->pid) {
181              
182 0           $stat = $self->proc_status($pid);
183              
184             }
185              
186 0           return $stat;
187              
188             }
189              
190             sub pause_process {
191 0     0 1   my $self = shift;
192              
193 0           my $alias = $self->alias;
194              
195 0 0         if ($self->pid) {
196              
197 0           my $pid = ($self->pid * -1);
198 0           my $code = $self->stat_process();
199              
200 0 0 0       if (($code == 3) || ($code == 2)) { # process is running or ready
201              
202 0 0         if (kill('STOP', $pid)) {
203              
204 0           $self->status(PROC_PAUSED);
205 0           $self->log->warn_msg('process_paused', $alias, $self->pid);
206              
207             }
208              
209             }
210              
211             }
212              
213             }
214              
215             sub resume_process {
216 0     0 1   my $self = shift;
217              
218 0           my $alias = $self->alias;
219              
220 0 0         if ($self->pid) {
221              
222 0           my $pid = ($self->pid * -1);
223 0           my $code = $self->stat_process();
224              
225 0 0         if ($code == 6) { # process is suspended ready
226              
227 0 0         if (kill('CONT', $pid)) {
228              
229 0           $self->status(PROC_RUNNING);
230 0           $self->log->warn_msg('process_started', $alias, $self->pid);
231              
232             }
233              
234             }
235              
236             }
237              
238             }
239              
240             sub stop_process {
241 0     0 1   my $self = shift;
242              
243 0           my $alias = $self->alias;
244              
245 0 0         if ($self->pid) {
246              
247 0           my $pid = ($self->pid * -1);
248              
249 0 0         if (kill('TERM', $pid)) {
250              
251 0 0         $self->status(PROC_STOPPED) unless ($self->status == PROC_SHUTDOWN);
252 0           $self->retries(0);
253 0           $self->log->warn_msg('process_stopped', $alias, $self->pid);
254              
255             }
256              
257             }
258              
259             }
260              
261             sub kill_process {
262 0     0 1   my $self = shift;
263              
264 0           my $alias = $self->alias;
265              
266 0 0         if ($self->pid) {
267              
268 0           my $pid = ($self->pid * -1);
269              
270 0 0         if (kill('KILL', $pid)) {
271              
272 0           $self->status(PROC_KILLED);
273 0           $self->retries(0);
274 0           $self->log->warn_msg('process_killed', $alias, $self->pid);
275              
276             }
277              
278             }
279              
280             }
281              
282             sub destroy {
283 0     0 0   my $self = shift;
284             }
285              
286             sub init_process {
287 0     0 1   my $self = shift;
288             }
289              
290             # ----------------------------------------------------------------------
291             # Private Events
292             # ----------------------------------------------------------------------
293              
294             sub _poll_child {
295 0     0     my ($self, $signal, $pid, $exitcode) = @_[OBJECT,ARG0,ARG1,ARG2];
296              
297 0           my $alias = $self->alias;
298              
299 0           $self->log->debug("$alias: entering poll_child");
300              
301 0 0 0       unless (($self->status == PROC_KILLED) || ($self->status == PROC_SHUTDOWN)) {
302              
303 0           $self->status(PROC_STOPPED);
304              
305             }
306              
307             # notify 'child_exit' that we are done
308              
309 0           $poe_kernel->post($alias, 'child_exit', 'CHLD', $pid, $exitcode);
310              
311             }
312              
313             # ----------------------------------------------------------------------
314             # Private Methods
315             # ----------------------------------------------------------------------
316              
317             sub _parse_command {
318 0     0     my $self = shift;
319              
320 0           my @args = split(' ', $self->command);
321 0           my @extensions = ('');
322 0           my @path = split(':', $ENV{'PATH'});
323            
324             # Stolen from Proc::Background
325             #
326             # If there is only one element in the @args array, then it may be a
327             # command to be passed to the shell and should not be checked, in
328             # case the command sets environmental variables in the beginning,
329             # i.e. 'VAR=arg ls -l'. If there is more than one element in the
330             # array, then check that the first element is a valid executable
331             # that can be found through the PATH and find the absolute path to
332             # the executable. If the executable is found, then replace the
333             # first element it with the absolute path.
334              
335 0 0         if (scalar(@args) > 1) {
336              
337 0 0         $args[0] = $self->_resolve_path($args[0], \@extensions, \@path) or return;
338              
339             }
340              
341 0           my $cmd = join(' ', @args);
342              
343 0           return create_argv($cmd);
344              
345             }
346              
347             1;
348              
349             __END__
350              
351             =head1 NAME
352              
353             XAS::Lib::Process::Unix - A mixin class for process management within the XAS environment
354              
355             =head1 DESCRIPTION
356              
357             This module is a mixin class to handle the needs for process management
358             under a Unix like system.
359              
360             =head1 METHODS
361              
362             =head2 init_process
363              
364             This method initializes the module so that it can function properly.
365              
366             =head2 start_process
367              
368             This method does the neccessary things to spawn a new process.
369              
370             =head2 stat_process
371              
372             This method returns the status of the process. These are the possible
373             values.
374              
375             =over 4
376              
377             =item B<6>
378              
379             This status indicates that the process is stopped, either by a
380             job control signal or it is being traced.
381              
382             =item B<5>
383              
384             This status indicates that the process is in a uninterruptible sleep,
385             usually waiting for I/O.
386              
387             =item B<4>
388              
389             Not implemented on Unix.
390              
391             =item B<3>
392              
393             This status indicates that the process is running or runnable.
394              
395             =item B<2>
396              
397             This indicates that the process is in a interruptible sleep, waiting for
398             an event to complete.
399              
400             =item B<1>
401              
402             This indicates that the process is a zombie. Terminated but not yet
403             reaped.
404              
405             =item B<0>
406              
407             This indicates that the process is in an unknown state.
408              
409             =back
410              
411             =head2 stop_process
412              
413             This method will send a 'TERM' signal to the process.
414              
415             =head2 pause_process
416              
417             This method will send a 'TSTP' signal to the process.
418              
419             =head2 resume_process
420              
421             This method will send a 'CONT' signal to the process.
422              
423             =head2 kill_process
424              
425             This method will send a 'KILL' signal to the process.
426              
427             =head1 SEE ALSO
428              
429             =over 4
430              
431             =item L<XAS::Lib::Process|XAS::Lib::Process>
432              
433             =item L<XAS|XAS>
434              
435             =back
436              
437             =head1 AUTHOR
438              
439             Kevin L. Esteb, E<lt>kevin@kesteb.usE<gt>
440              
441             =head1 COPYRIGHT AND LICENSE
442              
443             Copyright (C) 2015 Kevin L. Esteb
444              
445             This is free software; you can redistribute it and/or modify it under
446             the terms of the Artistic License 2.0. For details, see the full text
447             of the license at http://www.perlfoundation.org/artistic_license_2_0.
448              
449             =cut