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     my $cl = $self->content_length;
 114
 115     if ( defined $_[0] ) {
 116         $self->{length} += length( $_[0] );
 117
 118         # Don't allow buffer data to exceed content-length
 119         if ( $self->{length} > $cl ) {
 120             $_[0] = substr $_[0], 0, $cl - $self->{length};
 121             $self->{length} = $cl;
 122         }
 123
 124         $self->{buffer} .= $_[0];
 125     }
 126
 127     unless ( $self->state eq 'done' ) {
 128         $self->spin;
 129     }
 130
 131     return ( $self->length - $cl );
 132 }
 133
 134 =item body
 135
 136 accessor for the body.
 137
 138 =cut
 139
 140 sub body {
 141     my $self = shift;
 142     $self->{body} = shift if @_;
 143     return $self->{body};
 144 }
 145
 146 =item buffer
 147
 148 read only accessor for the buffer.
 149
 150 =cut
 151
 152 sub buffer {
 153     return shift->{buffer};
 154 }
 155
 156 =item content_length
 157
 158 read only accessor for content length
 159
 160 =cut
 161
 162 sub content_length {
 163     return shift->{content_length};
 164 }
 165
 166 =item content_type
 167
 168 ready only accessor for the content type
 169
 170 =cut
 171
 172 sub content_type {
 173     return shift->{content_type};
 174 }
 175
 176 =item init
 177
 178 return self.
 179
 180 =cut
 181
 182 sub init {
 183     return $_[0];
 184 }
 185
 186 =item length
 187
 188 read only accessor for body length.
 189
 190 =cut
 191
 192 sub length {
 193     return shift->{length};
 194 }
 195
 196 =item spin
 197
 198 Abstract method to spin the io handle.
 199
 200 =cut
 201
 202 sub spin {
 203     Carp::croak('Define abstract method spin() in implementation');
 204 }
 205
 206 =item state
 207
 208 accessor for body state.
 209
 210 =cut
 211
 212 sub state {
 213     my $self = shift;
 214     $self->{state} = shift if @_;
 215     return $self->{state};
 216 }
 217
 218 =item param
 219
 220 accesor for http parameters.
 221
 222 =cut
 223
 224 sub param {
 225     my $self = shift;
 226
 227     if ( @_ == 2 ) {
 228
 229         my ( $name, $value ) = @_;
 230
 231         if ( exists $self->{param}->{$name} ) {
 232             for ( $self->{param}->{$name} ) {
 233                 $_ = [$_] unless ref($_) eq "ARRAY";
 234                 push( @$_, $value );
 235             }
 236         }
 237         else {
 238             $self->{param}->{$name} = $value;
 239         }
 240     }
 241
 242     return $self->{param};
 243 }
 244
 245 =item upload
 246
 247 =cut
 248
 249 sub upload {
 250     my $self = shift;
 251
 252     if ( @_ == 2 ) {
 253
 254         my ( $name, $upload ) = @_;
 255
 256         if ( exists $self->{upload}->{$name} ) {
 257             for ( $self->{upload}->{$name} ) {
 258                 $_ = [$_] unless ref($_) eq "ARRAY";
 259                 push( @$_, $upload );
 260             }
 261         }
 262         else {
 263             $self->{upload}->{$name} = $upload;
 264         }
 265     }
 266
 267     return $self->{upload};
 268 }
 269
 270 =back
 271
 272 =head1 BUGS
 273
 274 Chunked requests are currently not supported.
 275
 276 =head1 AUTHOR
 277
 278 Christian Hansen, C<ch@ngmedia.com>
 279
 280 Sebastian Riedel, C<sri@cpan.org>
 281
 282 =head1 LICENSE
 283
 284 This library is free software. You can redistribute it and/or modify
 285 it under the same terms as perl itself.
 286
 287 =cut
 288
 289 1;