view release on metacpan or  search on metacpan

ParseFormData.pm  view on Meta::CPAN

		my $data = $self->args();
		&_parse_query($self, $data) if($data);
		$self->pnotes('apr_req_result' => Apache::OK);
	}
	return($self);
}

sub DESTROY {  
	my $self = shift;
	for my $v (values(%{$self->pnotes('upload')})) {
		my $path = $v->[1];
		unlink($path) if(-e $path);
	}
}

sub parse_result { $_[0]->pnotes('apr_req_result') }

sub parms { $_[0]->pnotes('apr_req') }

sub _parse_query {
	my $r = shift;
	my $query_string = shift;
	my $re = shift || "&";

	my %hash = ();
	for(split(/$re/, $query_string)) {
		my ($n, $v) = split(/=/);
		defined($v) or $v = "";
		&decode_chars($n);
		&decode_chars($v);
		push(@{$hash{$n}}, $v);
	}
	$r->param(%hash);
	return();
}

sub decode_chars {
	$_[0] =~ tr/+/ /;
	$_[0] =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C", hex($1))/egi;
}

sub set_cookie {
	my $self = shift;
	my $args = {
		name    => "",
		value   => "",
		path    => "/",
		expires => "",
		secure  => 0,
		domain  => "",
		@_,
	};
	$args->{'name'} or return();
	my @a = (
		join("=", $args->{'name'}, $args->{'value'}),
		join("=", "path", $args->{'path'}),
	);
	push(@a, join("=", "expires", &cookie_expire($args->{'expires'}))) if($args->{'expires'});
	push(@a, join("=", "secure", $args->{'secure'})) if($args->{'secure'});
	push(@a, join("=", "domain", $args->{'domain'})) if($args->{'domain'});
	$self->headers_out->{'Set-Cookie'} = join(";", @a);
	$self->param($args->{'name'} => $args->{'value'});
	return();
}

sub cookie_expire {
	my $time = shift;
	my ($sec,$min,$hour,$mday,$mon,$year,$wday) = localtime($time);
	my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
	my @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
	return sprintf("%3s, %02d-%3s-%04d %02d:%02d:%02d GMT", $weekday[$wday], $mday, $months[$mon], $year+1900, $hour, $min, $sec);
}

sub upload {
	my $self = shift;
	my $name = shift || "";
	return($name ? @{$self->pnotes('upload')->{$name}} : keys(%{$self->pnotes('upload')}));
}

sub parse_content {
	my $r = shift;
	my $args = shift;

	my $buf = "";
	$r->setup_client_block;
	$r->should_client_block or return '';
	my $ct = $r->headers_in->get('content-type');

	if($args->{'disable_uploads'} && index($ct, "multipart/form-data") > -1) {
		my $error_str = "[Apache::ParseFormData] file upload forbidden";
		$r->notes->set("error-notes" => $error_str);
		$r->log_error($error_str);
		return(Apache::FORBIDDEN);
	}
	my $rm = $r->remaining;
	if($args->{'post_max'} && ($rm > $args->{'post_max'})) {
		my $pm = $args->{'post_max'};
		my $error_str = "[Apache::ParseFormData] entity too large ($rm, max=$pm)";
		$r->notes->set("error-notes" => $error_str);
		$r->log_error($error_str);
		return(Apache::HTTP_REQUEST_ENTITY_TOO_LARGE);
	}
	if($ct =~ /^multipart\/form-data; boundary=(.+)$/) {
		my $boundary = $1;
		my $lenbdr = length("--$boundary");
		$r->get_client_block($buf, $lenbdr+2);
		$buf = substr($buf, $lenbdr);
		$buf =~ s/[\n\r]+//;
		my $iter = -1;
		my @data = ();
		&multipart_data($r, $args, \@data, $boundary, BUFFLENGTH, 1, $buf, $iter);
		my %uploads = ();
		for(@data) {
			if(exists($_->{'headers'}->{'content-disposition'})) {
				my @a = split(/ *; */, $_->{'headers'}->{'content-disposition'});
				if(shift(@a) eq "form-data") {
					if(scalar(@a) == 1) {
						my ($key) = ($a[0] =~ /name=\"([^\"]+)\"/);
						$r->param($key => $_->{'values'} || "");
					} else {
						(ref($_->{'values'}) eq "ARRAY") or next;