view release on metacpan or  search on metacpan

Redirect.pm  view on Meta::CPAN

	$headers->remove_header('Accept-Encoding');
	#$self->_log(id => $LOG_REQUEST, message => 'HTTP::Headers',objects=>[$headers]);
	# costruisco l'url ed il content
	my $uri				= URI->new();
	$uri->scheme('http');
	$uri->host($self->{host});
	$uri->path($self->{url});
	$uri->query_form(%$request_args);
	my $content;
	if ($self->{apachereq}->method eq 'POST') {
		# costruisco il content
		$content		= $self->_built_content();
		# nel post la query string totale la metto nel
		# content e non nell'url
		$content		.= $uri->query;
		# nell'url ci lasciamo la sola query_string originale (00.04)
		$uri->query(scalar($self->{apachereq}->args));
		# imposto la lunghezza del content nell'header
		$headers->header('Content-Length' => length($content));
	} else {
		# nel get il content non c'e' (sara' vero ? :-)
		$headers->remove_header('Content-Length');
	}
	# costruisco la nuova richiesta per il recupero dell'url
	my $request			= new HTTP::Request($self->{apachereq}->method,
											$uri,
											$headers,
											$content
						);
	return $request;
}

sub _send_request() {
	my $self			= shift;
	my $request			= shift;

	if ($self->{use_http10}) {
		require LWP::Protocol::http10;
		LWP::Protocol::implementor('http', 'LWP::Protocol::http10');
	}
	my $ua 				= new LWP::UserAgent;
	my $response		= $ua->send_request($request);
	return $response;
}

sub _log() {
	my $self 			= shift;
	$self->{log} && $self->{log}->log(@_);
}

sub _built_content() {
	my $self			= shift;
	my $request_args	= $self->{args};

	my $request			= $self->{apachereq};
	my $content;
	my $boundary;
	if ($request->header_in("Content-type") =~ 
							qr|^multipart/form-data; boundary=(.+?)$|i) {
		$boundary   = "--$1";	
		for my $upload ($self->{apachereq}->upload) {
			$self->_log(message => 'Upload object',
						objects=>[$upload], id => $LOG_REQUEST);
			$content .= "$boundary\r\n";
			my $info = $upload->info;
			while (my($key, $val) = each %$info) {
				if ($key ne 'Content-Type') {
					$content .= "$key: $val; ";
				}
				# rimuovo l'ultimo ;
				chop($content);
			}
			$content .= "\r\nContent-Type: " .
			$upload->info("Content-Type") . "\r\n\r\n";
			my $fh = $upload->fh;
			while (<$fh>) {
				$content .= $_;
			}
			# lo rimuovo da args
			delete $request_args->{$upload->name};
		}
		# aggiungo gli args
		while (my ($key,$val) = each(%$request_args)) {
			$content .= qq|\r\n$boundary\r\nContent-Disposition: | .
				qq|form-data; name="$key"\r\n\r\n$val|;
		}
		$content .= "\r\n$boundary--\r\n";
	}
	
	return $content;
}

# read-write property

sub apachereq { 
	my $s = shift; 
	if (@_) { 
		die "apachereq must be a reference to Apache or Apache::Request object" 
			if (ref($_[0]) ne "Apache" && ref($_[0]) ne "Apache::Request");
		$s->{apachereq} = shift; 
	} 
	return $s->{apachereq}; 
}

sub host { my $s = shift; if (@_) { $s->{host} = shift; } return $s->{host}; }
sub url { my $s = shift; if (@_) { $s->{url} = shift; } return $s->{url}; }
sub use_http10 { my $s = shift; if (@_) { $s->{use_http10} = shift; } return $s->{use_http10}; }

sub args { 
	my $s = shift; 
	if (@_) { 
		die "args must be a reference to a hash insteed of " . ref($_[0])
			 if (ref($_[0]) ne "HASH");
		$s->{args} = shift; 
	} 
	return $s->{args}; 
}

1;
__END__