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