lib/HTTP/Body.pm

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