File Coverage

blib/lib/Test/WWW/Stub.pm

Criterion	Covered	Total	%
statement	72	73	98.6
branch	11	12	91.6
condition	5	8	62.5
subroutine	25	26	96.1
pod	7	7	100.0
total	120	126	95.2

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

our $VERSION = "0.08";

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;
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 {
    $register_g //= LWP::Protocol::PSGI->register($app);
}

sub register {
    my ($class, $uri_or_re, $app_or_res) = @_;
    $app_or_res //= [200, [], []];
    my $old_handler = $Intercepter->get_handler($uri_or_re);

    $Intercepter->register($uri_or_re, $app_or_res);
    defined wantarray && return guard {
        if ($old_handler) {
            $Intercepter->register($uri_or_re, $old_handler);
        } else {
            $Intercepter->unregister($uri_or_re);
        }
    };
}

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;
    return guard {
        $register_g = LWP::Protocol::PSGI->register($app);
    }
}

1;
__END__