| 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 | HTTP::Body::MultiPart::BEGIN@11 |
| 1 | 1 | 1 | 10µs | 123µs | HTTP::Body::MultiPart::BEGIN@10 |
| 1 | 1 | 1 | 10µs | 20µs | HTTP::Body::MultiPart::BEGIN@6 |
| 1 | 1 | 1 | 6µs | 61µs | HTTP::Body::MultiPart::BEGIN@7 |
| 1 | 1 | 1 | 6µs | 6µs | HTTP::Body::MultiPart::BEGIN@12 |
| 1 | 1 | 1 | 6µs | 6µs | HTTP::Body::MultiPart::BEGIN@8 |
| 1 | 1 | 1 | 2µs | 2µs | HTTP::Body::MultiPart::CORE:qr (opcode) |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::boundary |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::boundary_begin |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::boundary_end |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::crlf |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::delimiter_begin |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::delimiter_end |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::handler |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::init |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::parse_body |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::parse_boundary |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::parse_header |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::parse_preamble |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::MultiPart::spin |
| 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 |