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.01';
   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 =cut
  56
  57 sub new {
  58     my ( $class, $content_type, $content_length ) = @_;
  59
  60     unless ( @_ == 3 ) {
  61         Carp::croak( $class, '->new( $content_type, $content_length )' );
  62     }
  63
  64     my $type = first { index( lc($content_type), $_ ) >= 0 } keys %{$TYPES};
  65     my $body = $TYPES->{ $type || 'application/octet-stream' };
  66
  67     eval "require $body";
  68
  69     if ($@) {
  70         die $@;
  71     }
  72
  73     my $self = {
  74         buffer         => '',
  75         body           => undef,
  76         content_length => $content_length,
  77         content_type   => $content_type,
  78         length         => 0,
  79         param          => {},
  80         state          => 'buffering',
  81         upload         => {}
  82     };
  83
  84     bless( $self, $body );
  85
  86     return $self->init;
  87 }
  88
  89 =item add
  90
  91 =cut
  92
  93 sub add {
  94     my $self = shift;
  95
  96     if ( defined $_[0] ) {
  97         $self->{buffer} .= $_[0];
  98         $self->{length} += length( $_[0] );
  99     }
 100
 101     unless ( $self->state eq 'done' ) {
 102         $self->spin;
 103     }
 104
 105     return ( $self->length - $self->content_length );
 106 }
 107
 108 =item body
 109
 110 =cut
 111
 112 sub body {
 113     my $self = shift;
 114     $self->{body} = shift if @_;
 115     return $self->{body};
 116 }
 117
 118 =item buffer
 119
 120 =cut
 121
 122 sub buffer {
 123     return shift->{buffer};
 124 }
 125
 126 =item content_length
 127
 128 =cut
 129
 130 sub content_length {
 131     return shift->{content_length};
 132 }
 133
 134 =item content_type
 135
 136 =cut
 137
 138 sub content_type {
 139     return shift->{content_type};
 140 }
 141
 142 =item init
 143
 144 =cut
 145
 146 sub init {
 147     return $_[0];
 148 }
 149
 150 =item length
 151
 152 =cut
 153
 154 sub length {
 155     return shift->{length};
 156 }
 157
 158 =item spin
 159
 160 =cut
 161
 162 sub spin {
 163     Carp::croak('Define abstract method spin() in implementation');
 164 }
 165
 166 =item state
 167
 168 =cut
 169
 170 sub state {
 171     my $self = shift;
 172     $self->{state} = shift if @_;
 173     return $self->{state};
 174 }
 175
 176 =item param
 177
 178 =cut
 179
 180 sub param {
 181     my $self = shift;
 182
 183     if ( @_ == 2 ) {
 184
 185         my ( $name, $value ) = @_;
 186
 187         if ( exists $self->{param}->{$name} ) {
 188             for ( $self->{param}->{$name} ) {
 189                 $_ = [$_] unless ref($_) eq "ARRAY";
 190                 push( @$_, $value );
 191             }
 192         }
 193         else {
 194             $self->{param}->{$name} = $value;
 195         }
 196     }
 197
 198     return $self->{param};
 199 }
 200
 201 =item upload
 202
 203 =cut
 204
 205 sub upload {
 206     my $self = shift;
 207
 208     if ( @_ == 2 ) {
 209
 210         my ( $name, $upload ) = @_;
 211
 212         if ( exists $self->{upload}->{$name} ) {
 213             for ( $self->{upload}->{$name} ) {
 214                 $_ = [$_] unless ref($_) eq "ARRAY";
 215                 push( @$_, $upload );
 216             }
 217         }
 218         else {
 219             $self->{upload}->{$name} = $upload;
 220         }
 221     }
 222
 223     return $self->{upload};
 224 }
 225
 226 =back
 227
 228 =head1 AUTHOR
 229
 230 Christian Hansen, C<ch@ngmedia.com>
 231
 232 Sebastian Riedel, C<sri@cpan.org>
 233
 234 =head1 LICENSE
 235
 236 This library is free software. You can redistribute it and/or modify
 237 it under the same terms as perl itself.
 238
 239 =cut
 240
 241 1;