1 package HTTP::Body::Parser::MultiPart;
5 use base 'HTTP::Body::Parser';
11 __PACKAGE__->mk_accessors( qw[ boundary status state ] );
14 my ( $self, $params ) = @_;
16 my $content_type = $params->{context}->header('Content-Type');
18 unless ( $content_type =~ /boundary=\"?([^\";,]+)\"?/ ) {
19 Carp::croak qq/Invalid boundary in content_type: '$content_type'/;
22 $params->{boundary} = $1;
23 $params->{state} = 'preamble';
25 return $self->SUPER::initialize($params);
31 return if $self->state eq 'done';
35 if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) {
36 my $method = "parse_$1";
37 return unless $self->$method;
41 Carp::croak qq/Unknown state: '$self->{state}'/;
47 return "--" . $_[0]->boundary;
51 return $_[0]->boundary_begin . "--";
59 return $_[0]->crlf . $_[0]->boundary_begin;
63 return $_[0]->crlf . $_[0]->boundary_end;
69 my $index = index( $self->{buffer}, $self->boundary_begin );
71 unless ( $index >= 0 ) {
75 # replace preamble with CRLF so we can match dash-boundary as delimiter
76 substr( $self->{buffer}, 0, $index, $self->crlf );
78 $self->{state} = 'boundary';
86 if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) {
88 substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' );
90 $self->{state} = 'header';
95 if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) {
97 substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' );
99 $self->{state} = 'done';
110 my $crlf = $self->crlf;
111 my $index = index( $self->{buffer}, $crlf . $crlf );
113 unless ( $index >= 0 ) {
117 my $header = substr( $self->{buffer}, 0, $index );
119 substr( $self->{buffer}, 0, $index + 4, '' );
122 for ( split /$crlf/, $header ) {
131 my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
133 for my $header (@headers) {
135 $header =~ s/^($token):[\t ]*//;
137 ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg;
139 if ( exists $self->{part}->{headers}->{$field} ) {
140 for ( $self->{part}->{headers}->{$field} ) {
141 $_ = [$_] unless ref($_) eq "ARRAY";
142 push( @$_, $header );
146 $self->{part}->{headers}->{$field} = $header;
150 $self->{state} = 'body';
158 my $index = index( $self->{buffer}, $self->delimiter_begin );
162 # make sure we have enough buffer to detect end delimiter
163 my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 );
165 unless ( $length > 0 ) {
169 $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' );
170 $self->{part}->{size} += $length;
171 $self->{part}->{done} = 0;
173 $self->handler( $self->{part} );
178 $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' );
179 $self->{part}->{size} += $index;
180 $self->{part}->{done} = 1;
182 $self->handler( $self->{part} );
184 $self->{state} = 'boundary';
190 my ( $self, $part ) = @_;
192 # skip parts without content
193 if ( $part->{done} && $part->{size} == 0 ) {
197 unless ( exists $part->{name} ) {
199 my $disposition = $part->{headers}->{'Content-Disposition'};
200 my ($name) = $disposition =~ / name="?([^\";]+)"?/;
201 my ($filename) = $disposition =~ / filename="?([^\"]+)"?/;
203 $part->{name} = $name;
204 $part->{filename} = $filename;
208 my $fh = File::Temp->new( UNLINK => 0 );
211 $part->{tempname} = $fh->filename;
215 if ( $part->{filename} && length $part->{data} ) {
217 if ( $part->{done} || length $part->{data} >= $self->bufsize ) {
219 my ( $r, $w, $s ) = ( length $part->{data}, 0, 0 );
221 for ( $w = 0; $w < $r; $w += $s || 0 ) {
223 $s = $part->{fh}->syswrite( $part->{data}, $r - $w, $w );
225 Carp::croak qq/Failed to syswrite buffer to temporary file. Reason: $!./
226 unless defined $s || $! == Errno::EINTR;
233 if ( $part->{done} ) {
235 if ( $part->{filename} ) {
239 delete @{ $part }{qw[ data done fh ]};
241 $self->context->upload->add( $part->{name} => $part );
245 $self->context->param->add( $part->{name} => $part->{data} );