File Coverage

inc/Mock/LWP/UserAgent.pm

Criterion	Covered	Total	%
statement	84	103	81.5
branch	7	16	43.7
condition	0	3	0.0
subroutine	21	25	84.0
pod	1	1	100.0
total	113	148	76.3

package Mock::LWP::UserAgent;

use 5.006002;

use strict;
use warnings;

use Carp;
use Errno qw{ ENOENT };
use File::Spec;
use HTTP::Request;
use HTTP::Response;
use LWP::UserAgent;
use JSON;

our $VERSION = '0.180_03';

our $CANNED_RESPONSE_FILE;

use constant REF_HASH	=> ref {};

sub install_mock {

    $Astro::SpaceTrack::SPACETRACK_DELAY_SECONDS = 0;

    no warnings qw{ redefine };

    *LWP::UserAgent::new = sub {
	my ( $class, @arg ) = @_;
	### my $self = $class->SUPER::new( @arg );
	my $self = bless {}, $class;
	$self->{ +__PACKAGE__ } = __load_data();
	return $self;
    };

    *LWP::UserAgent::cookie_jar = sub {
	my ( $self, $data ) = @_;
	my $old = $self->{cookie_jar};
	if ( $data ) {
	    if ( REF_HASH eq ref $data ) {
		require HTTP::Cookies;
		$data = HTTP::Cookies->new( %{ $data } );
	    }
	    $self->{cookie_jar} = $data;
	}
	return $old;
    };

    *LWP::UserAgent::env_proxy = sub {
	return;
    };

    *LWP::UserAgent::get = sub {
	my ( $self, $url ) = @_;
	return $self->request( HTTP::Request->new( GET => $url ) );
    };

    *LWP::UserAgent::head = sub {
	my ( $self, $url ) = @_;
	return $self->request( HTTP::Request->new( HEAD => $url ) );
    };

    *LWP::UserAgent::post = sub {
	my ( $self, $url ) = @_;
	return $self->request( HTTP::Request->new( POST => $url ) );
    };

    *LWP::UserAgent::put = sub {
	my ( $self, $url ) = @_;
	return $self->request( HTTP::Request->new( PUT => $url ) );
    };

    *LWP::UserAgent::request = sub {
	my ( $self, $rqst ) = @_;
	my $method = $rqst->method();
	my $url = $rqst->url();

	my $data = $self->{ +__PACKAGE__ }{data}{$url}{$method}
	    or return _fail( $rqst, 404, "$method $url not found" );
	my $resp = HTTP::Response->new( @{ $data } );

	$resp->request( $rqst );
	if ( my $jar = $self->cookie_jar() ) {
	    $jar->extract_cookies( $resp );
	}
	return $resp;
    };
}

sub _fail {
    my ( $rqst, $code, $msg ) = @_;
    my $resp = HTTP::Response->new( $code, $msg );
    $resp->request( $rqst );
    return $resp;
}

sub __load_data {
    my ( %arg ) = @_;
    my $path = defined $CANNED_RESPONSE_FILE ?
	$CANNED_RESPONSE_FILE :
	File::Spec->catfile( qw{ t data Mock-LWP-UserAgent resp.json } );
    my $json = JSON->new();
    my $data;
    if ( open my $fh, '<:encoding(utf-8)', $path ) {
	local $/ = undef;	# Slurp mode
	$data = $json->decode( scalar <$fh> );
	close $fh;
    } elsif ( $arg{optional} && $! == ENOENT ) {
	$data = {};
    } else {
	croak "Failed to open $path: $!";
    }
    return +{
	path	=> $path,
	data	=> $data,
    };
}

sub __modify_data {
    my ( $data, $url, $method, $resp ) = @_;
    $data->{data}{$url}{$method} = $resp;
    my $path = $data->{path};
    my $json = JSON->new()->pretty()->canonical();
    open my $fh, '>:encoding(utf-8)', $path
	or croak "Unable to modify $path: $!";
    print { $fh } $json->encode( $data->{data} );
    close $fh;
    return;
}

1;

__END__