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