view release on metacpan or  search on metacpan

ParseFormData.pm  view on Meta::CPAN

							my ($name, $value) = (/([^=]+)=\"([^\"]+)\"/);
							if($name eq "name") {
								$uploads{$value} = [$fh, $path];
								$param = $value;
							} else {
								$hash{$name} = $value;
							}
						}
						$r->param($param => \%hash);
					}
				}
			}
		}
		$r->pnotes('upload' => \%uploads);
	} else {
		my $len = $r->headers_in->get('content-length');
		$r->get_client_block($buf, $len);
		&_parse_query($r, $buf) if($buf);
	}
	return(Apache::OK);
}

sub extract_headers {
	my $raw = shift;
	my %hash = ();
	for(split(/\r?\n/, $raw)) {
		s/[\r\n]+$//;
		$_ or next;
		my ($h, $v) = split(/ *: */, $_, 2);
		$hash{lc($h)} = $v;
	}
	$_[0] = \%hash;
	return(exists($hash{'content-type'}));
}

sub output_data {
	my $dest = shift;
	my $data = shift;

	if(ref($dest->{values}) eq "ARRAY") {
		my $fh = $dest->{values}->[0];
		print $fh $data;
	} else { $dest->{values} .= $data; }
}

sub new_tmp_file {
	my $temp_dir = shift;
	my $data = shift;

	my $path = "";
	my $fh;
	my $i = 0;
	do {
		$i < 3 or last;
		my $name = tmpnam(); 
		$name = (split("/", $name))[-1];
		$path = join("/", $temp_dir, $name);
		$i++;
	} until($fh = IO::File->new($path, O_RDWR|O_CREAT|O_EXCL));
	defined($fh) or return("Couldn't create temporary file: $path");
	binmode($fh);
	$fh->autoflush(1);
	$data->{values} = [$fh, $path];
	return();
}

sub multipart_data {
	my $r = shift;
	my $args = shift;
	my $data = shift;
	my $boundary = shift;
	my $len = shift;
	my $h = shift;
	my $buff = shift;

	my ($part, $content) = ($buff, "");
	while($r->get_client_block($buff, $len)) {
		$part .= $buff;
		if($h) {
			if($part =~ /\r?\n\r?\n/) {
				my ($left, $right) = ($`, $');
				$left =~ s/[\r\n]+$//;
				$_[0]++;
				push(@{$data}, {values => "", headers => {}});
				if(&extract_headers($left, $data->[$_[0]]->{'headers'})) {
					if(my $error = &new_tmp_file($args->{'temp_dir'}, $data->[$_[0]])) { $r->log->warn($error), next; }
				}
				$part = $content = $right;
				$h = 0;
			} else { next; }
		}
		if($part =~ /\r?\n--$boundary\r?\n/) {
			my ($left, $right) = ($`, $');
			&output_data($data->[$_[0]], $left) if($left);
			&multipart_data($r, $args, $data, $boundary, $len, 1, $right, $_[0]);
			$part = "";
		}
		if($part) {
			$content = substr($part, 0, int($len/2));
			&output_data($data->[$_[0]], $content) if($content);
			$part = substr($part, int($len/2));
		}
	}
	if($h && $part =~ /\r?\n\r?\n/) {
		my ($left, $right) = ($`, $');
		$left =~ s/[\r\n]+$//;
		$_[0]++;
		push(@{$data}, {values => "", headers => {}});
		if(&extract_headers($left, $data->[$_[0]]->{'headers'})) {
			if(my $error = &new_tmp_file($args->{'temp_dir'}, $data->[$_[0]])) { $r->log->warn($error), next; }
		}
		$part = $right;
		$h = 0;
	}
	if($part =~ /\r?\n--$boundary\r?\n/) {
		my ($left, $right) = ($`, $');
		&output_data($data->[$_[0]], $left) if($left);
		&multipart_data($r, $args, $data, $boundary, $len, 1, $right, $_[0]);
		$part = "";
	}
	if($part =~ /\r?\n--$boundary--[\r\n]*/) {