lib/HTTP/Body/Parser/MultiPart.pm

   1 package HTTP::Body::Parser::MultiPart;
   2
   3 use strict;
   4 use bytes;
   5 use base 'HTTP::Body::Parser';
   6
   7 use Carp       qw[];
   8 use Errno      qw[];
   9 use File::Temp qw[];
  10
  11 __PACKAGE__->mk_accessors( qw[ boundary status state ] );
  12
  13 sub initialize {
  14     my ( $self, $params ) = @_;
  15
  16     my $content_type = $params->{context}->header('Content-Type');
  17
  18     unless ( $content_type =~ /boundary=\"?([^\";,]+)\"?/ ) {
  19         Carp::croak qq/Invalid boundary in content_type: '$content_type'/;
  20     }
  21
  22     $params->{boundary} = $1;
  23     $params->{state}    = 'preamble';
  24
  25     return $self->SUPER::initialize($params);
  26 }
  27
  28 sub parse {
  29     my $self = shift;
  30
  31     return if $self->state eq 'done';
  32
  33     while (1) {
  34
  35         if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) {
  36             my $method = "parse_$1";
  37             return unless $self->$method;
  38         }
  39
  40         else {
  41             Carp::croak qq/Unknown state: '$self->{state}'/;
  42         }
  43     }
  44 }
  45
  46 sub boundary_begin {
  47     return "--" . $_[0]->boundary;
  48 }
  49
  50 sub boundary_end {
  51     return $_[0]->boundary_begin . "--";
  52 }
  53
  54 sub crlf {
  55     return "\x0d\x0a";
  56 }
  57
  58 sub delimiter_begin {
  59     return $_[0]->crlf . $_[0]->boundary_begin;
  60 }
  61
  62 sub delimiter_end {
  63     return $_[0]->crlf . $_[0]->boundary_end;
  64 }
  65
  66 sub parse_preamble {
  67     my $self = shift;
  68
  69     my $index = index( $self->{buffer}, $self->boundary_begin );
  70
  71     unless ( $index >= 0 ) {
  72         return 0;
  73     }
  74
  75     # replace preamble with CRLF so we can match dash-boundary as delimiter
  76     substr( $self->{buffer}, 0, $index, $self->crlf );
  77
  78     $self->{state} = 'boundary';
  79
  80     return 1;
  81 }
  82
  83 sub parse_boundary {
  84     my $self = shift;
  85
  86     if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) {
  87
  88         substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' );
  89         $self->{part}  = {};
  90         $self->{state} = 'header';
  91
  92         return 1;
  93     }
  94
  95     if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) {
  96
  97         substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' );
  98         $self->{part}  = {};
  99         $self->{state} = 'done';
 100
 101         return 0;
 102     }
 103
 104     return 0;
 105 }
 106
 107 sub parse_header {
 108     my $self = shift;
 109
 110     my $crlf  = $self->crlf;
 111     my $index = index( $self->{buffer}, $crlf . $crlf );
 112
 113     unless ( $index >= 0 ) {
 114         return 0;
 115     }
 116
 117     my $header = substr( $self->{buffer}, 0, $index );
 118
 119     substr( $self->{buffer}, 0, $index + 4, '' );
 120
 121     my @headers;
 122     for ( split /$crlf/, $header ) {
 123         if (s/^[ \t]+//) {
 124             $headers[-1] .= $_;
 125         }
 126         else {
 127             push @headers, $_;
 128         }
 129     }
 130
 131     my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
 132
 133     for my $header (@headers) {
 134
 135         $header =~ s/^($token):[\t ]*//;
 136
 137         ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg;
 138
 139         if ( exists $self->{part}->{headers}->{$field} ) {
 140             for ( $self->{part}->{headers}->{$field} ) {
 141                 $_ = [$_] unless ref($_) eq "ARRAY";
 142                 push( @$_, $header );
 143             }
 144         }
 145         else {
 146             $self->{part}->{headers}->{$field} = $header;
 147         }
 148     }
 149
 150     $self->{state} = 'body';
 151
 152     return 1;
 153 }
 154
 155 sub parse_body {
 156     my $self = shift;
 157
 158     my $index = index( $self->{buffer}, $self->delimiter_begin );
 159
 160     if ( $index < 0 ) {
 161
 162         # make sure we have enough buffer to detect end delimiter
 163         my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 );
 164
 165         unless ( $length > 0 ) {
 166             return 0;
 167         }
 168
 169         $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' );
 170         $self->{part}->{size} += $length;
 171         $self->{part}->{done} = 0;
 172
 173         $self->handler( $self->{part} );
 174
 175         return 0;
 176     }
 177
 178     $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' );
 179     $self->{part}->{size} += $index;
 180     $self->{part}->{done} = 1;
 181
 182     $self->handler( $self->{part} );
 183
 184     $self->{state} = 'boundary';
 185
 186     return 1;
 187 }
 188
 189 sub handler {
 190     my ( $self, $part ) = @_;
 191
 192     # skip parts without content
 193     if ( $part->{done} && $part->{size} == 0 ) {
 194         return 0;
 195     }
 196
 197     unless ( exists $part->{name} ) {
 198
 199         my $disposition = $part->{headers}->{'Content-Disposition'};
 200         my ($name)     = $disposition =~ / name="?([^\";]+)"?/;
 201         my ($filename) = $disposition =~ / filename="?([^\"]+)"?/;
 202
 203         $part->{name}     = $name;
 204         $part->{filename} = $filename;
 205
 206         if ($filename) {
 207
 208             my $fh = File::Temp->new( UNLINK => 0 );
 209
 210             $part->{fh}       = $fh;
 211             $part->{tempname} = $fh->filename;
 212         }
 213     }
 214
 215     if ( $part->{filename} && length $part->{data} ) {
 216
 217         if ( $part->{done} || length $part->{data} >= $self->bufsize ) {
 218
 219             my ( $r, $w, $s ) = ( length $part->{data}, 0, 0 );
 220
 221             for ( $w = 0; $w < $r; $w += $s || 0 ) {
 222
 223                 $s = $part->{fh}->syswrite( $part->{data}, $r - $w, $w );
 224
 225                 Carp::croak qq/Failed to syswrite buffer to temporary file. Reason: $!./
 226                   unless defined $s || $! == Errno::EINTR;
 227             }
 228
 229             $part->{data} = '';
 230         }
 231     }
 232
 233     if ( $part->{done} ) {
 234
 235         if ( $part->{filename} ) {
 236
 237             $part->{fh}->close;
 238
 239             delete @{ $part }{qw[ data done fh ]};
 240
 241             $self->context->upload->add( $part->{name} => $part );
 242         }
 243
 244         else {
 245             $self->context->param->add( $part->{name} => $part->{data} );
 246         }
 247     }
 248 }
 249
 250 1;