lib/HTTP/Body.pm

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