lib/HTTP/Body.pm

   1 package HTTP::Body;
   2
   3 use strict;
   4
   5 use Carp       qw[ ];
   6 use List::Util qw[ first ];
   7
   8 our $VERSION = '0.201';
   9
  10 our $TYPES = {
  11     'application/octet-stream'          => 'HTTP::Body::OctetStream',
  12     'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded',
  13     'multipart/form-data'               => 'HTTP::Body::MultiPart'
  14 };
  15
  16 =head1 NAME
  17
  18 HTTP::Body - HTTP Body Parser
  19
  20 =head1 SYNOPSIS
  21
  22     use HTTP::Body;
  23
  24     sub handler : method {
  25         my ( $class, $r ) = @_;
  26
  27         my $content_type   = $r->headers_in->get('Content-Type');
  28         my $content_length = $r->headers_in->get('Content-Length');
  29
  30         my $body   = HTTP::Body->new( $content_type, $content_length );
  31         my $length = $content_length;
  32
  33         while ( $length ) {
  34
  35             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
  36
  37             $length -= length($buffer);
  38
  39             $body->add($buffer);
  40         }
  41
  42         my $uploads = $body->upload; # hashref
  43         my $params  = $body->param;  # hashref
  44         my $body    = $body->body;   # IO::Handle
  45     }
  46
  47 =head1 DESCRIPTION
  48
  49 HTTP Body Parser.
  50
  51 =head1 METHODS
  52
  53 =over 4
  54
  55 =item new
  56
  57 Constructor. Takes content type and content length as parameters,
  58 returns a L<HTTP::Body> object.
  59
  60 =cut
  61
  62 sub new {
  63     my ( $class, $content_type, $content_length ) = @_;
  64
  65     unless ( @_ == 3 ) {
  66         Carp::croak( $class, '->new( $content_type, $content_length )' );
  67     }
  68
  69     my $type = first { index( lc($content_type), $_ ) >= 0 } keys %{$TYPES};
  70     my $body = $TYPES->{ $type || 'application/octet-stream' };
  71
  72     eval "require $body";
  73
  74     if ($@) {
  75         die $@;
  76     }
  77
  78     my $self = {
  79         buffer         => '',
  80         body           => undef,
  81         content_length => $content_length,
  82         content_type   => $content_type,
  83         length         => 0,
  84         param          => {},
  85         state          => 'buffering',
  86         upload         => {}
  87     };
  88
  89     bless( $self, $body );
  90
  91     return $self->init;
  92 }
  93
  94 =item add
  95
  96 Add string to internal buffer. Will call spin unless done. returns
  97 length before adding self.
  98
  99 =cut
 100
 101 sub add {
 102     my $self = shift;
 103
 104     if ( defined $_[0] ) {
 105         $self->{buffer} .= $_[0];
 106         $self->{length} += length( $_[0] );
 107     }
 108
 109     unless ( $self->state eq 'done' ) {
 110         $self->spin;
 111     }
 112
 113     return ( $self->length - $self->content_length );
 114 }
 115
 116 =item body
 117
 118 accessor for the body.
 119
 120 =cut
 121
 122 sub body {
 123     my $self = shift;
 124     $self->{body} = shift if @_;
 125     return $self->{body};
 126 }
 127
 128 =item buffer
 129
 130 read only accessor for the buffer.
 131
 132 =cut
 133
 134 sub buffer {
 135     return shift->{buffer};
 136 }
 137
 138 =item content_length
 139
 140 read only accessor for content length
 141
 142 =cut
 143
 144 sub content_length {
 145     return shift->{content_length};
 146 }
 147
 148 =item content_type
 149
 150 ready only accessor for the content type
 151
 152 =cut
 153
 154 sub content_type {
 155     return shift->{content_type};
 156 }
 157
 158 =item init
 159
 160 return self.
 161
 162 =cut
 163
 164 sub init {
 165     return $_[0];
 166 }
 167
 168 =item length
 169
 170 read only accessor for body length.
 171
 172 =cut
 173
 174 sub length {
 175     return shift->{length};
 176 }
 177
 178 =item spin
 179
 180 Abstract method to spin the io handle.
 181
 182 =cut
 183
 184 sub spin {
 185     Carp::croak('Define abstract method spin() in implementation');
 186 }
 187
 188 =item state
 189
 190 accessor for body state.
 191
 192 =cut
 193
 194 sub state {
 195     my $self = shift;
 196     $self->{state} = shift if @_;
 197     return $self->{state};
 198 }
 199
 200 =item param
 201
 202 accesor for http parameters.
 203
 204 =cut
 205
 206 sub param {
 207     my $self = shift;
 208
 209     if ( @_ == 2 ) {
 210
 211         my ( $name, $value ) = @_;
 212
 213         if ( exists $self->{param}->{$name} ) {
 214             for ( $self->{param}->{$name} ) {
 215                 $_ = [$_] unless ref($_) eq "ARRAY";
 216                 push( @$_, $value );
 217             }
 218         }
 219         else {
 220             $self->{param}->{$name} = $value;
 221         }
 222     }
 223
 224     return $self->{param};
 225 }
 226
 227 =item upload
 228
 229 =cut
 230
 231 sub upload {
 232     my $self = shift;
 233
 234     if ( @_ == 2 ) {
 235
 236         my ( $name, $upload ) = @_;
 237
 238         if ( exists $self->{upload}->{$name} ) {
 239             for ( $self->{upload}->{$name} ) {
 240                 $_ = [$_] unless ref($_) eq "ARRAY";
 241                 push( @$_, $upload );
 242             }
 243         }
 244         else {
 245             $self->{upload}->{$name} = $upload;
 246         }
 247     }
 248
 249     return $self->{upload};
 250 }
 251
 252 =back
 253
 254 =head1 BUGS
 255
 256 Chunked requests are currently not supported.
 257
 258 =head1 AUTHOR
 259
 260 Christian Hansen, C<ch@ngmedia.com>
 261
 262 Sebastian Riedel, C<sri@cpan.org>
 263
 264 =head1 LICENSE
 265
 266 This library is free software. You can redistribute it and/or modify
 267 it under the same terms as perl itself.
 268
 269 =cut
 270
 271 1;