Filename | /usr/local/share/perl/5.18.2/HTTP/Body/MultiPart.pm |
Statements | Executed 17 statements in 1.11ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 14µs | 83µs | BEGIN@11 | HTTP::Body::MultiPart::
1 | 1 | 1 | 10µs | 123µs | BEGIN@10 | HTTP::Body::MultiPart::
1 | 1 | 1 | 10µs | 20µs | BEGIN@6 | HTTP::Body::MultiPart::
1 | 1 | 1 | 6µs | 61µs | BEGIN@7 | HTTP::Body::MultiPart::
1 | 1 | 1 | 6µs | 6µs | BEGIN@12 | HTTP::Body::MultiPart::
1 | 1 | 1 | 6µs | 6µs | BEGIN@8 | HTTP::Body::MultiPart::
1 | 1 | 1 | 2µs | 2µs | CORE:qr (opcode) | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | boundary | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | boundary_begin | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | boundary_end | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | crlf | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | delimiter_begin | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | delimiter_end | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | handler | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | init | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | parse_body | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | parse_boundary | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | parse_header | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | parse_preamble | HTTP::Body::MultiPart::
0 | 0 | 0 | 0s | 0s | spin | HTTP::Body::MultiPart::
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 # 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 # 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 # 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 # 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 # 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 # 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 |