lib/HTTP/Body/Compat.pm

   1 package HTTP::Body::Compat;
   2
   3 use strict;
   4 use warnings;
   5 use base 'HTTP::Body';
   6
   7 use Params::Validate    qw[];
   8 use HTTP::Body::Context qw[];
   9
  10 =head1 NAME
  11
  12 HTTP::Body::Compat - Backwards compataible HTTP Body Parser for versions <= 0.6
  13
  14 =head1 SYNOPSIS
  15
  16    use HTTP::Body;
  17
  18    sub handler : method {
  19        my ( $class, $r ) = @_;
  20
  21        my $content_type   = $r->headers_in->get('Content-Type');
  22        my $content_length = $r->headers_in->get('Content-Length');
  23
  24        # Calling HTTP::Body->new this way will go into pre 0.7 compat mode
  25        my $body   = HTTP::Body->new( $content_type, $content_length );
  26        my $length = $content_length;
  27
  28        while ( $length ) {
  29
  30            $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
  31
  32            $length -= length($buffer);
  33
  34            $body->add($buffer);
  35        }
  36
  37        my $uploads = $body->upload; # hashref
  38        my $params  = $body->param;  # hashref
  39        my $body    = $body->body;   # IO::Handle
  40    }
  41
  42 =head1 DESCRIPTION
  43
  44 HTTP Body Parser.
  45
  46 =head1 METHODS
  47
  48 =over 4
  49
  50 =item new
  51
  52 Constructor. Takes content type and content length as parameters,
  53 returns a L<HTTP::Body::Compat> object.
  54
  55 =cut
  56
  57 sub new {
  58     my $class   = ref $_[0] ? ref shift : shift;
  59     my ( $content_type, $content_length ) = Params::Validate::validate_with(
  60         params  => \@_,
  61         spec    => [
  62             {
  63                 type      => Params::Validate::SCALAR,
  64                 optional  => 0
  65             },
  66             {
  67                 type      => Params::Validate::SCALAR,
  68                 optional  => 0
  69             }
  70         ],
  71         called  => "$class\::new"
  72     );
  73
  74     my $context = HTTP::Body::Context->new(
  75         headers => {
  76             'Content-Type'   => $content_type,
  77             'Content-Length' => $content_length
  78         }
  79     );
  80
  81     return bless( {}, $class )->initialize( { context => $context } );
  82 }
  83
  84 =item add
  85
  86 Add string to internal buffer. Returns length before adding string.
  87
  88 =cut
  89
  90 sub add {
  91     my $self = shift;
  92
  93     if ( defined $_[0] ) {
  94         $self->{length} += bytes::length $_[0];
  95     }
  96
  97     $self->put(@_);
  98
  99     if ( $self->length == $self->content_length ) {
 100         $self->eos;
 101         return 0;
 102     }
 103
 104     return ( $self->length - $self->content_length );
 105 }
 106
 107 =item body
 108
 109 accessor for the body
 110
 111 =cut
 112
 113 sub body {
 114     return $_[0]->context->content;
 115 }
 116
 117 sub buffer {
 118     return '';
 119 }
 120
 121 =item content_length
 122
 123 Read-only accessor for content legnth
 124
 125 =cut
 126
 127 sub content_length {
 128     return $_[0]->context->content_length;
 129 }
 130
 131 =item content_type
 132
 133 Read-only accessor for content type
 134
 135 =cut
 136
 137 sub content_type {
 138     return $_[0]->context->content_type;
 139 }
 140
 141 sub length {
 142     return $_[0]->{length};
 143 }
 144
 145 sub state {
 146     return 'done';
 147 }
 148
 149 =item param
 150
 151 Accessor for HTTP parameters
 152
 153 =cut
 154
 155 sub param {
 156     my $self = shift;
 157
 158     if ( @_ == 2 ) {
 159         return $self->context->param->add(@_);
 160     }
 161
 162     return scalar $self->context->param->as_hash;
 163 }
 164
 165 =iteam upload
 166
 167 =cut
 168
 169 sub upload {
 170     my $self = shift;
 171
 172     if ( @_ == 2 ) {
 173         return $self->context->upload->add(@_);
 174     }
 175
 176     return scalar $self->context->upload->as_hash;
 177 }
 178
 179 =back
 180
 181 =head1 AUTHOR
 182
 183 Christian Hansen, C<ch@ngmedia.com>
 184
 185 This pod written by Ash Berlin, C<ash@cpan.org>.
 186
 187 =head1 LICENSE
 188
 189 This library is free software. You can redistribute it and/or modify
 190 it under the same terms as perl itself.
 191
 192 =cut
 193
 194 1;