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 =head1 NAME
  30
  31 HTTP::Body::Parser
  32
  33 =head1 METHODS
  34
  35 =over 4
  36
  37 =item new($hashref)
  38
  39 Constructor.
  40
  41 =cut
  42
  43 sub new {
  44     my $class  = ref $_[0] ? ref shift : shift;
  45     my $params = Params::Validate::validate_with(
  46         params  => \@_,
  47         spec    => {
  48             bufsize => {
  49                 type      => Params::Validate::SCALAR,
  50                 default   => 65536,
  51                 optional  => 1
  52             },
  53             context => {
  54                 type      => Params::Validate::OBJECT,
  55                 isa       => 'HTTP::Body::Context',
  56                 optional  => 0
  57             }
  58         },
  59         called  => "$class\::new"
  60     );
  61
  62     # subclass
  63     if ( $class ne __PACKAGE__ ) {
  64         return bless( {}, $class )->initialize($params);
  65     }
  66
  67     # factory
  68     my $content_type = $params->{context}->content_type;
  69
  70     Carp::croak qq/Mandatory header 'Content-Type' is missing from headers in context./
  71       unless defined $content_type;
  72
  73     my $parser = $PARSERS->{ lc $content_type } || $PARSERS->{ 'application/octet-stream' };
  74
  75     eval "require $parser;"
  76       or Carp::croak qq/Failed to load parser '$parser' for Content-Type '$content_type'. Reason '$@'/;
  77
  78     return $parser->new($params);
  79 }
  80
  81 sub initialize {
  82     my ( $self, $params ) = @_;
  83
  84     $params->{buffer}   = '';
  85     $params->{length}   = 0;
  86     $params->{seen_eos} = 0;
  87
  88     while ( my ( $param, $value ) = each( %{ $params } ) ) {
  89         $self->$param($value);
  90     }
  91
  92     return $self;
  93 }
  94
  95 sub buffer : lvalue {
  96     my $self = shift;
  97
  98     if ( @_ ) {
  99         $self->{buffer} = $_[0];
 100     }
 101
 102     $self->{buffer};
 103 }
 104
 105 sub length : lvalue {
 106     my $self = shift;
 107
 108     if ( @_ ) {
 109         $self->{length} = $_[0];
 110     }
 111
 112     $self->{length};
 113 }
 114
 115 sub eos {
 116     my $self = shift;
 117
 118     $self->seen_eos(1);
 119
 120     if ( $self->context->content_length ) {
 121
 122         my $expected = $self->context->content_length;
 123         my $length   = $self->length;
 124
 125         if ( $length < $expected ) {
 126             Carp::croak qq/Truncated body. Expected $expected bytes, but only got $length bytes./;
 127         }
 128     }
 129
 130     return $self->parse;
 131 }
 132
 133 sub put {
 134     my $self = shift;
 135
 136     if ( defined $_[0] ) {
 137         $self->length += bytes::length $_[0];
 138         $self->buffer .= $_[0];
 139     }
 140
 141     return $self->parse;
 142 }
 143
 144 =back
 145
 146 =head1 AUTHOR
 147
 148 Christian Hansen, C<ch@ngmedia.com>
 149
 150 This pod written by Ash Berlin, C<ash@cpan.org>.
 151
 152 =head1 LICENSE
 153
 154 This library is free software. You can redistribute it and/or modify
 155 it under the same terms as perl itself.
 156
 157 =cut
 158
 159 1;