Profile of HTTP/Body/MultiPart.pm

← 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
Statements | Executed 17 statements in 1.11ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 14µs | 83µs | HTTP::Body::MultiPart::::BEGIN@11HTTP::Body::MultiPart::BEGIN@11
1 | 1 | 1 | 10µs | 123µs | HTTP::Body::MultiPart::::BEGIN@10HTTP::Body::MultiPart::BEGIN@10
1 | 1 | 1 | 10µs | 20µs | HTTP::Body::MultiPart::::BEGIN@6HTTP::Body::MultiPart::BEGIN@6
1 | 1 | 1 | 6µs | 61µs | HTTP::Body::MultiPart::::BEGIN@7HTTP::Body::MultiPart::BEGIN@7
1 | 1 | 1 | 6µs | 6µs | HTTP::Body::MultiPart::::BEGIN@12HTTP::Body::MultiPart::BEGIN@12
1 | 1 | 1 | 6µs | 6µs | HTTP::Body::MultiPart::::BEGIN@8HTTP::Body::MultiPart::BEGIN@8
1 | 1 | 1 | 2µs | 2µs | HTTP::Body::MultiPart::::CORE:qrHTTP::Body::MultiPart::CORE:qr (opcode)
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::boundaryHTTP::Body::MultiPart::boundary
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::boundary_beginHTTP::Body::MultiPart::boundary_begin
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::boundary_endHTTP::Body::MultiPart::boundary_end
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::crlfHTTP::Body::MultiPart::crlf
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::delimiter_beginHTTP::Body::MultiPart::delimiter_begin
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::delimiter_endHTTP::Body::MultiPart::delimiter_end
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::handlerHTTP::Body::MultiPart::handler
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::initHTTP::Body::MultiPart::init
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::parse_bodyHTTP::Body::MultiPart::parse_body
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::parse_boundaryHTTP::Body::MultiPart::parse_boundary
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::parse_headerHTTP::Body::MultiPart::parse_header
0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::::parse_preambleHTTP::Body::MultiPart::parse_preamble
0 | 0 | 0 | 0s | 0s | HTTP::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
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package HTTP::Body::MultiPart;
2 |  |  |  |  | {
3 | 2 | 900ns |  |  | $HTTP::Body::MultiPart::VERSION = '1.19';
4 |  |  |  |  | }
5 |  |  |  |  |
6 | 2 | 23µs | 2 | 31µ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
7 | 2 | 22µs | 2 | 116µ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
8 | 2 | 18µs | 2 | 7µ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 |  |  |  |  |
10 | 2 | 27µs | 2 | 236µ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
11 | 3 | 38µs | 3 | 152µ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
12 | 2 | 974µs | 1 | 6µ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 |  |  |  |  |
16 |  |  |  |  | HTTP::Body::MultiPart - HTTP Body Multipart Parser
17 |  |  |  |  |
18 |  |  |  |  | =head1 SYNOPSIS
19 |  |  |  |  |
20 |  |  |  |  | use HTTP::Body::Multipart;
21 |  |  |  |  |
22 |  |  |  |  | =head1 DESCRIPTION
23 |  |  |  |  |
24 |  |  |  |  | HTTP Body Multipart Parser.
25 |  |  |  |  |
26 |  |  |  |  | =head1 METHODS
27 |  |  |  |  |
28 |  |  |  |  | =over 4
29 |  |  |  |  |
30 |  |  |  |  | =item init
31 |  |  |  |  |
32 |  |  |  |  | =cut
33 |  |  |  |  |
34 |  |  |  |  | sub 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 |  |  |  |  |
52 |  |  |  |  | sub 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 |  |  |  |  |
72 |  |  |  |  | sub boundary {
73 |  |  |  |  | return shift->{boundary};
74 |  |  |  |  | }
75 |  |  |  |  |
76 |  |  |  |  | =item boundary_begin
77 |  |  |  |  |
78 |  |  |  |  | =cut
79 |  |  |  |  |
80 |  |  |  |  | sub boundary_begin {
81 |  |  |  |  | return "--" . shift->boundary;
82 |  |  |  |  | }
83 |  |  |  |  |
84 |  |  |  |  | =item boundary_end
85 |  |  |  |  |
86 |  |  |  |  | =cut
87 |  |  |  |  |
88 |  |  |  |  | sub boundary_end {
89 |  |  |  |  | return shift->boundary_begin . "--";
90 |  |  |  |  | }
91 |  |  |  |  |
92 |  |  |  |  | =item crlf
93 |  |  |  |  |
94 |  |  |  |  | =cut
95 |  |  |  |  |
96 |  |  |  |  | sub crlf () {
97 |  |  |  |  | return "\x0d\x0a";
98 |  |  |  |  | }
99 |  |  |  |  |
100 |  |  |  |  | =item delimiter_begin
101 |  |  |  |  |
102 |  |  |  |  | =cut
103 |  |  |  |  |
104 |  |  |  |  | sub delimiter_begin {
105 |  |  |  |  | my $self = shift;
106 |  |  |  |  | return $self->crlf . $self->boundary_begin;
107 |  |  |  |  | }
108 |  |  |  |  |
109 |  |  |  |  | =item delimiter_end
110 |  |  |  |  |
111 |  |  |  |  | =cut
112 |  |  |  |  |
113 |  |  |  |  | sub delimiter_end {
114 |  |  |  |  | my $self = shift;
115 |  |  |  |  | return $self->crlf . $self->boundary_end;
116 |  |  |  |  | }
117 |  |  |  |  |
118 |  |  |  |  | =item parse_preamble
119 |  |  |  |  |
120 |  |  |  |  | =cut
121 |  |  |  |  |
122 |  |  |  |  | sub 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 |  |  |  |  |
143 |  |  |  |  | sub 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 |  |  |  |  |
171 |  |  |  |  | sub 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 |  |  |  |  |
223 |  |  |  |  | sub 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 |  |  |  |  |
261 | 1 | 8µs | 1 | 2µs | our $basename_regexp = qr/[^.]+(\.[^\\\/]+)$/; # spent 2µs making 1 call to HTTP::Body::MultiPart::CORE:qr
262 |  |  |  |  | #our $basename_regexp = qr/(\.\w+(?:\.\w+)*)$/;
263 |  |  |  |  |
264 |  |  |  |  | sub 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 |  |  |  |  |
316 |  |  |  |  | Christian Hansen, C<ch@ngmedia.com>
317 |  |  |  |  |
318 |  |  |  |  | =head1 LICENSE
319 |  |  |  |  |
320 |  |  |  |  | This library is free software . You can redistribute it and/or modify
321 |  |  |  |  | it under the same terms as perl itself.
322 |  |  |  |  |
323 |  |  |  |  | =cut
324 |  |  |  |  |
325 | 1 | 3µs |  |  | 1;
|  |  |  |  | # 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