Add version 1.11 of HTTP::Body with new param_order functionality
[catagits/HTTP-Body.git] / lib / HTTP / Body.pm
1 package HTTP::Body;
2
3 use strict;
4
5 use Carp       qw[ ];
6
7 our $TYPES = {
8     'application/octet-stream'          => 'HTTP::Body::OctetStream',
9     'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded',
10     'multipart/form-data'               => 'HTTP::Body::MultiPart',
11     'multipart/related'                 => 'HTTP::Body::XFormsMultipart',
12     'application/xml'                   => 'HTTP::Body::XForms'
13 };
14
15 require HTTP::Body::OctetStream;
16 require HTTP::Body::UrlEncoded;
17 require HTTP::Body::MultiPart;
18 require HTTP::Body::XFormsMultipart;
19 require HTTP::Body::XForms;
20
21 use HTTP::Headers;
22 use HTTP::Message;
23
24 =head1 NAME
25
26 HTTP::Body - HTTP Body Parser
27
28 =head1 SYNOPSIS
29
30     use HTTP::Body;
31     
32     sub handler : method {
33         my ( $class, $r ) = @_;
34
35         my $content_type   = $r->headers_in->get('Content-Type');
36         my $content_length = $r->headers_in->get('Content-Length');
37         
38         my $body   = HTTP::Body->new( $content_type, $content_length );
39         my $length = $content_length;
40
41         while ( $length ) {
42
43             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
44
45             $length -= length($buffer);
46             
47             $body->add($buffer);
48         }
49         
50         my $uploads     = $body->upload;     # hashref
51         my $params      = $body->param;      # hashref
52         my $param_order = $body->param_order # arrayref
53         my $body        = $body->body;       # IO::Handle
54     }
55
56 =head1 DESCRIPTION
57
58 HTTP::Body parses chunks of HTTP POST data and supports 
59 application/octet-stream, application/x-www-form-urlencoded, and
60 multipart/form-data.
61
62 Chunked bodies are supported by not passing a length value to new().
63
64 It is currently used by L<Catalyst> to parse POST bodies.
65
66 =head1 NOTES
67
68 When parsing multipart bodies, temporary files are created to store any
69 uploaded files.  You must delete these temporary files yourself after
70 processing them, or set $body->cleanup(1) to automatically delete them
71 at DESTROY-time.
72
73 =head1 METHODS
74
75 =over 4 
76
77 =item new 
78
79 Constructor. Takes content type and content length as parameters,
80 returns a L<HTTP::Body> object.
81
82 =cut
83
84 sub new {
85     my ( $class, $content_type, $content_length ) = @_;
86
87     unless ( @_ >= 2 ) {
88         Carp::croak( $class, '->new( $content_type, [ $content_length ] )' );
89     }
90
91     my $type;
92     foreach my $supported ( keys %{$TYPES} ) {
93         if ( index( lc($content_type), $supported ) >= 0 ) {
94             $type = $supported;
95         }
96     }
97
98     my $body = $TYPES->{ $type || 'application/octet-stream' };
99
100     my $self = {
101         cleanup        => 0,
102         buffer         => '',
103         chunk_buffer   => '',
104         body           => undef,
105         chunked        => !defined $content_length,
106         content_length => defined $content_length ? $content_length : -1,
107         content_type   => $content_type,
108         length         => 0,
109         param          => {},
110         param_order    => [],
111         state          => 'buffering',
112         upload         => {},
113         tmpdir         => File::Spec->tmpdir(),
114     };
115
116     bless( $self, $body );
117
118     return $self->init;
119 }
120
121 sub DESTROY {
122     my $self = shift;
123     
124     if ( $self->{cleanup} ) {
125         my @temps = ();
126         for my $upload ( values %{ $self->{upload} } ) {
127             push @temps, map { $_->{tempname} || () }
128                 ( ref $upload eq 'ARRAY' ? @{$upload} : $upload );
129         }
130         
131         unlink map { $_ } grep { -e $_ } @temps;
132     }
133 }
134
135 =item add
136
137 Add string to internal buffer. Will call spin unless done. returns
138 length before adding self.
139
140 =cut
141
142 sub add {
143     my $self = shift;
144     
145     if ( $self->{chunked} ) {
146         $self->{chunk_buffer} .= $_[0];
147         
148         while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) {
149             my $chunk_len = hex($1);
150             
151             if ( $chunk_len == 0 ) {
152                 # Strip chunk len
153                 $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
154                 
155                 # End of data, there may be trailing headers
156                 if (  my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) {
157                     if ( my $message = HTTP::Message->parse( $headers ) ) {
158                         $self->{trailing_headers} = $message->headers;
159                     }
160                 }
161                 
162                 $self->{chunk_buffer} = '';
163                 
164                 # Set content_length equal to the amount of data we read,
165                 # so the spin methods can finish up.
166                 $self->{content_length} = $self->{length};
167             }
168             else {
169                 # Make sure we have the whole chunk in the buffer (+CRLF)
170                 if ( length( $self->{chunk_buffer} ) >= $chunk_len ) {
171                     # Strip chunk len
172                     $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
173                     
174                     # Pull chunk data out of chunk buffer into real buffer
175                     $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, '';
176                 
177                     # Strip remaining CRLF
178                     $self->{chunk_buffer} =~ s/^\x0D\x0A//;
179                 
180                     $self->{length} += $chunk_len;
181                 }
182                 else {
183                     # Not enough data for this chunk, wait for more calls to add()
184                     return;
185                 }
186             }
187             
188             unless ( $self->{state} eq 'done' ) {
189                 $self->spin;
190             }
191         }
192         
193         return;
194     }
195     
196     my $cl = $self->content_length;
197
198     if ( defined $_[0] ) {
199         $self->{length} += length( $_[0] );
200         
201         # Don't allow buffer data to exceed content-length
202         if ( $self->{length} > $cl ) {
203             $_[0] = substr $_[0], 0, $cl - $self->{length};
204             $self->{length} = $cl;
205         }
206         
207         $self->{buffer} .= $_[0];
208     }
209
210     unless ( $self->state eq 'done' ) {
211         $self->spin;
212     }
213
214     return ( $self->length - $cl );
215 }
216
217 =item body
218
219 accessor for the body.
220
221 =cut
222
223 sub body {
224     my $self = shift;
225     $self->{body} = shift if @_;
226     return $self->{body};
227 }
228
229 =item chunked
230
231 Returns 1 if the request is chunked.
232
233 =cut
234
235 sub chunked {
236     return shift->{chunked};
237 }
238
239 =item cleanup
240
241 Set to 1 to enable automatic deletion of temporary files at DESTROY-time.
242
243 =cut
244
245 sub cleanup {
246     my $self = shift;
247     $self->{cleanup} = shift if @_;
248     return $self->{cleanup};
249 }
250
251 =item content_length
252
253 Returns the content-length for the body data if known.
254 Returns -1 if the request is chunked.
255
256 =cut
257
258 sub content_length {
259     return shift->{content_length};
260 }
261
262 =item content_type
263
264 Returns the content-type of the body data.
265
266 =cut
267
268 sub content_type {
269     return shift->{content_type};
270 }
271
272 =item init
273
274 return self.
275
276 =cut
277
278 sub init {
279     return $_[0];
280 }
281
282 =item length
283
284 Returns the total length of data we expect to read if known.
285 In the case of a chunked request, returns the amount of data
286 read so far.
287
288 =cut
289
290 sub length {
291     return shift->{length};
292 }
293
294 =item trailing_headers
295
296 If a chunked request body had trailing headers, trailing_headers will
297 return an HTTP::Headers object populated with those headers.
298
299 =cut
300
301 sub trailing_headers {
302     return shift->{trailing_headers};
303 }
304
305 =item spin
306
307 Abstract method to spin the io handle.
308
309 =cut
310
311 sub spin {
312     Carp::croak('Define abstract method spin() in implementation');
313 }
314
315 =item state
316
317 Returns the current state of the parser.
318
319 =cut
320
321 sub state {
322     my $self = shift;
323     $self->{state} = shift if @_;
324     return $self->{state};
325 }
326
327 =item param
328
329 Get/set body parameters.
330
331 =cut
332
333 sub param {
334     my $self = shift;
335
336     if ( @_ == 2 ) {
337
338         my ( $name, $value ) = @_;
339
340         if ( exists $self->{param}->{$name} ) {
341             for ( $self->{param}->{$name} ) {
342                 $_ = [$_] unless ref($_) eq "ARRAY";
343                 push( @$_, $value );
344             }
345         }
346         else {
347             $self->{param}->{$name} = $value;
348         }
349
350         push @{$self->{param_order}}, $name;
351     }
352
353     return $self->{param};
354 }
355
356 =item upload
357
358 Get/set file uploads.
359
360 =cut
361
362 sub upload {
363     my $self = shift;
364
365     if ( @_ == 2 ) {
366
367         my ( $name, $upload ) = @_;
368
369         if ( exists $self->{upload}->{$name} ) {
370             for ( $self->{upload}->{$name} ) {
371                 $_ = [$_] unless ref($_) eq "ARRAY";
372                 push( @$_, $upload );
373             }
374         }
375         else {
376             $self->{upload}->{$name} = $upload;
377         }
378     }
379
380     return $self->{upload};
381 }
382
383 =item tmpdir 
384
385 Specify a different path for temporary files.  Defaults to the system temporary path.
386
387 =cut
388
389 sub tmpdir {
390     my $self = shift;
391     $self->{tmpdir} = shift if @_;
392     return $self->{tmpdir};
393 }
394
395 =item param_order
396
397 Returns the array ref of the param keys in the order how they appeared on the body
398
399 =cut
400
401 sub param_order {
402     return shift->{param_order};
403 }
404
405 =back
406
407 =head1 SUPPORT
408
409 Since its original creation this module has been taken over by the Catalyst
410 development team. If you want to contribute patches, these will be your
411 primary contact points:
412
413 IRC:
414
415     Join #catalyst-dev on irc.perl.org.
416
417 Mailing Lists:
418
419     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
420
421 =head1 AUTHOR
422
423 Christian Hansen, C<chansen@cpan.org>
424
425 Sebastian Riedel, C<sri@cpan.org>
426
427 Andy Grundman, C<andy@hybridized.org>
428
429 =head1 CONTRIBUTORS
430
431 Simon Elliott C<cpan@papercreatures.com>
432
433 Kent Fredric <kentnl@cpan.org>
434
435 Christian Walde
436
437 Torsten Raudssus <torsten@raudssus.de>
438
439 =head1 LICENSE
440
441 This library is free software. You can redistribute it and/or modify 
442 it under the same terms as perl itself.
443
444 =cut
445
446 1;