File Coverage

blib/lib/HTTP/Proxy/Engine/ScoreBoard.pm
Criterion Covered Total %
statement 18 114 15.7
branch 0 40 0.0
condition 0 15 0.0
subroutine 6 10 60.0
pod 3 3 100.0
total 27 182 14.8


line stmt bran cond sub pod time code
1             package HTTP::Proxy::Engine::ScoreBoard;
2             $HTTP::Proxy::Engine::ScoreBoard::VERSION = '0.302';
3 1     1   808 use strict;
  1         2  
  1         31  
4 1     1   4 use POSIX ":sys_wait_h"; # WNOHANG
  1         1  
  1         3  
5 1     1   198 use Fcntl qw(LOCK_UN LOCK_EX);
  1         1  
  1         41  
6 1     1   4 use IO::Handle;
  1         1  
  1         32  
7 1     1   739 use File::Temp;
  1         9668  
  1         69  
8 1     1   6 use HTTP::Proxy;
  1         1  
  1         1113  
9              
10             our @ISA = qw( HTTP::Proxy::Engine );
11             our %defaults = (
12             start_servers => 4, # start this many, and don't go below
13             max_clients => 12, # don't go above
14             max_requests_per_child => 250, # just in case there's a leak
15             min_spare_servers => 1, # minimum idle (if 0, never start new)
16             max_spare_servers => 12, # maximum idle (should be "single browser max")
17             verify_delay => 60, # minimum time between kids verification
18             );
19              
20             __PACKAGE__->make_accessors(
21             qw(
22             kids select status_read status_write scoreboard tempfile
23             verify_live_kids_time last_active_time last_fork_time
24             ),
25             keys %defaults
26             );
27              
28             sub start {
29 0     0 1   my $self = shift;
30 0           $self->kids( {} );
31              
32             # set up the communication pipe
33 0           $self->status_read( IO::Handle->new() );
34 0           $self->status_write( IO::Handle->new() );
35 0 0         pipe( $self->status_read(), $self->status_write() )
36             or die "Can't create pipe: $!";
37 0           $self->status_write()->autoflush(1);
38 0           $self->select( IO::Select->new( $self->status_read() ) );
39 0           setpgrp; # set as group leader
40              
41             # scoreboard information
42 0           $self->verify_live_kids_time( time );
43 0           $self->last_active_time( time );
44 0           $self->last_fork_time( time );
45 0           $self->scoreboard( '' );
46              
47             # lockfile information
48 0           $self->tempfile(
49             File::Temp->new( UNLINK => 0, TEMPLATE => 'http-proxy-XXXX' ) );
50 0           $self->proxy()->log( HTTP::Proxy::ENGINE, "ENGINE",
51             "Using " . $self->tempfile()->filename() . " as lockfile" );
52             }
53              
54             my %status = ( A => 'Acccept', B => 'Busy', I => 'Idle' );
55             sub run {
56 0     0 1   my $self = shift;
57 0           my $proxy = $self->proxy();
58 0           my $kids = $self->kids();
59              
60             ## first phase: update scoreboard
61 0 0         if ( $self->select()->can_read(1) ) {
62 0 0         $self->status_read()->sysread( my $buf, 50 ) > 0 # read first 10 changes
63             or die "bad read"; # FIXME
64 0           while ( length $buf ) {
65 0           my ( $pid, $status ) = unpack "NA", substr( $buf, 0, 5, "" );
66 0           $proxy->log( HTTP::Proxy::ENGINE, 'ENGINE',
67             "Child process $pid updated to $status ($status{$status})" );
68 0           $kids->{$pid} = $status;
69             }
70 0           $self->last_active_time(time);
71             }
72              
73             {
74 0           my $new = join "", values %$kids;
  0            
75 0 0         if ( $new ne $self->scoreboard() ) {
76 0           $proxy->log( HTTP::Proxy::ENGINE, 'ENGINE', "ScoreBoard = $new" );
77 0           $self->scoreboard($new);
78             }
79             }
80              
81             ## second phase: delete dead kids
82 0           while ( ( my $kid = waitpid( -1, WNOHANG ) ) > 0 ) {
83 0           $proxy->{conn}++; # Cannot use the interface for RO attributes
84 0           $proxy->log( HTTP::Proxy::PROCESS, 'PROCESS',
85             "Reaped child process $kid" );
86 0           $proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
87 0           keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" );
88 0           delete $kids->{$kid};
89             }
90              
91             ## third phase: verify live kids
92 0 0         if ( time > $self->verify_live_kids_time() + $self->verify_delay() ) {
93 0           for my $kid ( keys %$kids ) {
94 0 0         next if kill 0, $kid;
95              
96             # shouldn't happen normally
97 0           $proxy->log( HTTP::Proxy::ERROR, "ENGINE",
98             "Child process $kid found missing" );
99 0           delete $kids->{$kid};
100             }
101 0           $self->verify_live_kids_time(time);
102             }
103              
104             ## fourth phase: launch kids
105 0           my @idlers = grep $kids->{$_} eq "I", keys %$kids;
106 0 0 0       if (
    0 0        
      0        
      0        
      0        
107             (
108             @idlers < $self->min_spare_servers() # not enough idlers
109             or keys %$kids < $self->start_servers() # not enough overall
110             )
111             and keys %$kids < $self->max_clients() # not too many please
112             and time > $self->last_fork_time() # not too fast please
113             )
114             {
115 0           my $child = fork();
116 0 0         if ( !defined $child ) {
117 0           $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot fork" );
118             }
119             else {
120 0 0         if ($child) {
121 0           $proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
122             "Forked child process $child" );
123 0           $kids->{$child} = "I";
124 0           $self->last_fork_time(time);
125             }
126             else { # child process
127 0           $self->_run_child();
128 0           exit; # we're done
129             }
130             }
131             }
132             elsif (
133             (
134             @idlers > $self->max_spare_servers() # too many idlers
135             or @idlers > $self->min_spare_servers() # too many lazy idlers
136             and time > $self->last_active_time + $self->verify_delay()
137             )
138             and keys %$kids > $self->start_servers() # not too few please
139             )
140             {
141 0           my $victim = $idlers[ rand @idlers ];
142 0           $proxy->log( HTTP::Proxy::ENGINE, "ENGINE",
143             "Killing idle child process $victim" );
144 0           kill INT => $victim; # pick one at random
145 0           $self->last_active_time(time);
146             }
147              
148             }
149              
150             sub stop {
151 0     0 1   my $self = shift;
152 0           my $kids = $self->kids();
153 0           my $proxy = $self->proxy();
154              
155 0           kill 'INT' => keys %$kids;
156              
157             # wait for remaining children
158 0           while (%$kids) {
159 0           my $pid = waitpid( -1, WNOHANG );
160 0 0         next unless $pid;
161              
162 0           $proxy->{conn}++; # WRONG for this engine!
163              
164 0           delete $kids->{$pid};
165 0           $proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
166             "Reaped child process $pid" );
167 0           $proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
168 0           keys(%$kids) . " remaining kids: @{[ keys %$kids ]}" );
169             }
170              
171             # remove the temporary file
172 0 0         unlink $self->tempfile()->filename() or do {
173 0           $proxy->log( HTTP::Proxy::ERROR, "ERROR",
174 0           "Can't unlink @{[ $self->tempfile()->filename() ]}: $!" );
175             };
176             }
177              
178             sub _run_child {
179 0     0     my $self = shift;
180 0           my $proxy = $self->proxy();
181              
182 0           my $daemon = $proxy->daemon();
183 0           my $status_write = $self->status_write();
184              
185 0 0         open my $lockfh, $self->tempfile()->filename() or do {
186 0           $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot open lock file: $!" );
187 0           exit;
188             };
189              
190 0           my $did = 0; # processed count
191              
192 0           while ( ++$did <= $self->max_requests_per_child() ) {
193              
194 0 0         flock $lockfh, LOCK_EX or do {
195 0           $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot get flock: $!" );
196 0           exit;
197             };
198              
199 0 0         last unless $proxy->loop();
200              
201 0 0         5 == syswrite $status_write, pack "NA", $$, "A" # go accept
202             or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status A: short write");
203              
204 0 0         my $slave = $daemon->accept() or do {
205 0           $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot accept: $!");
206 0           exit;
207             };
208              
209 0 0         flock $lockfh, LOCK_UN or do {
210 0           $proxy->log( HTTP::Proxy::ERROR, "ERROR", "Cannot unflock: $!" );
211 0           exit;
212             };
213              
214 0 0         5 == syswrite $status_write, pack "NA", $$, "B" # go busy
215             or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status B: short write");
216 0           $slave->autoflush(1);
217            
218 0           $proxy->serve_connections($slave); # the real work is done here
219              
220 0           close $slave;
221 0 0         5 == syswrite $status_write, pack "NA", $$, "I" # go idle
222             or $proxy->log( HTTP::Proxy::ERROR, "ERROR", "status I: short write");
223             }
224             }
225              
226             1;
227              
228             __END__