← 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/MultiPart.pm
StatementsExecuted 17 statements in 1.11ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11114µs83µsHTTP::Body::MultiPart::::BEGIN@11HTTP::Body::MultiPart::BEGIN@11
11110µs123µsHTTP::Body::MultiPart::::BEGIN@10HTTP::Body::MultiPart::BEGIN@10
11110µs20µsHTTP::Body::MultiPart::::BEGIN@6HTTP::Body::MultiPart::BEGIN@6
1116µs61µsHTTP::Body::MultiPart::::BEGIN@7HTTP::Body::MultiPart::BEGIN@7
1116µs6µsHTTP::Body::MultiPart::::BEGIN@12HTTP::Body::MultiPart::BEGIN@12
1116µs6µsHTTP::Body::MultiPart::::BEGIN@8HTTP::Body::MultiPart::BEGIN@8
1112µs2µsHTTP::Body::MultiPart::::CORE:qrHTTP::Body::MultiPart::CORE:qr (opcode)
0000s0sHTTP::Body::MultiPart::::boundaryHTTP::Body::MultiPart::boundary
0000s0sHTTP::Body::MultiPart::::boundary_beginHTTP::Body::MultiPart::boundary_begin
0000s0sHTTP::Body::MultiPart::::boundary_endHTTP::Body::MultiPart::boundary_end
0000s0sHTTP::Body::MultiPart::::crlfHTTP::Body::MultiPart::crlf
0000s0sHTTP::Body::MultiPart::::delimiter_beginHTTP::Body::MultiPart::delimiter_begin
0000s0sHTTP::Body::MultiPart::::delimiter_endHTTP::Body::MultiPart::delimiter_end
0000s0sHTTP::Body::MultiPart::::handlerHTTP::Body::MultiPart::handler
0000s0sHTTP::Body::MultiPart::::initHTTP::Body::MultiPart::init
0000s0sHTTP::Body::MultiPart::::parse_bodyHTTP::Body::MultiPart::parse_body
0000s0sHTTP::Body::MultiPart::::parse_boundaryHTTP::Body::MultiPart::parse_boundary
0000s0sHTTP::Body::MultiPart::::parse_headerHTTP::Body::MultiPart::parse_header
0000s0sHTTP::Body::MultiPart::::parse_preambleHTTP::Body::MultiPart::parse_preamble
0000s0sHTTP::Body::MultiPart::::spinHTTP::Body::MultiPart::spin
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::MultiPart;
2{
32900ns $HTTP::Body::MultiPart::VERSION = '1.19';
4}
5
6223µs231µs
# spent 20µs (10+11) within HTTP::Body::MultiPart::BEGIN@6 which was called: # once (10µs+11µs) by Plack::Request::BEGIN@10 at line 6
use strict;
# spent 20µs making 1 call to HTTP::Body::MultiPart::BEGIN@6 # spent 11µs making 1 call to strict::import
7222µs2116µs
# spent 61µs (6+55) within HTTP::Body::MultiPart::BEGIN@7 which was called: # once (6µs+55µs) by Plack::Request::BEGIN@10 at line 7
use base 'HTTP::Body';
# spent 61µs making 1 call to HTTP::Body::MultiPart::BEGIN@7 # spent 55µs making 1 call to base::import
8218µs27µs
# spent 6µs (6+1000ns) within HTTP::Body::MultiPart::BEGIN@8 which was called: # once (6µs+1000ns) by Plack::Request::BEGIN@10 at line 8
use bytes;
# spent 6µs making 1 call to HTTP::Body::MultiPart::BEGIN@8 # spent 1µs making 1 call to bytes::import
9
10227µs2236µs
# spent 123µs (10+113) within HTTP::Body::MultiPart::BEGIN@10 which was called: # once (10µs+113µs) by Plack::Request::BEGIN@10 at line 10
use IO::File;
# spent 123µs making 1 call to HTTP::Body::MultiPart::BEGIN@10 # spent 113µs making 1 call to Exporter::import
11338µs3152µs
# spent 83µs (14+69) within HTTP::Body::MultiPart::BEGIN@11 which was called: # once (14µs+69µs) by Plack::Request::BEGIN@10 at line 11
use File::Temp 0.14;
# spent 83µs making 1 call to HTTP::Body::MultiPart::BEGIN@11 # spent 60µs making 1 call to Exporter::import # spent 9µs making 1 call to UNIVERSAL::VERSION
122974µs16µs
# spent 6µs within HTTP::Body::MultiPart::BEGIN@12 which was called: # once (6µs+0s) by Plack::Request::BEGIN@10 at line 12
use File::Spec;
# spent 6µs making 1 call to HTTP::Body::MultiPart::BEGIN@12
13
14=head1 NAME
15
16HTTP::Body::MultiPart - HTTP Body Multipart Parser
17
18=head1 SYNOPSIS
19
20 use HTTP::Body::Multipart;
21
22=head1 DESCRIPTION
23
24HTTP Body Multipart Parser.
25
26=head1 METHODS
27
28=over 4
29
30=item init
31
32=cut
33
34sub init {
35 my $self = shift;
36
37 unless ( $self->content_type =~ /boundary=\"?([^\";]+)\"?/ ) {
38 my $content_type = $self->content_type;
39 Carp::croak("Invalid boundary in content_type: '$content_type'");
40 }
41
42 $self->{boundary} = $1;
43 $self->{state} = 'preamble';
44
45 return $self;
46}
47
48=item spin
49
50=cut
51
52sub spin {
53 my $self = shift;
54
55 while (1) {
56
57 if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) {
58 my $method = "parse_$1";
59 return unless $self->$method;
60 }
61
62 else {
63 Carp::croak('Unknown state');
64 }
65 }
66}
67
68=item boundary
69
70=cut
71
72sub boundary {
73 return shift->{boundary};
74}
75
76=item boundary_begin
77
78=cut
79
80sub boundary_begin {
81 return "--" . shift->boundary;
82}
83
84=item boundary_end
85
86=cut
87
88sub boundary_end {
89 return shift->boundary_begin . "--";
90}
91
92=item crlf
93
94=cut
95
96sub crlf () {
97 return "\x0d\x0a";
98}
99
100=item delimiter_begin
101
102=cut
103
104sub delimiter_begin {
105 my $self = shift;
106 return $self->crlf . $self->boundary_begin;
107}
108
109=item delimiter_end
110
111=cut
112
113sub delimiter_end {
114 my $self = shift;
115 return $self->crlf . $self->boundary_end;
116}
117
118=item parse_preamble
119
120=cut
121
122sub parse_preamble {
123 my $self = shift;
124
125 my $index = index( $self->{buffer}, $self->boundary_begin );
126
127 unless ( $index >= 0 ) {
128 return 0;
129 }
130
131 # replace preamble with CRLF so we can match dash-boundary as delimiter
132 substr( $self->{buffer}, 0, $index, $self->crlf );
133
134 $self->{state} = 'boundary';
135
136 return 1;
137}
138
139=item parse_boundary
140
141=cut
142
143sub parse_boundary {
144 my $self = shift;
145
146 if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) {
147
148 substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' );
149 $self->{part} = {};
150 $self->{state} = 'header';
151
152 return 1;
153 }
154
155 if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) {
156
157 substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' );
158 $self->{part} = {};
159 $self->{state} = 'done';
160
161 return 0;
162 }
163
164 return 0;
165}
166
167=item parse_header
168
169=cut
170
171sub parse_header {
172 my $self = shift;
173
174 my $crlf = $self->crlf;
175 my $index = index( $self->{buffer}, $crlf . $crlf );
176
177 unless ( $index >= 0 ) {
178 return 0;
179 }
180
181 my $header = substr( $self->{buffer}, 0, $index );
182
183 substr( $self->{buffer}, 0, $index + 4, '' );
184
185 my @headers;
186 for ( split /$crlf/, $header ) {
187 if (s/^[ \t]+//) {
188 $headers[-1] .= $_;
189 }
190 else {
191 push @headers, $_;
192 }
193 }
194
195 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
196
197 for my $header (@headers) {
198
199 $header =~ s/^($token):[\t ]*//;
200
201 ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg;
202
203 if ( exists $self->{part}->{headers}->{$field} ) {
204 for ( $self->{part}->{headers}->{$field} ) {
205 $_ = [$_] unless ref($_) eq "ARRAY";
206 push( @$_, $header );
207 }
208 }
209 else {
210 $self->{part}->{headers}->{$field} = $header;
211 }
212 }
213
214 $self->{state} = 'body';
215
216 return 1;
217}
218
219=item parse_body
220
221=cut
222
223sub parse_body {
224 my $self = shift;
225
226 my $index = index( $self->{buffer}, $self->delimiter_begin );
227
228 if ( $index < 0 ) {
229
230 # make sure we have enough buffer to detect end delimiter
231 my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 );
232
233 unless ( $length > 0 ) {
234 return 0;
235 }
236
237 $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' );
238 $self->{part}->{size} += $length;
239 $self->{part}->{done} = 0;
240
241 $self->handler( $self->{part} );
242
243 return 0;
244 }
245
246 $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' );
247 $self->{part}->{size} += $index;
248 $self->{part}->{done} = 1;
249
250 $self->handler( $self->{part} );
251
252 $self->{state} = 'boundary';
253
254 return 1;
255}
256
257=item handler
258
259=cut
260
26118µs12µsour $basename_regexp = qr/[^.]+(\.[^\\\/]+)$/;
# spent 2µs making 1 call to HTTP::Body::MultiPart::CORE:qr
262#our $basename_regexp = qr/(\.\w+(?:\.\w+)*)$/;
263
264sub handler {
265 my ( $self, $part ) = @_;
266
267 unless ( exists $part->{name} ) {
268
269 my $disposition = $part->{headers}->{'Content-Disposition'};
270 my ($name) = $disposition =~ / name="?([^\";]+)"?/;
271 my ($filename) = $disposition =~ / filename="?([^\"]*)"?/;
272 # Need to match empty filenames above, so this part is flagged as an upload type
273
274 $part->{name} = $name;
275
276 if ( defined $filename ) {
277 $part->{filename} = $filename;
278
279 if ( $filename ne "" ) {
280 my $basename = (File::Spec->splitpath($filename))[2];
281 my $suffix = $basename =~ $basename_regexp ? $1 : q{};
282
283 my $fh = File::Temp->new( UNLINK => 0, DIR => $self->tmpdir, SUFFIX => $suffix );
284
285 $part->{fh} = $fh;
286 $part->{tempname} = $fh->filename;
287 }
288 }
289 }
290
291 if ( $part->{fh} && ( my $length = length( $part->{data} ) ) ) {
292 $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length );
293 }
294
295 if ( $part->{done} ) {
296
297 if ( exists $part->{filename} ) {
298 if ( $part->{filename} ne "" ) {
299 $part->{fh}->close if defined $part->{fh};
300
301 delete @{$part}{qw[ data done fh ]};
302
303 $self->upload( $part->{name}, $part );
304 }
305 }
306 else {
307 $self->param( $part->{name}, $part->{data} );
308 }
309 }
310}
311
312=back
313
314=head1 AUTHOR
315
316Christian Hansen, C<ch@ngmedia.com>
317
318=head1 LICENSE
319
320This library is free software . You can redistribute it and/or modify
321it under the same terms as perl itself.
322
323=cut
324
32513µs1;
 
# spent 2µs within HTTP::Body::MultiPart::CORE:qr which was called: # once (2µs+0s) by Plack::Request::BEGIN@10 at line 261
sub HTTP::Body::MultiPart::CORE:qr; # opcode