← Index
NYTProf Performance Profile   « line view »
For script/ponapi
  Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

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