view release on metacpan or  search on metacpan

lib/Catalyst/Engine/HTTP/Prefork/Handler.pm  view on Meta::CPAN

    my $read;
    
    # If we have any remaining data in the input buffer, send it back first
    if ( $_[0] = $self->{client}->{inputbuf} ) {
        $read = length( $_[0] );
        $self->{client}->{inputbuf} = '';
        
        # XXX: Data::Dump segfaults on 5.8.8 when dumping long strings...
        DEBUG && warn "[$$] read_chunk: Read $read bytes from previous input buffer\n"; # . dump($_[0]) . "\n";
    }
    else {
        $read = $self->SUPER::read_chunk( $c, @_ );
        DEBUG && warn "[$$] read_chunk: Read $read bytes from STDIN\n"; # . dump($_[0]) . "\n";
    }
    
    return $read;
}

sub finalize_read {
    my ( $self, $c ) = @_;
    
    delete $self->{_chunked_req};
    
    return $self->SUPER::finalize_read( $c );
}

sub finalize_headers {
    my ( $self, $c ) = @_;
    
    my $protocol = $c->request->protocol;
    my $status   = $c->response->status;
    my $message  = status_message($status);
    
    my @headers;
    push @headers, "$protocol $status $message";
    
    # Switch on Transfer-Encoding: chunked if we don't know Content-Length.
    if ( $protocol eq 'HTTP/1.1' ) {
        if ( !$c->response->content_length ) {
            if ( $c->response->status !~ /^1\d\d|[23]04$/ ) {
                DEBUG && warn "[$$] Using chunked transfer-encoding to send unknown length body\n";
                $c->response->header( 'Transfer-Encoding' => 'chunked' );
                $self->{_chunked_res} = 1;
            }
        }
        elsif ( my $te = $c->response->header('Transfer-Encoding') ) {
            if ( $te eq 'chunked' ) {
                DEBUG && warn "[$$] Chunked transfer-encoding set for response\n";
                $self->{_chunked_res} = 1;
            }
        }
    }
    
    if ( !$c->response->header('Date') ) {
        $c->response->header( Date => time2str( time() ) );
    }
    
    $c->response->header( Status => $c->response->status );
    
    # Should we keep the connection open?
    if ( $self->{client}->{keepalive} ) {
        $c->response->headers->header( Connection => 'keep-alive' );
    }
    else {
        $c->response->headers->header( Connection => 'close' );
    }
    
    push @headers, $c->response->headers->as_string($CRLF);
    
    # Buffer the headers so they are sent with the first write() call
    # This reduces the number of TCP packets we are sending
    $self->{_header_buf} = join( $CRLF, @headers, '' );
}

sub finalize_body {
    my ( $self, $c ) = @_;
    
    $self->SUPER::finalize_body( $c );
    
    if ( $self->{_chunked_res} ) {
        if ( !$self->{_chunked_done} ) {
            # Write the final '0' chunk
            syswrite STDOUT, "0$CRLF";
        }
        
        delete $self->{_chunked_res};
        delete $self->{_chunked_done};
    } 
}

sub write {
    my ( $self, $c, $buffer ) = @_;

    if ( $self->{_chunked_res} ) {
        my $len = length($buffer);
        
        $buffer = sprintf( "%x", $len ) . $CRLF . $buffer . $CRLF;
        
        # Flag if we wrote an empty chunk
        if ( !$len ) {
            $self->{_chunked_done} = 1;
        }
    }
    
    DEBUG && warn "[$$] Wrote " . length($buffer) . " bytes\n";
    
    $self->SUPER::write( $c, $buffer );
}

1;