1 package HTTP::Body::MultiPart;
12 HTTP::Body::MultiPart - HTTP Body Multipart Parser
16 use HTTP::Body::Multipart;
20 HTTP Body Multipart Parser.
33 unless ( $self->content_type =~ /boundary=\"?([^\";,]+)\"?/ ) {
34 my $content_type = $self->content_type;
35 Carp::croak("Invalid boundary in content_type: '$content_type'");
38 $self->{boundary} = $1;
39 $self->{state} = 'preamble';
53 if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) {
54 my $method = "parse_$1";
55 return unless $self->$method;
59 Carp::croak('Unknown state');
69 return shift->{boundary};
77 return "--" . shift->boundary;
85 return shift->boundary_begin . "--";
100 sub delimiter_begin {
102 return $self->crlf . $self->boundary_begin;
111 return $self->crlf . $self->boundary_end;
121 my $index = index( $self->{buffer}, $self->boundary_begin );
123 unless ( $index >= 0 ) {
127 # replace preamble with CRLF so we can match dash-boundary as delimiter
128 substr( $self->{buffer}, 0, $index, $self->crlf );
130 $self->{state} = 'boundary';
142 if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) {
144 substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' );
146 $self->{state} = 'header';
151 if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) {
153 substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' );
155 $self->{state} = 'done';
170 my $crlf = $self->crlf;
171 my $index = index( $self->{buffer}, $crlf . $crlf );
173 unless ( $index >= 0 ) {
177 my $header = substr( $self->{buffer}, 0, $index );
179 substr( $self->{buffer}, 0, $index + 4, '' );
182 for ( split /$crlf/, $header ) {
191 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
193 for my $header (@headers) {
195 $header =~ s/^($token):[\t ]*//;
197 ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg;
199 if ( exists $self->{part}->{headers}->{$field} ) {
200 for ( $self->{part}->{headers}->{$field} ) {
201 $_ = [$_] unless ref($_) eq "ARRAY";
202 push( @$_, $header );
206 $self->{part}->{headers}->{$field} = $header;
210 $self->{state} = 'body';
222 my $index = index( $self->{buffer}, $self->delimiter_begin );
226 # make sure we have enough buffer to detect end delimiter
227 my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 );
229 unless ( $length > 0 ) {
233 $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' );
234 $self->{part}->{size} += $length;
235 $self->{part}->{done} = 0;
237 $self->handler( $self->{part} );
242 $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' );
243 $self->{part}->{size} += $index;
244 $self->{part}->{done} = 1;
246 $self->handler( $self->{part} );
248 $self->{state} = 'boundary';
258 my ( $self, $part ) = @_;
260 unless ( exists $part->{name} ) {
262 my $disposition = $part->{headers}->{'Content-Disposition'};
263 my ($name) = $disposition =~ / name="?([^\";]+)"?/;
264 my ($filename) = $disposition =~ / filename="?([^\"]*)"?/;
265 # Need to match empty filenames above, so this part is flagged as an upload type
267 $part->{name} = $name;
269 if ( defined $filename ) {
270 $part->{filename} = $filename;
272 if ( $filename ne "" ) {
273 my $fh = File::Temp->new( UNLINK => 0 );
276 $part->{tempname} = $fh->filename;
281 if ( $part->{fh} && ( my $length = length( $part->{data} ) ) ) {
282 $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length );
285 if ( $part->{done} ) {
287 if ( exists $part->{filename} ) {
288 if ( $part->{filename} ne "" ) {
291 delete @{$part}{qw[ data done fh ]};
293 $self->upload( $part->{name}, $part );
297 $self->param( $part->{name}, $part->{data} );
306 Christian Hansen, C<ch@ngmedia.com>
310 This library is free software . You can redistribute it and/or modify
311 it under the same terms as perl itself.