/lib/HTTP/Proxy/Engine/Legacy.pm
Perl | 180 lines | 118 code | 54 blank | 8 comment | 18 complexity | 93c2ea06db8a877f8c992d551b3c644d MD5 | raw file
- package HTTP::Proxy::Engine::Legacy;
- use strict;
- use POSIX 'WNOHANG';
- use HTTP::Proxy;
- use HTTP::Proxy::Engine;
- our @ISA = qw( HTTP::Proxy::Engine );
- our %defaults = (
- max_clients => 12,
- );
- __PACKAGE__->make_accessors( qw( kids select ), keys %defaults );
- sub start {
- my $self = shift;
- $self->kids( [] );
- $self->select( IO::Select->new( $self->proxy->daemon ) );
- }
- sub run {
- my $self = shift;
- my $proxy = $self->proxy;
- my $kids = $self->kids;
- # check for new connections
- my @ready = $self->select->can_read(1);
- for my $fh (@ready) { # there's only one, anyway
- # single-process proxy (useful for debugging)
- if ( $self->max_clients == 0 ) {
- $proxy->max_keep_alive_requests(1); # do not block simultaneous connections
- $proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
- "No fork allowed, serving the connection" );
- $proxy->serve_connections($fh->accept);
- $proxy->new_connection;
- next;
- }
- if ( @$kids >= $self->max_clients ) {
- $proxy->log( HTTP::Proxy::ERROR, "PROCESS",
- "Too many child process, serving the connection" );
- $proxy->serve_connections($fh->accept);
- $proxy->new_connection;
- next;
- }
- # accept the new connection
- my $conn = $fh->accept;
- my $child = fork;
- if ( !defined $child ) {
- $conn->close;
- $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot fork" );
- $self->max_clients( $self->max_clients - 1 )
- if $self->max_clients > @$kids;
- next;
- }
- # the parent process
- if ($child) {
- $conn->close;
- $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Forked child process $child" );
- push @$kids, $child;
- }
- # the child process handles the whole connection
- else {
- $SIG{INT} = 'DEFAULT';
- $proxy->serve_connections($conn);
- exit; # let's die!
- }
- }
- $self->reap_zombies if @$kids;
- }
- sub stop {
- my $self = shift;
- my $kids = $self->kids;
- # wait for remaining children
- # EOLOOP
- kill INT => @$kids;
- $self->reap_zombies while @$kids;
- }
- # private reaper sub
- sub reap_zombies {
- my $self = shift;
- my $kids = $self->kids;
- my $proxy = $self->proxy;
- while (1) {
- my $pid = waitpid( -1, WNOHANG );
- last if $pid == 0 || $pid == -1; # AS/Win32 returns negative PIDs
- @$kids = grep { $_ != $pid } @$kids;
- $proxy->{conn}++; # Cannot use the interface for RO attributes
- $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Reaped child process $pid" );
- $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", @$kids . " remaining kids: @$kids" );
- }
- }
- 1;
- __END__
- =head1 NAME
- HTTP::Proxy::Engine::Legacy - The "older" HTTP::Proxy engine
- =head1 SYNOPSIS
- my $proxy = HTTP::Proxy->new( engine => 'Legacy' );
- =head1 DESCRIPTION
- This engine reproduces the older child creation algorithm of L<HTTP::Proxy>.
- Angelos Karageorgiou C<< <angelos@unix.gr> >> reports:
- I<I got the Legacy engine to work really fast under C<Win32> with the following trick:>
- max_keep_alive_requests(1);
- max_clients(120);
- $HTTP::VERSION(1.0); # just in case
- I<and it smokes.>
- I<It seems that forked children are really slow when calling select for handling C<keep-alive>d requests!>
- =head1 METHODS
- The module defines the following methods, used by L<HTTP::Proxy> main loop:
- =over 4
- =item start()
- Initialise the engine.
- =item run()
- Implements the forking logic: a new process is forked for each new
- incoming TCP connection.
- =item stop()
- Reap remaining child processes.
- =back
- The following method is used by the engine internally:
- =over 4
- =item reap_zombies()
- Process the dead child processes.
- =back
- =head1 SEE ALSO
- L<HTTP::Proxy>, L<HTTP::Proxy::Engine>.
- =head1 AUTHOR
- Philippe "BooK" Bruhat, C<< <book@cpan.org> >>.
- =head1 COPYRIGHT
- Copyright 2005-2015, Philippe Bruhat.
- =head1 LICENSE
- This module is free software; you can redistribute it or modify it under
- the same terms as Perl itself.
- =cut