File Coverage

blib/lib/Apache/Request/Redirect.pm

Criterion	Covered	Total	%
statement	33	135	24.4
branch	0	36	0.0
condition	0	6	0.0
subroutine	11	22	50.0
pod	5	7	71.4
total	49	206	23.7

package Apache::Request::Redirect;

use 5.006;
use strict;
use warnings;
use Carp;
use Exporter;

use vars qw(@ISA @EXPORT $LOG_REQUEST $LOG_QUERYSTRING $LOG_RESPONSE);

@ISA 					= qw(Exporter);
@EXPORT 				= qw($LOG_REQUEST $LOG_QUERYSTRING $LOG_RESPONSE);

use HTTP::Response;
use HTTP::Request;
use HTTP::Headers;
use LWP::UserAgent;
use URI;

$Apache::Request::Redirect::VERSION = '0.05';

$Apache::Request::Redirect::LOG = 0;

$LOG_REQUEST			= 0b0001;
$LOG_QUERYSTRING		= 0b0010;
$LOG_RESPONSE			= 0b0100;


my $MOD_PERL = 0;
# Turn on special checking for Doug MacEachern's modperl
if (exists $ENV{MOD_PERL}) {
  eval "require mod_perl";
  # mod_perl handlers may run system() on scripts using CGI.pm;
  # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
  if (defined $mod_perl::VERSION) {
    if ($mod_perl::VERSION >= 1.99) {
      $MOD_PERL = 2;
      require Apache::RequestRec;
      require Apache::RequestUtil;
      require APR::Pool;
    } else {
      $MOD_PERL = 1;
      require Apache;
    }
  }
}


my %fields = (
				apachereq		=> '',
				host			=> 'localhost',
				url				=> '/',
				args			=> {},
				use_http10		=> 0,
);

sub new {
	my ($proto,%options) = @_;
	my $class = ref($proto) || $proto;
	my $self = { };
	while (my ($key,$value) = each(%options)) {
      if (exists($fields{$key})) {
          $self->{$key} = $value;
      } else {
          die $class . "::new: invalid option '$key'\n";
      }
	}
	#foreach (keys %fields) {
	#	die $class . "::new: omitted required option '$_'\n"
	#		if (!defined $self->{$_});
	#}

	bless $self, $class;

	# attivo apachereq direttamente da Apache
	if ($MOD_PERL) {
		$self->apachereq(Apache->request) unless $self->apachereq;
		my $apachereq = $self->apachereq;
		if ($MOD_PERL == 1) {
			#$apacheref->register_cleanup(\&CGI::_reset_globals);
		} else {
      		# XXX: once we have the new API
      		# will do a real PerlOptions -SetupEnv check
      		#$apacheref->subprocess_env unless exists $ENV{REQUEST_METHOD};
      		#$apacheref->pool->cleanup_register(\&CGI::_reset_globals);
		}
	}

	if ($Apache::Request::Redirect::LOG != 0) {
		eval {
			require "Log/FileSimple.pm";
		};
		if ($@) {
			warn "Warning: Logging disabled...cannot find Log::FileSimple module";
			$Apache::Request::Redirect::LOG = 0;
		} else {
			$self->{log} 	= new Log::FileSimple(
													name=> "Apache::Request::Redirect",
													file=> '/tmp/Apache-Request-Redirect.log',
													mask=> $Apache::Request::Redirect::LOG,
											);
		}
	}
	return $self;
}

sub redirect() {
	# passare un riferimento ad hash con
	# i parametri della query in quanto la query string (GET)
	# o il content (POST) deve essere ricostruito
	# (Mason si mangia il content)
	my $self			= shift;
	my $request 		= $self->_prepare_request();
	$self->_log(message => "Request:\n" . $request->as_string , id => $LOG_REQUEST);
	my $response		= $self->_send_request($request);
	my $response_text 	= $response->as_string;
	$self->_log(id => $LOG_RESPONSE, message => "Response:\n" .
							$response_text);
	return $response;
}

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

	# Costruisco l'header della richiesta da quello originale
	my $headers			= new HTTP::Headers(%{$self->{apachereq}->headers_in});
	# modifico l'host per impostarlo a quello che andro' realmente a
	# chiamare
	$headers->header('Host',$self->{host});
	# dato che questo modulo e' fatto per post processare
	# l'html ottenuto...non posso permettere che mi ritorni
	# html compresso
	$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__