1package HTTP::Proxy::Engine::Legacy;
2use strict;
3use POSIX 'WNOHANG';
4use HTTP::Proxy;
5
6our @ISA = qw( HTTP::Proxy::Engine );
7our %defaults = (
8    max_clients => 12,
9);
10
11__PACKAGE__->make_accessors( qw( kids select ), keys %defaults );
12
13sub start {
14    my $self = shift;
15    $self->kids( [] );
16    $self->select( IO::Select->new( $self->proxy->daemon ) );
17}
18
19sub run {
20    my $self   = shift;
21    my $proxy  = $self->proxy;
22    my $kids   = $self->kids;
23
24    # check for new connections
25    my @ready = $self->select->can_read(1);
26    for my $fh (@ready) {    # there's only one, anyway
27
28        # single-process proxy (useful for debugging)
29        if ( $self->max_clients == 0 ) {
30            $proxy->max_keep_alive_requests(1);  # do not block simultaneous connections
31            $proxy->log( HTTP::Proxy::PROCESS, "PROCESS",
32                        "No fork allowed, serving the connection" );
33            $proxy->serve_connections($fh->accept);
34            $proxy->new_connection;
35            next;
36        }
37
38        if ( @$kids >= $self->max_clients ) {
39            $proxy->log( HTTP::Proxy::ERROR, "PROCESS",
40                        "Too many child process, serving the connection" );
41            $proxy->serve_connections($fh->accept);
42            $proxy->new_connection;
43            next;
44        }
45
46        # accept the new connection
47        my $conn  = $fh->accept;
48        my $child = fork;
49        if ( !defined $child ) {
50            $conn->close;
51            $proxy->log( HTTP::Proxy::ERROR, "PROCESS", "Cannot fork" );
52            $self->max_clients( $self->max_clients - 1 )
53              if $self->max_clients > @$kids;
54            next;
55        }
56
57        # the parent process
58        if ($child) {
59            $conn->close;
60            $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Forked child process $child" );
61            push @$kids, $child;
62        }
63
64        # the child process handles the whole connection
65        else {
66            $SIG{INT} = 'DEFAULT';
67            $proxy->serve_connections($conn);
68            exit;    # let's die!
69        }
70    }
71
72    $self->reap_zombies if @$kids;
73}
74
75sub stop {
76    my $self = shift;
77    my $kids = $self->kids;
78
79    # wait for remaining children
80    # EOLOOP
81    kill INT => @$kids;
82    $self->reap_zombies while @$kids;
83}
84
85# private reaper sub
86sub reap_zombies {
87    my $self  = shift;
88    my $kids  = $self->kids;
89    my $proxy = $self->proxy;
90
91    while (1) {
92        my $pid = waitpid( -1, WNOHANG );
93        last if $pid == 0 || $pid == -1;    # AS/Win32 returns negative PIDs
94        @$kids = grep { $_ != $pid } @$kids;
95        $proxy->{conn}++;    # Cannot use the interface for RO attributes
96        $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", "Reaped child process $pid" );
97        $proxy->log( HTTP::Proxy::PROCESS, "PROCESS", @$kids . " remaining kids: @$kids" );
98    }
99}
100
1011;
102
103__END__
104
105=head1 NAME
106
107HTTP::Proxy::Engine::Legacy - The "older" HTTP::Proxy engine
108
109=head1 SYNOPSIS
110
111    my $proxy = HTTP::Proxy->new( engine => 'Legacy' );
112
113=head1 DESCRIPTION
114
115This engine reproduces the older child creation algorithm of HTTP::Proxy.
116
117Angelos Karageorgiou C<< <angelos@unix.gr> >> reports:
118
119I<I got the Legacy engine to work really fast under C<Win32> with the following trick:>
120
121    max_keep_alive_requests(1);
122    max_clients(120);
123    $HTTP::VERSION(1.0); # just in case
124
125I<and it smokes.>
126
127I<It seems that forked children are really slow when calling select for handling C<keep-alive>d requests!>
128
129=head1 METHODS
130
131The module defines the following methods, used by HTTP::Proxy main loop:
132
133=over 4
134
135=item start()
136
137Initialise the engine.
138
139=item run()
140
141Implements the forking logic: a new process is forked for each new
142incoming TCP connection.
143
144=item stop()
145
146Reap remaining child processes.
147
148=back
149
150The following method is used by the engine internally:
151
152=over 4
153
154=item reap_zombies()
155
156Process the dead child processes.
157
158=back
159
160=head1 SEE ALSO
161
162L<HTTP::Proxy>, L<HTTP::Proxy::Engine>.
163
164=head1 AUTHOR
165
166Philippe "BooK" Bruhat, C<< <book@cpan.org> >>.
167
168=head1 COPYRIGHT
169
170Copyright 2005, Philippe Bruhat.
171
172=head1 LICENSE
173
174This module is free software; you can redistribute it or modify it under
175the same terms as Perl itself.
176
177=cut
178
179