File Coverage

blib/lib/HTTP/Server/Simple/CGI/PreFork.pm

Criterion	Covered	Total	%
statement	33	173	19.0
branch	0	76	0.0
condition	0	29	0.0
subroutine	11	19	57.8
pod	2	2	100.0
total	46	299	15.3

package HTTP::Server::Simple::CGI::PreFork;

use strict;
use warnings;
use Socket ':all';
use IO::Handle;

#use Socket6 qw[unpack_sockaddr_in6];

our $VERSION = 6.0;
use Carp;

use base qw[HTTP::Server::Simple::CGI];

sub run {
    my ($self, %config) = @_;

    if(!defined($config{prefork})) {
        $config{prefork} = 0;
    }

    if(!defined($config{usessl})) {
        $config{usessl} = 0;
    }

    if($config{prefork}) {
        # Create new subroutine to tell HTTP::Server::Simple that we want
        # to be a preforking server
        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        *{__PACKAGE__ . "::net_server"} = sub {
            my $server = 'Net::Server::PreFork';
            return $server;
        };

    } else {
        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        *{__PACKAGE__ . "::net_server"} = sub {
            my $server = 'Net::Server::Single';
            return $server;
        };
    }

    # SET UP FOR SSL
    if($config{usessl}) {
        # SET UP FOR SSL
        # we need to ovverride the _process_request sub for IPv6. For SSL, we
        # also need to disable the calls to binmode

        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        *{__PACKAGE__ . "::_process_request"} =
            sub {

            my $self = shift;

            # Create a callback closure that is invoked for each incoming request;
            # the $self above is bound into the closure.
            sub {
                $self->stdio_handle(*STDIN) unless $self->stdio_handle;

                # Default to unencoded, raw data out.
                # if you're sending utf8 and latin1 data mixed, you may need to override this
                #binmode STDIN,  ':raw';
                #binmode STDOUT, ':raw';

                my $remote_sockaddr = getpeername( $self->stdio_handle );
                if(!$remote_sockaddr && defined($main::_realpeername)) {
                    $remote_sockaddr = $main::_realpeername;
                }

                my ( $iport, $iaddr, $peeraddr );
                if($remote_sockaddr) {
                    eval {
                        # Be fully backwards compatible
                        ( $iport, $iaddr ) = sockaddr_in($remote_sockaddr);
                        $peeraddr = $iaddr ? ( inet_ntoa($iaddr) || "127.0.0.1" ) : '127.0.0.1';
                        1;
                    } or do {
                        # Handle cases where the $remote_sockaddr is an IPv6 structure
                        eval {
                            ( $iport, $iaddr ) = unpack_sockaddr_in6($remote_sockaddr);
                            $peeraddr = inet_ntop(AF_INET6, $iaddr);
                            1;
                        } or do {
                            # What is the best way to handle an unparseable $remote_sockaddr?
                            # Will IPv6 be the "old protocol" one day in our lifetime to be superceded
                            # by something even more complex?
                            #
                            # For now, just return "127.0.0.1", which itself is problematic: What
                            # about the time IPv4 gets switched off and some backend will croak because
                            # the IP is too short?
                            $peeraddr = "127.0.0.1";
                        }
                    }
                }

                if(!defined($peeraddr)) {
                    $peeraddr = "";
                } elsif($peeraddr =~ /^\:\:ffff\:(\d+)\./) {
                    # Looks like a IPv4 adress in IPv6 format (e.g. ::ffff:192.168.0.1
                    # turn it into an IPv4 address for backward compatibility
                    $peeraddr =~ s/^\:\:ffff\://;
                }

                my ( $method, $request_uri, $proto ) = $self->parse_request;

                unless ($self->valid_http_method($method) ) {
                    $self->bad_request;
                    return;
                }

                $proto ||= "HTTP/0.9";

                my ( $file, $query_string )
                    = ( $request_uri =~ /([^?]*)(?:\?(.*))?/s );    # split at ?

                $self->setup(
                    method       => $method,
                    protocol     => $proto,
                    query_string => ( defined($query_string) ? $query_string : '' ),
                    request_uri  => $request_uri,
                    path         => $file,
                    localname    => $self->host,
                    localport    => $self->port,
                    peername     => $peeraddr,
                    peeraddr     => $peeraddr,
                    peerport     => $iport,
                );

                # HTTP/0.9 didn't have any headers (I think)
                my %xheaders;
                if ( $proto =~ m{HTTP/(\d(\.\d)?)$} and $1 >= 1 ) {

                    my $headers = $self->parse_headers
                        or do { $self->bad_request; return };

                    %xheaders = (@$headers);
                    $self->headers($headers);

                }

                my $do_continue = 1;
                if(defined($xheaders{Expect} && $xheaders{Expect} =~ /100\-continue/i)) {
                    $do_continue = $self->handle_continue_header(%xheaders);
                    flush STDOUT;
                }

                if($do_continue) {
                    $self->post_setup_hook if $self->can("post_setup_hook");

                    $self->handler;
                }
            }
        }


    } else {
        # SET UP FOR NON-SSL

        # we need to ovverride the _process_request sub for IPv6.

        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        *{__PACKAGE__ . "::_process_request"} =
            sub {

            my $self = shift;

            # Create a callback closure that is invoked for each incoming request;
            # the $self above is bound into the closure.
            sub {

                $self->stdio_handle(*STDIN) unless $self->stdio_handle;

                # Default to unencoded, raw data out.
                # if you're sending utf8 and latin1 data mixed, you may need to override this
                binmode STDIN,  ':raw';
                binmode STDOUT, ':raw';

                my $remote_sockaddr = getpeername( $self->stdio_handle );
                if(!$remote_sockaddr && defined($main::_realpeername)) {
                    $remote_sockaddr = $main::_realpeername;
                }

                my ( $iport, $iaddr, $peeraddr );

                if($remote_sockaddr) {
                    eval {
                        # Be fully backwards compatible
                        ( $iport, $iaddr ) = sockaddr_in($remote_sockaddr);
                        $peeraddr = $iaddr ? ( inet_ntoa($iaddr) || "127.0.0.1" ) : '127.0.0.1';
                        1;
                    } or do {
                        # Handle cases where the $remote_sockaddr is an IPv6 structure
                        #print STDERR $@ . "\n";
                        eval {
                            ( $iport, $iaddr ) = unpack_sockaddr_in6($remote_sockaddr);
                            $peeraddr = inet_ntop(AF_INET6, $iaddr);
                            1;
                        } or do {
                            #print STDERR $@ . "\n";
                            # What is the best way to handle an unparseable $remote_sockaddr?
                            # Will IPv6 be the "old protocol" one day in our lifetime to be superceded
                            # by something even more complex?
                            #
                            # For now, just return "127.0.0.1", which itself is problematic: What
                            # about the time IPv4 gets switched off and some backend will croak because
                            # the IP is too short?
                            $peeraddr = "127.0.0.1";
                        }
                    }
                }
                if(!defined($peeraddr)) {
                    $peeraddr = "";
                } elsif($peeraddr =~ /^\:\:ffff\:(\d+)\./) {
                    # Looks like a IPv4 adress in IPv6 format (e.g. ::ffff:192.168.0.1
                    # turn it into an IPv4 address for backward compatibility
                    $peeraddr =~ s/^\:\:ffff\://;
                }

                my ( $method, $request_uri, $proto ) = $self->parse_request;

                unless ($self->valid_http_method($method) ) {
                    $self->bad_request;
                    return;
                }

                $proto ||= "HTTP/0.9";

                # Google-Chrome, Chromium and others sometimes make "futility connections", e.g.
                # they open a connection, do nothing and just close the connection after a few seconds
                if(!defined($request_uri) || $request_uri eq '') {
                    $self->bad_request;
                    return;
                }
                my ( $file, $query_string )
                    = ( $request_uri =~ /([^?]*)(?:\?(.*))?/s );    # split at ?

                $self->setup(
                    method       => $method,
                    protocol     => $proto,
                    query_string => ( defined($query_string) ? $query_string : '' ),
                    request_uri  => $request_uri,
                    path         => $file,
                    localname    => $self->host,
                    localport    => $self->port,
                    peername     => $peeraddr,
                    peeraddr     => $peeraddr,
                    peerport     => $iport,
                );

                # HTTP/0.9 didn't have any headers (I think)
                my %xheaders;
                if ( $proto =~ m{HTTP/(\d(\.\d)?)$} and $1 >= 1 ) {

                    my $headers = $self->parse_headers
                        or do { $self->bad_request; return };

                    %xheaders = (@$headers);
                    $self->headers($headers);

                }

                my $do_continue = 1;
                if(defined($xheaders{Expect} && $xheaders{Expect} =~ /100\-continue/i)) {
                    $do_continue = $self->handle_continue_header(%xheaders);
                    flush STDOUT;
                }

                if($do_continue) {
                    $self->post_setup_hook if $self->can("post_setup_hook");

                    $self->handler;
                }
            }
        }

    }

    # Ok now fix broken Net::Server*SSL* handling by putting the the SSL options into ARGV
        my @ssl_args = qw(
        SSL_server
        SSL_use_cert
        SSL_verify_mode
        SSL_key_file
        SSL_cert_file
        SSL_ca_path
        SSL_ca_file
        SSL_cipher_list
        SSL_passwd_cb
        SSL_error_callback
        SSL_max_getline_length
    );
    foreach my $ssl_arg (@ssl_args) {
        if(defined($config{$ssl_arg})) {
            push @ARGV, '--' . $ssl_arg . "=" . $config{$ssl_arg};
        }
    }

    # Don't call super, just do out stuff here, as we need some changes anyway
    #return $self->SUPER::run(%config); # Call parent run()

    #*{__PACKAGE__ . "::_process_request"} = sub {
    {
        my $server = $self->net_server;

        local $SIG{CHLD} = 'IGNORE';    # reap child processes

        # $pkg is generated anew for each invocation to "run"
        # Just so we can use different net_server() implementations
        # in different runs.
        my $pkg = join '::', ref($self), "NetServer";
        my $thispkg = ref($self);

        no strict 'refs';
        *{"$pkg\::process_request"} = $self->_process_request;

        if ($server) {
            require join( '/', split /::/, $server ) . '.pm';
            *{"$pkg\::ISA"} = [$server];

            # clear the environment before every request
            require HTTP::Server::Simple::CGI;
            *{"$pkg\::post_accept"} = sub {
                HTTP::Server::Simple::CGI::Environment->setup_environment;
                $config{usessl} and $ENV{'HTTPS'} = 'on'; # Required by CGI spec. Also needed for CGI.pm to return 'on' (and not undef) in https() and to return https:// and not http:// links in url().
                # $self->SUPER::post_accept uses the wrong super package
                $server->can('post_accept')->(@_);
            };

            *{"$pkg\::post_accept_hook"} = sub {
                my ($xself) = @_;
                $main::_realpeername = $xself->{server}->{peername};
            };

        }
        else {
            $self->setup_listener;
        $self->after_setup_listener();
            *{"$pkg\::run"} = $self->_default_run;
        }

        #local $SIG{HUP} = sub { $SERVER_SHOULD_RUN = 0; };

        $pkg->run( port => $self->port, @_ );
    };


}

sub handle_continue_header {
    my ($self, %headers) = @_;
    my $continue = 1;

    print "HTTP/1.1 100 Continue\r\n";

    return $continue;

}

1;
__END__