lib/HTTP/Body/Parser.pm

   1 package HTTP::Body::Parser;
   2
   3 use strict;
   4 use warnings;
   5 use bytes;
   6 use base 'Class::Accessor::Fast';
   7
   8 use Carp             qw[];
   9 use Class::Param     qw[];
  10 use HTTP::Headers    qw[];
  11 use Params::Validate qw[];
  12
  13 __PACKAGE__->mk_accessors( qw[ bufsize context seen_eos ] );
  14
  15 our $PARSERS = { };
  16
  17 sub register_parser {
  18     my ( $content_type, $parser ) = ( @_ == 2 ) ?  @_[ 1, 0 ] : @_[ 1, 2 ];
  19
  20     $PARSERS->{ $content_type } = $parser;
  21
  22     eval "use prefork '$parser';";
  23 }
  24
  25 __PACKAGE__->register_parser( 'application/octet-stream'          => 'HTTP::Body::Parser::OctetStream' );
  26 __PACKAGE__->register_parser( 'application/x-www-form-urlencoded' => 'HTTP::Body::Parser::UrlEncoded' );
  27 __PACKAGE__->register_parser( 'multipart/form-data'               => 'HTTP::Body::Parser::MultiPart'   );
  28
  29 sub new {
  30     my $class  = ref $_[0] ? ref shift : shift;
  31     my $params = Params::Validate::validate_with(
  32         params  => \@_,
  33         spec    => {
  34             bufsize => {
  35                 type      => Params::Validate::SCALAR,
  36                 default   => 65536,
  37                 optional  => 1
  38             },
  39             context => {
  40                 type      => Params::Validate::OBJECT,
  41                 isa       => 'HTTP::Body::Context',
  42                 optional  => 0
  43             }
  44         },
  45         called  => "$class\::new"
  46     );
  47
  48     # subclass
  49     if ( $class ne __PACKAGE__ ) {
  50         return bless( {}, $class )->initialize($params);
  51     }
  52
  53     # factory
  54     my $content_type = $params->{context}->content_type;
  55
  56     Carp::croak qq/Mandatory header 'Content-Type' is missing from headers in context./
  57       unless defined $content_type;
  58
  59     my $parser = $PARSERS->{ lc $content_type } || $PARSERS->{ 'application/octet-stream' };
  60
  61     eval "require $parser;"
  62       or Carp::croak qq/Failed to load parser '$parser' for Content-Type '$content_type'. Reason '$@'/;
  63
  64     return $parser->new($params);
  65 }
  66
  67 sub initialize {
  68     my ( $self, $params ) = @_;
  69
  70     $params->{buffer}   = '';
  71     $params->{length}   = 0;
  72     $params->{seen_eos} = 0;
  73
  74     while ( my ( $param, $value ) = each( %{ $params } ) ) {
  75         $self->$param($value);
  76     }
  77
  78     return $self;
  79 }
  80
  81 sub buffer : lvalue {
  82     my $self = shift;
  83
  84     if ( @_ ) {
  85         $self->{buffer} = $_[0];
  86     }
  87
  88     $self->{buffer};
  89 }
  90
  91 sub length : lvalue {
  92     my $self = shift;
  93
  94     if ( @_ ) {
  95         $self->{length} = $_[0];
  96     }
  97
  98     $self->{length};
  99 }
 100
 101 sub eos {
 102     my $self = shift;
 103
 104     $self->seen_eos(1);
 105
 106     if ( $self->context->content_length ) {
 107
 108         my $expected = $self->context->content_length;
 109         my $length   = $self->length;
 110
 111         if ( $length < $expected ) {
 112             Carp::croak qq/Truncated body. Expected $expected bytes, but only got $length bytes./;
 113         }
 114     }
 115
 116     return $self->parse;
 117 }
 118
 119 sub put {
 120     my $self = shift;
 121
 122     if ( defined $_[0] ) {
 123         $self->length += bytes::length $_[0];
 124         $self->buffer .= $_[0];
 125     }
 126
 127     return $self->parse;
 128 }
 129
 130 1;