File Coverage

blib/lib/Test/Override/UserAgent/Scope.pm

Criterion	Covered	Total	%
statement	92	93	98.9
branch	10	12	83.3
condition			n/a
subroutine	20	20	100.0
pod	2	2	100.0
total	124	127	97.6

package Test::Override::UserAgent::Scope;

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

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

###########################################################################
# MODULE IMPORTS
use Carp qw(croak);
use LWP::Protocol; # Not actually required here, but want it to be loaded
use Scalar::Util;
use Sub::Install 0.90;
use Sub::Override;

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

###########################################################################
# METHODS
sub scheme_implementor {
	my ($self, $scheme) = @_;

	# Lower-case scheme
	$scheme = lc $scheme;

	if (!exists $self->{_protocol_classes}->{$scheme}) {
		# Create a new scheme implementor
		$self->_create_scheme_implementor($scheme);
	}

	# Return the name of the class to use
	return $self->{_protocol_classes}->{$scheme};
}

###########################################################################
# 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
		override => undef,

		# Private attributes
		_original_implementor_lookup => undef,
		_protocol_classes            => {},
	);

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

	if (!defined $data{override}) {
		croak 'Must supply override attribute';
	}

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

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

	# Get the current implementor lookup
	$self->{_original_implementor_lookup} = \&LWP::Protocol::implementor;

	# Store the scope override reference
	$self->{_scope_override} = $self->_install_in_scope;

	# Return our blessed configuration
	return $self;
}

###########################################################################
# DESTRUCTOR
sub DESTROY {
	my ($self) = @_;

	# Destroy the override
	undef $self->{_scope_override};

	# Destroy all the created packages
	foreach my $scheme (keys %{$self->{_protocol_classes}}) {
		$self->_destroy_scheme_implementor($scheme);
	}

	return;
}

###########################################################################
# PRIVATE METHODS
sub _create_scheme_implementor {
	my ($self, $scheme) = @_;

	# Calculate a new scheme class name
	my $new_scheme_class = sprintf '%s::%s',
		$self->{_uniq_name}, $scheme;

	# Install new() into the scheme class
	Sub::Install::install_sub({
		into => $new_scheme_class,
		as   => 'new',
		code => $self->_generate_scheme_new,
	});

	# Install request() into the scheme class
	Sub::Install::install_sub({
		into => $new_scheme_class,
		as   => 'request',
		code => $self->_generate_scheme_request($scheme),
	});

	# Save the name of the new class
	$self->{_protocol_classes}->{$scheme} = $new_scheme_class;

	return $new_scheme_class;
}
sub _destroy_scheme_implementor {
	my ($self, $scheme) = @_;

	# Get the package name of the scheme
	my $package = $self->{_protocol_classes}->{$scheme};

	if (defined $package) {
		# Delete new and request methods
		undef &{$package . '::new'};
		undef &{$package . '::request'};
	}

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

	return sub {
		my ($class, $scheme, $ua) = @_;

		my $object = bless {
			scheme => $scheme,
			ua     => $ua,
		}, $class;

		return $object;
	}
}
sub _generate_scheme_request {
	my ($self, $scheme) = @_;

	# Copy self
	my $weak_self = $self;

	# Weaken the self reference
	Scalar::Util::weaken($weak_self);

	return sub {
		my ($proto_self, $request, $proxy, $arg, $size, $timeout) = @_;

		# Get the override object
		my $override = $weak_self->{override};

		# Process the request by us
		my $response = $override->handle_request(
			$request,
			live_request_handler => sub {
				# Get the normal implementor
				my $implementor_class = $weak_self->{_original_implementor_lookup}->($scheme);

				if (!defined $implementor_class) {
					croak "Protocol scheme '$scheme' is not supported";
				}

				# Create a new instance
				my $implementor = $implementor_class->new($proto_self->{qw(scheme ua)});

				# Make the request
				my $live_response = $implementor->request($request, $proxy, $arg, $size, $timeout);

				return $live_response;
			},
		);

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

	# Get the current implementor lookup
	my $implementor_lookup = \&LWP::Protocol::implementor;

	# Created a weakened self to allow for destruction
	my $weak_self = $self;
	Scalar::Util::weaken($weak_self);

	# Create an override for the current scope
	my $override = Sub::Override->new(
		'LWP::Protocol::implementor' => sub { return $weak_self->scheme_implementor(shift); },
	);

	return $override;
}

1;

__END__