255 lines
7.5 KiB
Perl
255 lines
7.5 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::CGI::MultiPart
|
|
# CVS Info :
|
|
# $Id: MultiPart.pm,v 1.5 2004/01/13 01:35:16 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Multipart form handling for GT::CGI objects.
|
|
#
|
|
# This is taken almost entirely from CGI.pm, and is loaded on demand.
|
|
#
|
|
|
|
package GT::CGI::MultiPart;
|
|
# ==============================================================================
|
|
use strict 'vars', 'subs';
|
|
use GT::CGI;
|
|
use GT::Base;
|
|
use GT::TempFile();
|
|
use vars qw/$DEBUG $ERRORS @ISA $ATTRIBS $CRLF/;
|
|
|
|
@ISA = qw/GT::Base/;
|
|
use constants
|
|
BLOCK_SIZE => 4096,
|
|
MAX_READS => 2000;
|
|
$CRLF = "\015\012";
|
|
$ATTRIBS = {
|
|
fh => undef, # web request on stdin
|
|
buffer => '', # buffer to hold tmp data
|
|
length => 0, # length of file to parse
|
|
boundary => undef, # mime boundary to look for
|
|
fillunit => BLOCK_SIZE, # amount to read per chunk
|
|
safety => 0 # safety counter
|
|
};
|
|
$ERRORS = {
|
|
NOBOUNDARY => "Unable to find a MIME boundary in environment. Content-type looks like: %s",
|
|
CLIENTABORT => "Unable to read data from server. Still have %s bytes to read, but got 0. Data in buffer is: %s",
|
|
BADMULTIPART => "Invalid multipart message. Nothing left to read, and can't find closing boundary. Data in buffer is: %s"
|
|
};
|
|
|
|
sub parse {
|
|
# -------------------------------------------------------------------
|
|
# Parses a multipart form to handle file uploads.
|
|
#
|
|
my ($class, $cgi) = @_;
|
|
|
|
# We override any fatal handlers as our handlers typically create a CGI object
|
|
# avoiding a nasty loop.
|
|
local $SIG{__DIE__} = 'DEFAULT';
|
|
|
|
# We only load the multipart parser if we have multipart code.
|
|
my $parser = $class->new or return;
|
|
|
|
my ($header, $name, $value, $filename);
|
|
until ($parser->eof) {
|
|
$header = $parser->read_header or return die "BADREQUEST";
|
|
$header->{'Content-Disposition'} =~ m/ name=(?:"([^"]*)"|((?!")[^;]*))/;
|
|
$name = $1 || $2;
|
|
($filename) = $header->{'Content-Disposition'} =~ m/ filename="?([^\";]*)"?/;
|
|
|
|
# Not a file, just regular form data.
|
|
if (! defined $filename or $filename eq '') {
|
|
$value = $parser->read_body;
|
|
|
|
# Netscape 6 does some fun things with line feeds in multipart form data
|
|
$value =~ s/\r\r/\r/g; # What it does on unix
|
|
$value =~ s/\r\n/\n/g if $^O eq 'MSWin32';
|
|
unless ($cgi->{params}->{$name}) {
|
|
push @{$cgi->{param_order}}, $name;
|
|
}
|
|
unshift @{$cgi->{params}->{$name}}, $value;
|
|
next;
|
|
}
|
|
|
|
# Print out the data to a temp file.
|
|
local $\;
|
|
my $tmp_file = new GT::TempFile;
|
|
require GT::CGI::Fh;
|
|
my $fh = GT::CGI::Fh->new($filename, $$tmp_file, 0);
|
|
binmode $fh;
|
|
my $data;
|
|
while (defined($data = $parser->read)) {
|
|
print $fh $data;
|
|
}
|
|
seek $fh, 0, 0;
|
|
unless ($cgi->{params}->{$name}) {
|
|
push @{$cgi->{param_order}}, $name;
|
|
}
|
|
unshift @{$cgi->{params}->{$name}}, $fh;
|
|
}
|
|
}
|
|
|
|
sub init {
|
|
# -------------------------------------------------------------------
|
|
# Initilize our object.
|
|
#
|
|
$DEBUG = $GT::CGI::DEBUG;
|
|
|
|
my $self = shift;
|
|
|
|
# Get the boundary marker.
|
|
my $boundary;
|
|
if (defined $ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /boundary=\"?([^\";,]+)\"?/) {
|
|
$boundary = $1;
|
|
}
|
|
else {
|
|
return $self->error("NOBOUNDARY", "FATAL", $ENV{CONTENT_TYPE});
|
|
}
|
|
$self->{boundary} = "--$boundary";
|
|
|
|
# Get our filehandle.
|
|
binmode(STDIN);
|
|
|
|
# And if the boundary is > the BLOCK_SIZE, adjust.
|
|
if (length $boundary > $self->{fillunit}) {
|
|
$self->{fillunit} = length $boundary;
|
|
}
|
|
|
|
# Set the content-length.
|
|
$self->{length} = $ENV{CONTENT_LENGTH} || 0;
|
|
|
|
# Read the preamble and the topmost (boundary) line plus the CRLF.
|
|
while ($self->read) { }
|
|
}
|
|
|
|
sub fill_buffer {
|
|
# -------------------------------------------------------------------
|
|
# Fill buffer.
|
|
#
|
|
my ($self, $bytes) = @_;
|
|
|
|
return unless $self->{length};
|
|
|
|
my $boundary_length = length $self->{boundary};
|
|
my $buffer_length = length $self->{buffer};
|
|
my $bytes_to_read = $bytes - $buffer_length + $boundary_length + 2;
|
|
$bytes_to_read = $self->{length} if $self->{length} < $bytes_to_read;
|
|
|
|
my $bytes_read = read(STDIN, $self->{buffer}, $bytes_to_read, $buffer_length);
|
|
if (! defined $self->{buffer}) {
|
|
$self->{buffer} = '';
|
|
}
|
|
if ($bytes_read == 0) {
|
|
if ($self->{safety}++ > MAX_READS) {
|
|
return $self->error(CLIENTABORT => FATAL => $self->{length}, $self->{buffer});
|
|
}
|
|
}
|
|
else {
|
|
$self->{safety} = 0;
|
|
}
|
|
|
|
$self->{length} -= $bytes_read;
|
|
}
|
|
|
|
sub read {
|
|
# -------------------------------------------------------------------
|
|
# Read some input.
|
|
#
|
|
my $self = shift;
|
|
my $bytes = $self->{fillunit};
|
|
|
|
# Load up self->{buffer} with data.
|
|
$self->fill_buffer($bytes);
|
|
|
|
# find the boundary (if exists).
|
|
my $start = index($self->{buffer}, $self->{boundary});
|
|
|
|
# Make sure the post was formed properly.
|
|
unless (($start >= 0) or ($self->{length} > 0)) {
|
|
return $self->error(BADMULTIPART => FATAL => $self->{buffer});
|
|
}
|
|
|
|
if ($start == 0) {
|
|
# Quit if we found the last boundary at the beginning.
|
|
if (index($self->{buffer},"$self->{boundary}--") == 0) {
|
|
$self->{buffer} = '';
|
|
$self->{length} = 0;
|
|
return;
|
|
}
|
|
# Otherwise remove the boundary (+2 to remove line feeds).
|
|
substr($self->{buffer}, 0, length ($self->{boundary}) + 2) = '';
|
|
return;
|
|
}
|
|
|
|
my $bytes_to_return;
|
|
if ($start > 0) {
|
|
$bytes_to_return = $start > $bytes ? $bytes : $start;
|
|
}
|
|
else {
|
|
$bytes_to_return = $bytes - length($self->{boundary}) + 1;
|
|
}
|
|
|
|
my $return = substr($self->{buffer}, 0, $bytes_to_return);
|
|
substr($self->{buffer}, 0, $bytes_to_return) = '';
|
|
|
|
return $start > 0 ? substr($return, 0, -2) : $return;
|
|
}
|
|
|
|
sub read_header {
|
|
# -------------------------------------------------------------------
|
|
# Reads the header.
|
|
#
|
|
my $self = shift;
|
|
my ($ok, $bad, $end, $safety) = (0, 0);
|
|
until ($ok or $bad) {
|
|
$self->fill_buffer($self->{fillunit});
|
|
|
|
$ok++ if ($end = index($self->{buffer}, "$CRLF$CRLF")) >= 0;
|
|
$ok++ if $self->{buffer} eq '';
|
|
$bad++ if !$ok and $self->{length} <= 0;
|
|
return if $safety++ >= 10;
|
|
}
|
|
|
|
return if $bad;
|
|
|
|
my $header = substr($self->{buffer}, 0, $end + 2);
|
|
substr($self->{buffer}, 0, $end + 4) = '';
|
|
|
|
my %header;
|
|
my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
|
|
$header =~ s/$CRLF\s+/ /og;
|
|
while ($header =~ /($token+):\s+([^$CRLF]*)/go) {
|
|
my ($field_name,$field_value) = ($1,$2);
|
|
$field_name =~ s/\b(\w)/\u$1/g;
|
|
$header{$field_name} = $field_value;
|
|
}
|
|
return \%header;
|
|
}
|
|
|
|
sub read_body {
|
|
# -------------------------------------------------------------------
|
|
# Reads a body and returns as a single scalar value.
|
|
#
|
|
my $self = shift;
|
|
my $data = '';
|
|
my $return = '';
|
|
while (defined($data = $self->read)) {
|
|
$return .= $data;
|
|
}
|
|
return $return;
|
|
}
|
|
|
|
sub eof {
|
|
# -------------------------------------------------------------------
|
|
# Return true when we've finished reading.
|
|
#
|
|
my $self = shift;
|
|
return 1 if length $self->{buffer} == 0 and $self->{length} <= 0;
|
|
}
|
|
|
|
1;
|