File Coverage

blib/lib/Test/WWW/Stub.pm

Criterion	Covered	Total	%
statement	82	83	98.8
branch	11	14	78.5
condition	7	14	50.0
subroutine	29	30	96.6
pod	7	7	100.0
total	136	148	91.8

package Test::WWW::Stub;
use 5.010;
use strict;
use warnings;

our $VERSION = "0.11";

use Carp ();
use Guard;  # guard
use LWP::Protocol::PSGI;
use Plack::Request;
use Test::More ();
use List::MoreUtils ();
use URI;

use Test::WWW::Stub::Intercepter;

my  $Intercepter = Test::WWW::Stub::Intercepter->new;
our @Requests;

my $register_g;
my $app;
my %import_options;
sub _app { $app; }

$app = sub {
    my ($env) = @_;
    my $req = Plack::Request->new($env);

    push @Requests, $req;

    my $uri = _normalize_uri($req->uri);

    my $stubbed_res = $Intercepter->intercept($uri, $env, $req);
    return $stubbed_res if $stubbed_res;

    my ($file, $line) = _trace_file_and_line();

    my $method = $req->method;
    warn "Unexpected external access: $method $uri at $file line $line";

    return [ 499, [], [] ];
};

sub import {
    my ($class, %options) = @_;
    if (!defined $register_g || _diff(\%import_options, \%options)) {
        %import_options = %options;
        $register_g = LWP::Protocol::PSGI->register($app, %options);
    }
}

sub unimport {
    undef $register_g;
    undef %import_options;
}

sub register {
    my ($class, $uri_or_re, $app_or_res) = @_;
    $app_or_res //= [200, [], []];

    my $handler = $Intercepter->register($uri_or_re, $app_or_res);
    defined wantarray && return guard {
        $Intercepter->unregister($uri_or_re, $handler);
    };
}

sub last_request {
    return undef unless @Requests;
    return $Requests[-1];
}

sub last_request_for {
    my ($class, $method, $url) = @_;
    my $reqs = { map { _request_signature($_) => $_ } @Requests };
    my $signature = "$method $url";
    return $reqs->{$signature};
}

sub _request_signature {
    my ($req) = @_;
    my $normalized = _normalize_uri($req->uri);
    return join ' ', $req->method, $normalized;
}

# Don't use query part of URI for handler matching.
sub _normalize_uri {
    my ($uri) = @_;
    my $cloned = $uri->clone;
    $cloned->query(undef);
    return $cloned;
}

sub requests { @Requests }

sub requested_ok {
    my ($class, $method, $url) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    Test::More::ok(
        List::MoreUtils::any(sub {
            my $req_url = _normalize_uri($_->uri);
            $_->method eq $method && $req_url eq $url
        }, @Requests),
        "stubbed $method $url",
    ) or Test::More::diag Test::More::explain [ map { $_->method . ' ' . $_->uri } @Requests ]
}

sub clear_requests {
    @Requests = ();
}

sub _trace_file_and_line {
    my $level = $Test::Builder::Level;
    my (undef, $file, $line) = caller($level);
    # assume "Actual" caller is test file named FOOBAR.t
    while ($file && $file !~ m<\.t$>) {
        (undef, $file, $line) = caller(++$level);
    }
    ($file, $line);
}

sub unstub {
    Carp::croak 'guard is required' unless defined wantarray;
    undef $register_g;

    # Copy options to restore the state at the time of unstub
    my %options = %import_options;
    return guard {
        %import_options = %options;
        $register_g = LWP::Protocol::PSGI->register($app, %options);
    }
}

sub _diff {
    my ($a, $b) = @_;

    my @diff_a = List::MoreUtils::any { !(exists $b->{$_} && ($b->{$_} eq $a->{$_})) } keys %$a;
    my @diff_b = List::MoreUtils::any { !(exists $a->{$_} && ($a->{$_} eq $b->{$_})) } keys %$b;

    @diff_a || @diff_b
}

1;
__END__