lib/HTTP/Body/Multipart.pm

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