1package HTTP::Body::MultiPart; 2$HTTP::Body::MultiPart::VERSION = '1.22'; 3use strict; 4use base 'HTTP::Body'; 5use bytes; 6 7use IO::File; 8use File::Temp 0.14; 9use File::Spec; 10 11=head1 NAME 12 13HTTP::Body::MultiPart - HTTP Body Multipart Parser 14 15=head1 SYNOPSIS 16 17 use HTTP::Body::Multipart; 18 19=head1 DESCRIPTION 20 21HTTP Body Multipart Parser. 22 23=head1 METHODS 24 25=over 4 26 27=item init 28 29=cut 30 31sub 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 49sub 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 69sub boundary { 70 return shift->{boundary}; 71} 72 73=item boundary_begin 74 75=cut 76 77sub boundary_begin { 78 return "--" . shift->boundary; 79} 80 81=item boundary_end 82 83=cut 84 85sub boundary_end { 86 return shift->boundary_begin . "--"; 87} 88 89=item crlf 90 91=cut 92 93sub crlf () { 94 return "\x0d\x0a"; 95} 96 97=item delimiter_begin 98 99=cut 100 101sub delimiter_begin { 102 my $self = shift; 103 return $self->crlf . $self->boundary_begin; 104} 105 106=item delimiter_end 107 108=cut 109 110sub delimiter_end { 111 my $self = shift; 112 return $self->crlf . $self->boundary_end; 113} 114 115=item parse_preamble 116 117=cut 118 119sub 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 140sub 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 168sub 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 220sub 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 258our $basename_regexp = qr/[^.]+(\.[^\\\/]+)$/; 259#our $basename_regexp = qr/(\.\w+(?:\.\w+)*)$/; 260 261sub handler { 262 my ( $self, $part ) = @_; 263 264 unless ( exists $part->{name} ) { 265 266 my $disposition = $part->{headers}->{'Content-Disposition'}; 267 my ($name) = $disposition =~ / name="?([^\";]+)"?/; 268 my ($filename) = $disposition =~ / filename="?([^\"]*)"?/; 269 # Need to match empty filenames above, so this part is flagged as an upload type 270 271 $part->{name} = $name; 272 273 if ( defined $filename ) { 274 $part->{filename} = $filename; 275 276 if ( $filename ne "" ) { 277 my $basename = (File::Spec->splitpath($filename))[2]; 278 my $suffix = $basename =~ $basename_regexp ? $1 : q{}; 279 280 my $fh = File::Temp->new( UNLINK => 0, DIR => $self->tmpdir, SUFFIX => $suffix ); 281 282 $part->{fh} = $fh; 283 $part->{tempname} = $fh->filename; 284 } 285 } 286 } 287 288 if ( $part->{fh} && ( my $length = length( $part->{data} ) ) ) { 289 $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length ); 290 } 291 292 if ( $part->{done} ) { 293 294 if ( exists $part->{filename} ) { 295 if ( $part->{filename} ne "" ) { 296 $part->{fh}->close if defined $part->{fh}; 297 298 delete @{$part}{qw[ data done fh ]}; 299 300 $self->upload( $part->{name}, $part ); 301 } 302 } 303 # If we have more than the content-disposition, we need to create a 304 # data key so that we don't waste the headers. 305 else { 306 $self->param( $part->{name}, $part->{data} ); 307 $self->part_data( $part->{name}, $part ) 308 } 309 } 310} 311 312=back 313 314=head1 AUTHOR 315 316Christian Hansen, C<ch@ngmedia.com> 317 318=head1 LICENSE 319 320This library is free software . You can redistribute it and/or modify 321it under the same terms as perl itself. 322 323=cut 324 3251; 326