File Coverage

blib/lib/POE/Filter/HTTP/Parser.pm

Criterion	Covered	Total	%
statement	110	117	94.0
branch	18	30	60.0
condition	17	35	48.5
subroutine	17	18	94.4
pod	6	6	100.0
total	168	206	81.5

package POE::Filter::HTTP::Parser;
$POE::Filter::HTTP::Parser::VERSION = '1.08';
# ABSTRACT: A HTTP POE filter for HTTP clients or servers

use strict;
use warnings;
use HTTP::Parser;
use HTTP::Status qw(status_message RC_BAD_REQUEST RC_OK RC_LENGTH_REQUIRED);
use base 'POE::Filter';
use Encode qw[encode_utf8];

my %type_map = (
   'server', 'request',
   'client', 'response',
);

sub new {
  my $class = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  if ( $opts{type} and defined $type_map{ $opts{type} } ) {
	$opts{type} = $type_map{ $opts{type} };
  }
  $opts{type} = 'response' unless $opts{type} and $opts{type} =~ /^(request|response)$/;
  my $self = \%opts;
  $self->{BUFFER} = [];
  $self->{parser} = HTTP::Parser->new( $self->{type} => 1 );
  bless $self, $class;
}

sub get_one_start {
  my ($self, $raw) = @_;
  push @{ $self->{BUFFER} }, $_ for @$raw;
}

sub get_one {
  my $self = shift;
  my $events = [];

  my $string = shift @{ $self->{BUFFER} };
  return [] unless $string;

  my $status;
  eval { $status = $self->{parser}->add( $string ); };

  if ( $@ and $self->{type} eq 'request' ) {
    # Build a HTTP::Response error message
    return [ $self->_build_error( RC_BAD_REQUEST, "$@" ) ];
  }

  if ( $@ and $self->{debug} ) {
     warn "$@\n";
     warn "Input was: '$string'\n";
     return $events;
  }

  if ( defined $status and $status == 0 ) {
     push @$events, $self->{parser}->object();
     my $data = $self->{parser}->data();
     unshift @{ $self->{BUFFER} }, $data if $data;
     $self->{parser} = HTTP::Parser->new( $self->{type} => 1 );
  }

  return $events;
}

sub _old_put {
  my ($self, $chunks) = @_;
  [ @$chunks ];
}

sub put {
  my $self = shift;
  my $return;
  if ( $self->{type} eq 'request' ) {
     $return = $self->_put_response( @_ );
  }
  else {
     $return = $self->_put_request( @_ );
  }
  $return;
}

sub _put_response {
  my ($self, $responses) = @_;
  my @raw;

  # HTTP::Response's as_string method returns the header lines
  # terminated by "\n", which does not do the right thing if we want
  # to send it to a client.  Here I've stolen HTTP::Response's
  # as_string's code and altered it to use network newlines so picky
  # browsers like lynx get what they expect.

  # And this is shamelessly stolen from POE::Filter::HTTPD

  foreach (@$responses) {
    my $code           = $_->code;
    my $status_message = status_message($code) || "Unknown Error";
    my $message        = $_->message  || "";
    my $proto          = $_->protocol || 'HTTP/1.0';

    my $status_line = "$proto $code";
    $status_line   .= " ($status_message)"  if $status_message ne $message;
    $status_line   .= " $message" if length($message);

    # Use network newlines, and be sure not to mangle newlines in the
    # response's content.

    my @headers;
    push @headers, $status_line;
    push @headers, $_->headers_as_string("\x0D\x0A");

    push @raw, encode_utf8(join("\x0D\x0A", @headers, "")) . $_->content;
  }

  \@raw;
}

sub _put_request {
  my ($self, $requests) = @_;
  my @raw;

  foreach (@$requests) {
    my $req_line = $_->method || "-";
    my $uri = $_->uri;
    $uri = (defined $uri) ? $uri->as_string : "-";
    $req_line .= " $uri";
    my $proto = $_->protocol;
    $req_line .= " $proto" if $proto;

    # Use network newlines, and be sure not to mangle newlines in the
    # response's content.

    my @headers;
    push @headers, $req_line;
    push @headers, $_->headers_as_string("\x0D\x0A");

    push @raw, encode_utf8(join("\x0D\x0A", @headers, "")) . $_->content;
  }

  \@raw;
}

sub clone {
  my $self = shift;
  my $nself = { };
  $nself->{$_} = $self->{$_} for keys %{ $self };
  $nself->{BUFFER} = [ ];
  $nself->{parser} = HTTP::Parser->new( $nself->{type} => 1 );
  return bless $nself, ref $self;
}

sub get_pending {
  my $self = shift;
  my $data = $self->{parser}->data();
  return unless $data or scalar @{ $self->{BUFFER} };
  return [ ( $data ? $data : () ), @{ $self->{BUFFER} } ];
}

sub _build_basic_response {
  my ($self, $content, $content_type, $status) = @_;

  # Need to check lengths in octets, not characters.
  BEGIN { eval { require bytes } and bytes->import; }

  $content_type ||= 'text/html';
  $status       ||= RC_OK;

  my $response = HTTP::Response->new($status);

  $response->push_header( 'Content-Type', $content_type );
  $response->push_header( 'Content-Length', length($content) );
  $response->content($content);

  return $response;
}

sub _build_error {
  my($self, $status, $details) = @_;

  $status  ||= RC_BAD_REQUEST;
  $details ||= '';
  my $message = status_message($status) || "Unknown Error";

  return $self->_build_basic_response(
    ( "" .
      "" .
      "Error $status: $message" .
      "" .
      "" .
      "Error $status: $message" .
      "$details" .
      "" .
      ""
    ),
    "text/html",
    $status
  );
}

'I filter therefore I am';

__END__