| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package IPC::QWorker::Worker; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 12 |  |  | 12 |  | 84 | use strict; | 
|  | 12 |  |  |  |  | 24 |  | 
|  | 12 |  |  |  |  | 359 |  | 
| 4 | 12 |  |  | 12 |  | 71 | use warnings; | 
|  | 12 |  |  |  |  | 13 |  | 
|  | 12 |  |  |  |  | 289 |  | 
| 5 | 12 |  |  | 12 |  | 60 | use utf8; | 
|  | 12 |  |  |  |  | 35 |  | 
|  | 12 |  |  |  |  | 59 |  | 
| 6 |  |  |  |  |  |  |  | 
| 7 |  |  |  |  |  |  | # ABSTRACT: worker process for IPC::QWorker | 
| 8 |  |  |  |  |  |  | our $VERSION = '0.08'; # VERSION | 
| 9 |  |  |  |  |  |  |  | 
| 10 | 12 |  |  | 12 |  | 479 | use Carp; | 
|  | 12 |  |  |  |  | 35 |  | 
|  | 12 |  |  |  |  | 837 |  | 
| 11 | 12 |  |  | 12 |  | 6141 | use IO::Socket; | 
|  | 12 |  |  |  |  | 276878 |  | 
|  | 12 |  |  |  |  | 49 |  | 
| 12 | 12 |  |  | 12 |  | 13078 | use Storable qw(fd_retrieve store_fd); | 
|  | 12 |  |  |  |  | 37279 |  | 
|  | 12 |  |  |  |  | 811 |  | 
| 13 | 12 |  |  | 12 |  | 7553 | use Data::Dumper; | 
|  | 12 |  |  |  |  | 79469 |  | 
|  | 12 |  |  |  |  | 8647 |  | 
| 14 |  |  |  |  |  |  |  | 
| 15 |  |  |  |  |  |  | sub new { | 
| 16 | 65 |  |  | 65 | 0 | 218 | my $this  = shift; | 
| 17 | 65 |  | 33 |  |  | 632 | my $class = ref($this) || $this; | 
| 18 | 65 |  |  |  |  | 3250 | my $self  = { | 
| 19 |  |  |  |  |  |  | 'pid'   => 0, | 
| 20 |  |  |  |  |  |  | 'pipe'  => undef, | 
| 21 |  |  |  |  |  |  | 'calls' => {@_}, | 
| 22 |  |  |  |  |  |  | 'ctx'   => {}, | 
| 23 |  |  |  |  |  |  | 'ready' => 0, | 
| 24 |  |  |  |  |  |  | }; | 
| 25 | 65 |  |  |  |  | 771 | bless( $self, $class ); | 
| 26 | 65 |  |  |  |  | 265 | $self->_fork_worker(); | 
| 27 | 55 |  |  |  |  | 2853 | return ($self); | 
| 28 |  |  |  |  |  |  | } | 
| 29 |  |  |  |  |  |  |  | 
| 30 |  |  |  |  |  |  | sub _fork_worker { | 
| 31 | 65 |  |  | 65 |  | 100 | my $self = shift; | 
| 32 | 65 |  |  |  |  | 168 | my $pid; | 
| 33 |  |  |  |  |  |  | my $parent_pipe; | 
| 34 | 65 |  |  |  |  | 0 | my $child_pipe; | 
| 35 |  |  |  |  |  |  |  | 
| 36 | 65 | 50 |  |  |  | 5615 | socketpair( $parent_pipe, $child_pipe, AF_UNIX, SOCK_STREAM, PF_UNIX ) | 
| 37 |  |  |  |  |  |  | or croak("cant create socketpair: $!"); | 
| 38 |  |  |  |  |  |  |  | 
| 39 | 65 |  |  |  |  | 1350 | $parent_pipe->autoflush(1); | 
| 40 | 65 |  |  |  |  | 8409 | $child_pipe->autoflush(1); | 
| 41 |  |  |  |  |  |  |  | 
| 42 | 65 | 100 |  |  |  | 52669 | if ( $pid = fork ) { | 
| 43 | 55 |  |  |  |  | 2750 | close($parent_pipe); | 
| 44 | 55 |  |  |  |  | 459 | $self->{'pid'}  = $pid; | 
| 45 | 55 |  |  |  |  | 3628 | $self->{'pipe'} = $child_pipe; | 
| 46 |  |  |  |  |  |  | } | 
| 47 |  |  |  |  |  |  | else { | 
| 48 | 10 | 50 |  |  |  | 1019 | if ( !defined($pid) ) { | 
| 49 | 0 |  |  |  |  | 0 | croak("cannot fork child process"); | 
| 50 |  |  |  |  |  |  | } | 
| 51 | 10 |  |  |  |  | 408 | close($child_pipe); | 
| 52 | 10 |  |  |  |  | 218 | $self->{'pipe'} = $parent_pipe; | 
| 53 | 10 | 50 |  |  |  | 298 | if ( defined( $self->{'calls'}->{'_init'} ) ) { | 
| 54 | 10 |  |  |  |  | 496 | $self->{'calls'}->{'_init'}->( $self->{'ctx'} ); | 
| 55 |  |  |  |  |  |  | } | 
| 56 | 10 |  |  | 10 |  | 1659 | $SIG{'HUP'} = sub { $self->_shutdown() }; | 
|  | 10 |  |  |  |  | 9569348 |  | 
| 57 | 10 |  |  |  |  | 300 | $self->_child_loop(); | 
| 58 | 0 |  |  |  |  | 0 | close($parent_pipe); | 
| 59 | 0 |  |  |  |  | 0 | exit; | 
| 60 |  |  |  |  |  |  | } | 
| 61 |  |  |  |  |  |  | } | 
| 62 |  |  |  |  |  |  |  | 
| 63 |  |  |  |  |  |  | sub _child_loop { | 
| 64 | 10 |  |  | 10 |  | 42 | my $self = shift; | 
| 65 | 10 |  |  |  |  | 83 | my $qentry; | 
| 66 |  |  |  |  |  |  |  | 
| 67 | 10 |  |  |  |  | 292 | $self->send_ready(); | 
| 68 |  |  |  |  |  |  |  | 
| 69 | 10 |  |  |  |  | 57 | while ( $qentry = ${ fd_retrieve( $self->{'pipe'} ) } ) { | 
|  | 130 |  |  |  |  | 1041 |  | 
| 70 | 120 | 50 |  |  |  | 251096 | if ($IPC::QWorker::DEBUG) { print STDERR Dumper($qentry); } | 
|  | 0 |  |  |  |  | 0 |  | 
| 71 |  |  |  |  |  |  |  | 
| 72 | 120 | 50 |  |  |  | 2594 | if ( defined $self->{'calls'}->{ $qentry->{'cmd'} } ) { | 
| 73 |  |  |  |  |  |  | $self->{'calls'}->{ $qentry->{'cmd'} } | 
| 74 | 120 |  |  |  |  | 993 | ->( $self->{'ctx'}, $qentry->{'params'} ); | 
| 75 |  |  |  |  |  |  | } | 
| 76 |  |  |  |  |  |  | else { | 
| 77 | 0 |  |  |  |  | 0 | croak( $$ . ": no such call defined in this worker" ); | 
| 78 |  |  |  |  |  |  | } | 
| 79 |  |  |  |  |  |  |  | 
| 80 | 120 |  |  |  |  | 17190 | $self->send_ready(); | 
| 81 |  |  |  |  |  |  | } | 
| 82 |  |  |  |  |  |  | } | 
| 83 |  |  |  |  |  |  |  | 
| 84 |  |  |  |  |  |  | sub send_ready { | 
| 85 | 130 |  |  | 130 | 0 | 355 | my $self = shift(); | 
| 86 |  |  |  |  |  |  |  | 
| 87 | 130 |  |  |  |  | 290 | print ${ $self->{'pipe'} }($$." READY\n"); | 
|  | 130 |  |  |  |  | 2628 |  | 
| 88 |  |  |  |  |  |  | } | 
| 89 |  |  |  |  |  |  |  | 
| 90 |  |  |  |  |  |  | sub send_entry { | 
| 91 | 120 |  |  | 120 | 0 | 175 | my $self = shift; | 
| 92 | 120 |  |  |  |  | 146 | my $qentry = shift; | 
| 93 |  |  |  |  |  |  |  | 
| 94 | 120 |  |  |  |  | 168 | $self->{'ready'} = 0; | 
| 95 |  |  |  |  |  |  |  | 
| 96 | 120 | 50 |  |  |  | 198 | if ($IPC::QWorker::DEBUG) { | 
| 97 | 0 |  |  |  |  | 0 | print STDERR $$ . ": sending entry...\n"; | 
| 98 |  |  |  |  |  |  | } | 
| 99 | 120 |  |  |  |  | 310 | store_fd( \$qentry, $self->{'pipe'} ); | 
| 100 |  |  |  |  |  |  | } | 
| 101 |  |  |  |  |  |  |  | 
| 102 |  |  |  |  |  |  | sub exit_child { | 
| 103 | 10 |  |  | 10 | 0 | 40 | my $self = shift(); | 
| 104 |  |  |  |  |  |  |  | 
| 105 | 10 | 50 |  |  |  | 92 | if ( $self->{'pid'} == 0 ) {    # do nothing when called from within child | 
| 106 | 0 |  |  |  |  | 0 | return (); | 
| 107 |  |  |  |  |  |  | } | 
| 108 |  |  |  |  |  |  |  | 
| 109 | 10 |  |  |  |  | 642 | kill( 'HUP', $self->{'pid'} ); | 
| 110 | 10 |  |  |  |  | 2142660 | waitpid( $self->{'pid'}, 0 ); | 
| 111 |  |  |  |  |  |  | } | 
| 112 |  |  |  |  |  |  |  | 
| 113 |  |  |  |  |  |  | sub _shutdown { | 
| 114 | 10 |  |  | 10 |  | 45 | my $self = shift(); | 
| 115 |  |  |  |  |  |  |  | 
| 116 | 10 | 50 |  |  |  | 105 | if ( defined( $self->{'calls'}->{'_destroy'} ) ) { | 
| 117 | 10 |  |  |  |  | 137 | $self->{'calls'}->{'_destroy'}->( $self->{'ctx'} ); | 
| 118 |  |  |  |  |  |  | } | 
| 119 | 10 | 50 |  |  |  | 723 | if ($IPC::QWorker::DEBUG) { print STDERR $$ . ": exiting...\n"; } | 
|  | 0 |  |  |  |  | 0 |  | 
| 120 | 10 |  |  |  |  | 4844 | exit(0); | 
| 121 |  |  |  |  |  |  | } | 
| 122 |  |  |  |  |  |  |  | 
| 123 |  |  |  |  |  |  | 1; | 
| 124 |  |  |  |  |  |  |  | 
| 125 |  |  |  |  |  |  | # vim:ts=2:expandtab:syntax=perl: | 
| 126 |  |  |  |  |  |  |  | 
| 127 |  |  |  |  |  |  | __END__ |