1 package HTTP::Body::MultiPart;
13 HTTP::Body::MultiPart - HTTP Body Multipart Parser
17 use HTTP::Body::Multipart;
21 HTTP Body Multipart Parser.
34 unless ( $self->content_type =~ /boundary=\"?([^\";]+)\"?/ ) {
35 my $content_type = $self->content_type;
36 Carp::croak("Invalid boundary in content_type: '$content_type'");
39 $self->{boundary} = $1;
40 $self->{state} = 'preamble';
54 if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) {
55 my $method = "parse_$1";
56 return unless $self->$method;
60 Carp::croak('Unknown state');
70 return shift->{boundary};
78 return "--" . shift->boundary;
86 return shift->boundary_begin . "--";
101 sub delimiter_begin {
103 return $self->crlf . $self->boundary_begin;
112 return $self->crlf . $self->boundary_end;
122 my $index = index( $self->{buffer}, $self->boundary_begin );
124 unless ( $index >= 0 ) {
128 # replace preamble with CRLF so we can match dash-boundary as delimiter
129 substr( $self->{buffer}, 0, $index, $self->crlf );
131 $self->{state} = 'boundary';
143 if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) {
145 substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' );
147 $self->{state} = 'header';
152 if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) {
154 substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' );
156 $self->{state} = 'done';
171 my $crlf = $self->crlf;
172 my $index = index( $self->{buffer}, $crlf . $crlf );
174 unless ( $index >= 0 ) {
178 my $header = substr( $self->{buffer}, 0, $index );
180 substr( $self->{buffer}, 0, $index + 4, '' );
183 for ( split /$crlf/, $header ) {
192 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
194 for my $header (@headers) {
196 $header =~ s/^($token):[\t ]*//;
198 ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg;
200 if ( exists $self->{part}->{headers}->{$field} ) {
201 for ( $self->{part}->{headers}->{$field} ) {
202 $_ = [$_] unless ref($_) eq "ARRAY";
203 push( @$_, $header );
207 $self->{part}->{headers}->{$field} = $header;
211 $self->{state} = 'body';
223 my $index = index( $self->{buffer}, $self->delimiter_begin );
227 # make sure we have enough buffer to detect end delimiter
228 my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 );
230 unless ( $length > 0 ) {
234 $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' );
235 $self->{part}->{size} += $length;
236 $self->{part}->{done} = 0;
238 $self->handler( $self->{part} );
243 $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' );
244 $self->{part}->{size} += $index;
245 $self->{part}->{done} = 1;
247 $self->handler( $self->{part} );
249 $self->{state} = 'boundary';
258 our $basename_regexp = qr/[^.]+(\.[^\\\/]+)$/;
259 #our $basename_regexp = qr/(\.\w+(?:\.\w+)*)$/;
262 my ( $self, $part ) = @_;
264 unless ( exists $part->{name} ) {
266 my $disposition = $part->{headers}->{'Content-Disposition'};
267 my ($name) = $disposition =~ / name="?([^\";]+)"?/;
268 my ($filename) = $disposition =~ / filename="?([^\"]*)"?/;
269 # Need to match empty filenames above, so this part is flagged as an upload type
271 $part->{name} = $name;
273 if ( defined $filename ) {
274 $part->{filename} = $filename;
276 if ( $filename ne "" ) {
277 my $basename = (File::Spec->splitpath($filename))[2];
278 my $suffix = $basename =~ $basename_regexp ? $1 : q{};
280 my $fh = File::Temp->new( UNLINK => 0, DIR => $self->tmpdir, SUFFIX => $suffix );
283 $part->{tempname} = $fh->filename;
288 if ( $part->{fh} && ( my $length = length( $part->{data} ) ) ) {
289 $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length );
292 if ( $part->{done} ) {
294 if ( exists $part->{filename} ) {
295 if ( $part->{filename} ne "" ) {
296 $part->{fh}->close if defined $part->{fh};
298 delete @{$part}{qw[ data done fh ]};
300 $self->upload( $part->{name}, $part );
303 # If we have more than the content-disposition, we need to create a
304 # data key so that we don't waste the headers.
306 $self->param( $part->{name}, $part->{data} );
307 $self->part_data( $part->{name}, $part )
316 Christian Hansen, C<ch@ngmedia.com>
320 This library is free software . You can redistribute it and/or modify
321 it under the same terms as perl itself.