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