lib/HTTP/Body.pm

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