#!/usr/bin/perl
use strict;

BEGIN {
	unshift @INC, $1 if $0 =~ m!(.*)[/\\]!;
}

eval {
	my $in = process_buffer();

	print "Content-Type: text/html\n\n";
	print q~<form method="post" action="" enctype="multipart/form-data"><input type="file" name="file"><br><input type="submit" value="Upload"></form>~;

	if ($in->{file}) {
		(my $fn = $in->{file}) =~ s!^.*(\\|\/)!!; # get actual filename
		open FH, ">$fn";
		binmode FH;
		print FH $::multipart_data{$in->{file}};
		close FH;
		print "<p>File $in->{file} Uploaded!";
	}
};
print "content-type: text/html\n\n$@" if $@;


# process_buffer: Read the form data.
sub process_buffer {
	binmode STDIN;
	binmode STDOUT;
	binmode STDERR;
	my $buffer;
	if ($ENV{'REQUEST_METHOD'} =~ /^(GET|HEAD)$/) {
		$buffer = $ENV{'QUERY_STRING'};
	}
	elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
		if ((my $received = read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'})) != $ENV{'CONTENT_LENGTH'}) {
			die "Short read: wanted $ENV{'CONTENT_LENGTH'}, but unfortunately got $received";
		}
		if ($ENV{'CONTENT_TYPE'} =~ m|^multipart/form-data|) { # Begin multipart
			my ($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
			die "Couldn't find boundary. This is usually caused by a bug server-side." unless $boundary;
			$boundary = "--$boundary";
			my @buffer = ();
			for my $i (grep /^\s*Content-Disposition:/i, split /$boundary/, $buffer) {
				my @data = split("\r\n\r\n", substr($i, 0, length($i) - 2));
				my $headers = shift @data;
				my %header;
				while ($headers =~ /([-\w!\#$%&\'*+.^_\`|{}~]+):"?(.+)"?/xmgo) {
					my ($name, $value) = ($1, $2);
					$name =~ s/\b(\w)/\u$1/g;
					$header{$name} = $value;
				}
				my ($key) = $header{'Content-Disposition'} =~ / name="?([^\";]*)"?/;
				my $value = join "\r\n\r\n", @data;
				# POSSIBLE BUG ALERT: Netscape does not escape quotation marks in file names?
				my ($filename) = $header{'Content-Disposition'} =~ / filename="?([^\"]*)"?/;
				#$filename =~ s!\\!/!g;
				$filename =~ s~[^\w\d \-_:/\\\.]~~g;
				if ($filename) {
					$::multipart_data{$filename} = $value;
					push @buffer, "$key=$filename";
				}
				else {
					push @buffer, "$key=$value";
				}
			}
			$buffer = join ';', @buffer;
		} # End multipart
	}
	else {
	  	die "Unknown request method used: $ENV{'REQUEST_METHOD'}";
	}
	return format_buffer($buffer);
}

# format_buffer: Converts a standard buffer into a hash.
#                Syntax: format_buffer('key=value&key2=value2');
sub format_buffer {
	my $buffer = shift;
	my $temp;
	for my $pair ( split /[&;]/, $buffer ) {
		my ($name, $value) = split /=/, $pair;
		$name =~ tr/+/ /;
		$name =~ s/%([a-fA-F0-9]{2})/pack("c", hex($1))/eg;
		$value =~ tr/+/ /;
		$value =~ s/%([a-fA-F0-9]{2})/pack("c", hex($1))/eg;
		if (exists $temp->{$name}) {
			if (ref $temp->{$name}) {
				push @{ $temp->{$name} }, $value;
			}
			else {
				$temp->{$name} = [$temp->{$name}, $value];
			}
		}
		else {
			$temp->{$name} = $value;
		}
	}
	return $temp;
}