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 =head1 NAME
  10
  11 HTTP::Body::Multipart - HTTP Body MultipartParser
  12
  13 =head1 SYNOPSIS
  14
  15     use HTTP::Body::Multipart;
  16
  17 =head1 DESCRIPTION
  18
  19 HTTP Body Multipart Parser.
  20
  21 =head1 METHODS
  22
  23 =over 4
  24
  25 =item init
  26
  27 =cut
  28
  29 sub init {
  30     my $self = shift;
  31
  32     unless ( $self->content_type =~ /boundary=\"?([^\";,]+)\"?/ ) {
  33         my $content_type = $self->content_type;
  34         Carp::croak("Invalid boundary in content_type: '$content_type'");
  35     }
  36
  37     $self->{boundary} = $1;
  38     $self->{state}    = 'preamble';
  39
  40     return $self;
  41 }
  42
  43 =item spin
  44
  45 =cut
  46
  47 sub spin {
  48     my $self = shift;
  49
  50     while (1) {
  51
  52         if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) {
  53             my $method = "parse_$1";
  54             return unless $self->$method;
  55         }
  56
  57         else {
  58             Carp::croak('Unknown state');
  59         }
  60     }
  61 }
  62
  63 =item boundary
  64
  65 =cut
  66
  67 sub boundary {
  68     return shift->{boundary};
  69 }
  70
  71 =item boundary_begin
  72
  73 =cut
  74
  75 sub boundary_begin {
  76     return "--" . shift->boundary;
  77 }
  78
  79 =item boundary_end
  80
  81 =cut
  82
  83 sub boundary_end {
  84     return shift->boundary_begin . "--";
  85 }
  86
  87 =item crlf
  88
  89 =cut
  90
  91 sub crlf {
  92     return "\x0d\x0a";
  93 }
  94
  95 =item delimiter_begin
  96
  97 =cut
  98
  99 sub delimiter_begin {
 100     my $self = shift;
 101     return $self->crlf . $self->boundary_begin;
 102 }
 103
 104 =item delimiter_end
 105
 106 =cut
 107
 108 sub delimiter_end {
 109     my $self = shift;
 110     return $self->crlf . $self->boundary_end;
 111 }
 112
 113 =item parse_preamble
 114
 115 =cut
 116
 117 sub parse_preamble {
 118     my $self = shift;
 119
 120     my $index = index( $self->{buffer}, $self->boundary_begin );
 121
 122     unless ( $index >= 0 ) {
 123         return 0;
 124     }
 125
 126     # replace preamble with CRLF so we can match dash-boundary as delimiter
 127     substr( $self->{buffer}, 0, $index, $self->crlf );
 128
 129     $self->{state} = 'boundary';
 130
 131     return 1;
 132 }
 133
 134 =item parse_boundary
 135
 136 =cut
 137
 138 sub parse_boundary {
 139     my $self = shift;
 140
 141     if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) {
 142
 143         substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' );
 144         $self->{part}  = {};
 145         $self->{state} = 'header';
 146
 147         return 1;
 148     }
 149
 150     if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) {
 151
 152         substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' );
 153         $self->{part}  = {};
 154         $self->{state} = 'done';
 155
 156         return 0;
 157     }
 158
 159     return 0;
 160 }
 161
 162 =item parse_header
 163
 164 =cut
 165
 166 sub parse_header {
 167     my $self = shift;
 168
 169     my $crlf  = $self->crlf;
 170     my $index = index( $self->{buffer}, $crlf . $crlf );
 171
 172     unless ( $index >= 0 ) {
 173         return 0;
 174     }
 175
 176     my $header = substr( $self->{buffer}, 0, $index );
 177
 178     substr( $self->{buffer}, 0, $index + 4, '' );
 179
 180     my @headers;
 181     for ( split /$crlf/, $header ) {
 182         if (s/^[ \t]+//) {
 183             $headers[-1] .= $_;
 184         }
 185         else {
 186             push @headers, $_;
 187         }
 188     }
 189
 190     my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
 191
 192     for my $header (@headers) {
 193
 194         $header =~ s/^($token):[\t ]*//;
 195
 196         ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg;
 197
 198         if ( exists $self->{part}->{headers}->{$field} ) {
 199             for ( $self->{part}->{headers}->{$field} ) {
 200                 $_ = [$_] unless ref($_) eq "ARRAY";
 201                 push( @$_, $header );
 202             }
 203         }
 204         else {
 205             $self->{part}->{headers}->{$field} = $header;
 206         }
 207     }
 208
 209     $self->{state} = 'body';
 210
 211     return 1;
 212 }
 213
 214 =item parse_body
 215
 216 =cut
 217
 218 sub parse_body {
 219     my $self = shift;
 220
 221     my $index = index( $self->{buffer}, $self->delimiter_begin );
 222
 223     if ( $index < 0 ) {
 224
 225         # make sure we have enough buffer to detect end delimiter
 226         my $length =
 227           length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 );
 228
 229         unless ( $length > 0 ) {
 230             return 0;
 231         }
 232
 233         $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' );
 234         $self->{part}->{size} += $length;
 235         $self->{part}->{done} = 0;
 236
 237         $self->handler( $self->{part} );
 238
 239         return 0;
 240     }
 241
 242     $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' );
 243     $self->{part}->{size} += $index;
 244     $self->{part}->{done} = 1;
 245
 246     $self->handler( $self->{part} );
 247
 248     $self->{state} = 'boundary';
 249
 250     return 1;
 251 }
 252
 253 =item handler
 254
 255 =cut
 256
 257 sub handler {
 258     my ( $self, $part ) = @_;
 259
 260     # skip parts without content
 261     if ( $part->{done} && $part->{size} == 0 ) {
 262         return 0;
 263     }
 264
 265     unless ( $self->{seen}->{"$part"}++ ) {
 266
 267         my $disposition = $part->{headers}->{'Content-Disposition'};
 268         my ($name)     = $disposition =~ / name="?([^\";]+)"?/;
 269         my ($filename) = $disposition =~ / filename="?([^\"]+)"?/;
 270
 271         $part->{name}     = $name;
 272         $part->{filename} = $filename;
 273
 274         if ($filename) {
 275
 276             my $fh = File::Temp->new( UNLINK => 0 );
 277
 278             $part->{fh}       = $fh;
 279             $part->{tempname} = $fh->filename;
 280         }
 281     }
 282
 283     if ( $part->{filename} && ( my $length = length( $part->{data} ) ) ) {
 284         $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length );
 285     }
 286
 287     if ( $part->{done} ) {
 288
 289         if ( $part->{filename} ) {
 290
 291             $part->{fh}->close;
 292
 293             delete @{$part}{qw[ data done fh ]};
 294
 295             $self->upload( $part->{name}, $part );
 296         }
 297
 298         else {
 299             $self->param( $part->{name}, $part->{data} );
 300         }
 301     }
 302 }
 303
 304 =back
 305
 306 =head1 AUTHOR
 307
 308 Christian Hansen, C<ch@ngmedia.com>
 309
 310 =head1 LICENSE
 311
 312 This library is free software . You can redistribute it and/or modify
 313 it under the same terms as perl itself.
 314
 315 =cut
 316
 317 1;