view release on metacpan or  search on metacpan

lib/Net/Server/HTTP.pm  view on Meta::CPAN

sub initialize_logging {
    my $self = shift;
    $self->SUPER::initialize_logging(@_);
    my $prop = $self->{'server'};

    my $d = {
        access_log_format => '%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-Agent}i\"',
    };
    $prop->{$_} = $d->{$_} foreach grep {!defined($prop->{$_})} keys %$d;

    $self->_init_access_log;
}

sub post_configure {
    my $self = shift;
    $self->SUPER::post_configure(@_);
    my $prop = $self->{'server'};

    # set other defaults
    my $d = {
        timeout_header  => 15,
        timeout_idle    => 60,
        server_revision => __PACKAGE__."/$Net::Server::VERSION",
        max_header_size => 100_000,
    };
    $prop->{$_} = $d->{$_} foreach grep {!defined($prop->{$_})} keys %$d;

    $self->_tie_client_stdout;
}

sub post_bind {
    my $self = shift;
    $self->SUPER::post_bind(@_);

    $self->_check_dispatch;
}

sub _init_access_log {
    my $self = shift;
    my $prop = $self->{'server'};
    my $log = $prop->{'access_log_file'};
    return if (! $log || $log eq '/dev/null') && ! $prop->{'access_log_function'};
    return if ! $prop->{'access_log_format'};
    $prop->{'access_log_format'} =~ s/\\([\\\"nt])/$1 eq 'n' ? "\n" : $1 eq 't' ? "\t" : $1/eg;
    if (my $code = $prop->{'access_log_function'}) {
        if (ref $code ne 'CODE') {
            die "Passed access_log_function $code was not a valid method of server, or was not a code object\n" if ! $self->can($code);
            my $copy = $self;
            $prop->{'access_log_function'} = sub { $copy->$code(@_) };
            weaken $copy;
        }
    } elsif ($log eq 'STDOUT' || $log eq '/dev/stdout') {
        open my $fh, '>&', \*STDOUT or die "Could not dup STDOUT: $!";
        $fh->autoflush(1);
        $prop->{'access_log_function'} = sub { print $fh @_,"\n" };
    } elsif ($log eq 'STDERR' || $log eq '/dev/stderr') {
        $prop->{'access_log_function'} = sub { print STDERR @_,"\n" };
    } else {
        open my $fh, '>>', $log or die "Could not open access_log_file \"$log\": $!";
        $fh->autoflush(1);
        push @{ $prop->{'chown_files'} }, $log;
        $prop->{'access_log_function'} = sub { print $fh @_,"\n" };
    }
}

sub _tie_client_stdout {
    my $self = shift;
    my $prop = $self->{'server'};

    # install a callback that will handle our outbound header negotiation for the clients similar to what apache does for us
    my $copy = $self;
    $prop->{'tie_client_stdout'} = 1;
    $prop->{'tied_stdout_callback'} = sub {
        my $client = shift;
        my $method = shift;
        alarm($copy->timeout_idle); # reset timeout

        my $request_info = $copy->{'request_info'};
        if ($request_info->{'headers_sent'}) { # keep track of how much has been printed
            my ($resp, $len);
            if ($method eq 'print') {
                $resp = $client->print(my $str = join '', @_);
                $len = length $str;
            } elsif ($method eq 'printf') {
                $resp = $client->print(my $str = sprintf(shift, @_));
                $len = length $str;
            } elsif ($method eq 'say') {
                $resp = $client->print(my $str = join '', @_, "\n");
                $len = length $str;
            } elsif ($method eq 'write') {
                my $buf = shift;
                $buf = substr($buf, $_[1] || 0, $_[0]) if @_;
                $resp = $client->print($buf);
                $len = length $buf;
            } elsif ($method eq 'syswrite') {
                $len = $resp = $client->syswrite(@_);
            } else {
                return $client->$method(@_);
            }
            $request_info->{'response_size'} = ($request_info->{'response_size'} || 0) + $len if defined $len;
            return $resp;
        }

        die "All headers must only be sent via print ($method)\n" if $method ne 'print';

        my $headers = ${*$client}{'headers'} ||= {buffer => '', status => undef, msg => undef, headers => []};
        $headers->{'buffer'} .= join('', @_);
        while ($headers->{'buffer'} =~ s/^(.*?)\015?\012//) {
            my $line = $1;

            if ($line =~ m{^HTTP/(1.[01]) \s+ (\d+) (?: | \s+ (.+?)) \s* $ }x) {
                die "Found HTTP/ line after other headers were sent\n" if @{ $headers->{'headers'} };
                @$headers{qw(version status msg)} = ($1, $2, $3);
            }
            elsif (! length $line) {
                if (! $headers->{'status'} && ! @{ $headers->{'headers'} }) {
                    die "Premature end of script headers\n";
                }
                delete ${*$client}{'headers'};
                $copy->send_status($headers);
                if (my $n = length $headers->{'buffer'}) {