File Coverage

blib/lib/Test/Override/UserAgent.pm

Criterion	Covered	Total	%
statement	192	192	100.0
branch	53	54	98.1
condition	22	23	95.6
subroutine	39	39	100.0
pod	7	7	100.0
total	313	315	99.3

package Test::Override::UserAgent;

use 5.008001;
use strict;
use warnings 'all';

###########################################################################
# METADATA
our $AUTHORITY = 'cpan:DOUGDUDE';
our $VERSION   = '0.004001';

###########################################################################
# MODULE IMPORTS
use Carp qw(croak);
use Clone;
use HTTP::Config 5.815;
use HTTP::Date ();
use HTTP::Headers;
use HTTP::Response;
use HTTP::Status 5.817 ();
use LWP::UserAgent; # Not actually required here, but want it to be loaded
use Scalar::Util;
use Sub::Install 0.90;
use Test::Override::UserAgent::Scope;
use Try::Tiny;
use URI;

###########################################################################
# ALL IMPORTS BEFORE THIS WILL BE ERASED
use namespace::clean 0.04 -except => [qw(meta)];

###########################################################################
# METHODS
sub allow_live_requests {
	my ($self, $new_value) = @_;

	if (defined $new_value) {
		# Set the new value
		$self->{allow_live_requests} = $new_value;
	}

	return $self->{allow_live_requests};
}
sub handle_request {
	my ($self, $request, %args) = @_;

	# Lookup the handler for the request
	my $handler = $self->_get_handler_for($request);

	# Hold the response
	my $response;

	if (defined $handler) {
		# Get the response
		$response = _convert_psgi_response($handler->($request));

		if (!defined $response->request) {
			# Set the request that made this response
			$response->request($request);
		}
	}

	if (!defined $response && exists $args{live_request_handler}) {
		# There was no handler/response and a live requestor was provided
		if ($self->allow_live_requests) {
			# Make the live request
			$response = $args{live_request_handler}->($request);
		}
		else {
			# Make an internal response for not successful since no
			# live requests are allowed.
			$response = _new_internal_response(
				HTTP::Status::HTTP_NOT_FOUND,
				'Not Found (No Live Requests)',
			);
		}
	}

	return $response;
}
sub install_in_scope {
	my ($self) = @_;

	# Return the scope variable
	return Test::Override::UserAgent::Scope->new(
		override => $self,
	);
}
sub install_in_user_agent {
	my ($self, $user_agent, %args) = @_;

	# Get the clone argument
	my $clone = exists $args{clone} ? $args{clone} : 0;

	if ($clone) {
		# Make a clone of the user agent
		$user_agent = $user_agent->clone;
	}

	# Add as a handler in the user agent
	$user_agent->add_handler(
		request_send => sub {
			# Get the response
			my $response = $self->handle_request(
				shift,
				live_request_handler => sub { return; },
			);

			return $response;
		},
		owner => Scalar::Util::refaddr($self),
	);

	# Return the user agent
	return $user_agent;
}
sub override_request {
	my ($self, @args) = @_;

	# Get the handler from the end
	my $handler = pop @args;

	# Convert the arguments into a hash
	my %args = @args;

	# Register the handler
	$self->_register_handler($handler, %args);

	# Enable chaining
	return $self;
}
sub uninstall_from_user_agent {
	my ($self, $user_agent) = @_;

	# Remove our handlers from the user agent
	$user_agent->remove_handler(
		'request_send',
		owner => Scalar::Util::refaddr($self),
	);

	# Return the user agent for some reason
	return $user_agent;
}

###########################################################################
# STATIC METHODS
sub import {
	my ($class, %args) = @_;

	# What this module is being used for
	my $use_for = $args{for} || 'testing';

	if ($use_for eq 'configuration') {
		# Get the calling package
		my $caller = caller;

		# Create a new configuration object that will be wrapped in
		# closures.
		my $conf = $class->new;

		# Create a defaults hash for colsures
		my $defaults = {};

		# Install override_request
		Sub::Install::install_sub({
			code => sub { return $conf->override_request(%{$defaults}, @_); },
			into => $caller,
			as   => 'override_request',
		});

		# Install override_for
		Sub::Install::install_sub({
			code => sub {
				my $block = pop;

				# Rember the current defaults
				my $previous_defaults = $defaults;

				# Set the new defaults as an extension of the current
				$defaults = {%{Clone::clone($defaults)}, @_};

				# Run the block with the defaults in effect
				$block->();

				# Restore the defaults
				$defaults = $previous_defaults;
			},
			into => $caller,
			as   => 'override_for',
		});

		# Install allow_live
		Sub::Install::install_sub({
			code => sub {
				my $allow = shift;

				# Set the allow live requests (no arguments defaults to 1)
				$conf->allow_live_requests(defined $allow ? $allow : 1);
			},
			into => $caller,
			as   => 'allow_live',
		});

		# Install custom configuration which retuns the config object
		Sub::Install::install_sub({
			code => sub { return $conf; },
			into => $caller,
			as   => 'configuration',
		});
	}

	return;
}

###########################################################################
# CONSTRUCTOR
sub new {
	my ($class, @args) = @_;

	# Get the arguments as a plain hash
	my %args = @args == 1 ? %{shift @args}
	                      : @args
	                      ;

	# Create a hash with configuration information
	my %data = (
		# Attributes
		allow_live_requests => 0,

		# Private attributes
		_lookup_table => HTTP::Config->new,
		_protocol_classes => {},
	);

	# Set attributes
	foreach my $arg (grep { m{\A [^_]}msx } keys %data) {
		if (exists $args{$arg}) {
			$data{$arg} = $args{$arg};
		}
	}

	# Bless the hash to this class
	my $self = bless \%data, $class;

	# Set our unique name
	$self->{_uniq_name} = $class . '::Number' . Scalar::Util::refaddr($self);

	# Return our blessed configuration
	return $self;
}

###########################################################################
# PRIVATE METHODS
sub _get_handler_for {
	my ($self, $request) = @_;

	# Get the handler
	my @handlers = $self->{_lookup_table}->matching_items($request);

	return $handlers[0];
}
sub _register_handler {
	my ($self, $handler, %args) = @_;

	# Add m_ to the beginning of the arguments
	for my $key (keys %args) {
		# Specially handle "url" key as HTTP::Config does not
		if ($key eq 'url' || $key eq 'uri') {
			# Get the URI from the arguments
			my $uri = URI->new(delete $args{$key});

			# Set a match against it's canonical value
			$args{m_uri__canonical} = $uri->canonical;
		}
		elsif (q{m_} ne substr $key, 0, 2) {
			# Add m_
			$args{"m_$key"} = delete $args{$key};
		}
	}

	# Set the handler
	$self->{_lookup_table}->add_item($handler, %args);

	return;
}

###########################################################################
# PRIVATE FUNCTIONS
sub _convert_psgi_response {
	my ($response) = @_;

	if (!defined Scalar::Util::blessed($response)) {
		# Get the type of the response
		my $response_type = Scalar::Util::reftype($response);

		if (defined $response_type && $response_type eq 'ARRAY') {
			# This is a PSGI-formatted response
			try {
				# Validate the response
				_validate_psgi_response($response);

				# Unwrap the PSGI response
				my ($status_code, $headers, $body) = @{$response};

				# Change the headers to a header object
				$headers = HTTP::Headers->new(@{$headers});

				if (ref $body ne 'ARRAY') {
					# The body is a filehandle
					my $fh = $body;

					# Change the body to an array reference
					$body = [];

					while (defined(my $line = $fh->getline)) {
						# Push the line into the body
						push @{$body}, $line;
					}

					# Close the file
					$fh->close;
				}

				# Create the response object
				$response = HTTP::Response->new(
					$status_code, undef, $headers, join q{}, @{$body});
			}
			catch {
				# Invalid PSGI response
				my $error = "$_"; # stringify error

				# Remove line information from croak
				$error =~ s{\s at \s .+ \z}{}msx;

				# Set the response
				$response = _new_internal_response(
					HTTP::Status::HTTP_EXPECTATION_FAILED,
					$error,
				);
			};
		}
		else {
			# Bad return value from handler
			$response = _new_internal_response(
				HTTP::Status::HTTP_EXPECTATION_FAILED,
				'Override handler returned invalid value: ' . $response
			);
		}
	}

	return $response;
}
sub _is_invalid_psgi_header_key {
	my ($key) = @_;

	return $key =~ m{(?:\A status \z | [:\n] | [_-] \z)}imsx
		|| $key !~ m{\A [a-z] [a-z0-9_-]* \z}imsx;
}
sub _is_invalid_psgi_header_value {
	my ($value) = @_;

	return ref $value ne q{} || $value =~ m{[\x00-\x19\x21-\x25]}imsx;
}
sub _new_internal_response {
	my ($code, $message) = @_;

	# Make a new response
	my $response = HTTP::Response->new($code, $message);

	# Set some headers for client information
	$response->header(
		'Client-Date'            => HTTP::Date::time2str(time),
		'Client-Response-Source' => __PACKAGE__,
		'Client-Warning'         => 'Internal response',
		'Content-Type'           => 'text/plain',
	);

	# Set the content as the status_line
	$response->content("$code $message");

	return $response;
}
sub _validate_psgi_response {
	my ($psgi) = @_;

	# Unwrap the response
	my ($code, $headers, $body) = @{$psgi};

	if ($code !~ m{\A [1-9] \d{2,} \z}msx) {
		croak 'PSGI HTTP status code MUST be 100 or greater';
	}

	if (ref $headers ne 'ARRAY') {
		croak 'PSGI headers MUST be an array reference';
	}

	if (@{$headers} % 2 != 0) {
		croak 'PSGI headers MUST have even number of elements';
	}

	# Headers copied
	my @headers = @{$headers};

	# Hold invalid stuff
	my (@invalid_header_keys, @invalid_header_values,
		$has_content_type, $has_content_length);

	while (my ($key, $value) = splice @headers, 0, 2) {
		if (_is_invalid_psgi_header_key($key)) {
			# Remember the invalid key
			push @invalid_header_keys, $key;
		}
		elsif (lc $key eq 'content-type') {
			# The response has a defined content type
			$has_content_type = 1;
		}
		elsif (lc $key eq 'content-length') {
			# The response has a defined content length
			$has_content_length = 1;
		}

		if (_is_invalid_psgi_header_value($value)) {
			# Remember the key of the invalid value
			push @invalid_header_values, $key;
		}
	}

	if (@invalid_header_keys) {
		croak 'PSGI headers have invalid key(s): ',
			join q{, }, sort @invalid_header_keys;
	}

	if (@invalid_header_values) {
		croak 'PSGI headers have invalid value(s): ',
			join q{, }, sort @invalid_header_values;
	}

	if (!$has_content_type && $code !~ m{\A 1 | [23]04}msx) {
		croak 'There MUST be a Content-Type for code other than 1xx, 204, and 304';
	}

	if ($has_content_length && $code =~ m{\A 1 | [23]04}msx) {
		croak 'There MUST NOT be a Content-Length for 1xx, 204, and 304';
	}

	# Return true for successful check
	return 1;
}

1;

__END__