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
117=head1 METHODS
118
119The module defines the following methods, used by HTTP::Proxy main loop:
120
121=over
122
123=item start()
124
125Initialise the engine.
126
127=item run()
128
129Implements the forking logic: a new process is forked for each new
130incoming TCP connection.
131
132=item stop()
133
134Reap remaining child processes.
135
136=back
137
138The following method is used by the engine internally:
139
140=over 4
141
142=item reap_zombies()
143
144Process the dead child processes.
145
146=back
147
148=head1 SEE ALSO
149
150L<HTTP::Proxy>, L<HTTP::Proxy::Engine>.
151
152=head1 AUTHOR
153
154Philippe "BooK" Bruhat, C<< <book@cpan.org> >>.
155
156=head1 COPYRIGHT
157
158Copyright 2005, Philippe Bruhat.
159
160=head1 LICENSE
161
162This module is free software; you can redistribute it or modify it under
163the same terms as Perl itself.
164
165=cut
166
167