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