<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Test::Mock::LWP::Conditional;

use 5.008001;
use strict;
use warnings;
use LWP::UserAgent;
use Scalar::Util qw(blessed refaddr);
use Sub::Install qw(install_sub);
use Class::Method::Modifiers qw(install_modifier);
use Math::Random::Secure qw(irand);
use Test::Mock::LWP::Conditional::Stubs;

our $VERSION = '0.04';
$VERSION = eval $VERSION;

our $Stubs = +{ __GLOBAL__ =&gt; +{} };
our $Regex = +{ __GLOBAL__ =&gt; +{} };

sub _set_stub {
    my ($key, $uri, $res) = @_;

    $Stubs-&gt;{$key} ||= +{};

    if (ref $uri eq 'Regexp') {
        my $rng = irand('9999999999999999');
        $Regex-&gt;{$key}-&gt;{$rng} = $uri;
        $uri = $rng;
    }

    $Stubs-&gt;{$key}-&gt;{$uri} ||= Test::Mock::LWP::Conditional::Stubs-&gt;new;
    $Stubs-&gt;{$key}-&gt;{$uri}-&gt;add($res);
}

sub _get_stub {
    my ($key, $uri) = @_;

    if (exists $Stubs-&gt;{$key}) {
        if (exists $Stubs-&gt;{$key}-&gt;{$uri}) {
            return $Stubs-&gt;{$key}-&gt;{$uri};
        }
        return _check_regex($key, $uri);
    }
    elsif (exists $Stubs-&gt;{__GLOBAL__}-&gt;{$uri}) {
        return $Stubs-&gt;{__GLOBAL__}-&gt;{$uri};
    } else {
        return _check_regex("__GLOBAL__", $uri);
    }
}

sub _check_regex {
    my ($key, $uri) = @_;

    foreach my $marker (keys %{$Regex-&gt;{$key}}) {
        if ($uri =~ $Regex-&gt;{$key}-&gt;{$marker}) {
            return $Stubs-&gt;{$key}-&gt;{$marker};
        }
    }
}

sub stub_request {
    my ($self, $uri, $res) = @_;
    my $key = blessed($self) ? refaddr($self) : '__GLOBAL__';
    _set_stub($key, $uri, $res);
}

sub reset_all {
    $Stubs = +{ __GLOBAL__ =&gt; +{} };
    $Regex = +{ __GLOBAL__ =&gt; +{} };
}

{ # LWP::UserAgent injection
    install_modifier('LWP::UserAgent', 'around', 'simple_request', sub {
        my $orig = shift;
        my ($self, $req, @rest) = @_;

        my $stub = _get_stub(refaddr($self), $req-&gt;uri);
        return $stub ? $stub-&gt;execute($req) : $orig-&gt;(@_);
    });

    install_sub({
        code =&gt; __PACKAGE__-&gt;can('stub_request'),
        into =&gt; 'LWP::UserAgent',
        as   =&gt; 'stub_request',
    });
}

1;

=head1 NAME

Test::Mock::LWP::Conditional - stubbing on LWP request

=head1 SYNOPSIS

    use LWP::UserAgent;
    use HTTP::Response;

    use Test::More
    use Test::Mock::LWP::Conditional;

    my $uri = 'http://example.com/';

    # global
    Test::Mock::LWP::Conditional-&gt;stub_request($uri =&gt; HTTP::Response-&gt;new(503));
    is LWP::UserAgent-&gt;new-&gt;get($uri)-&gt;code =&gt; 503;

    # lexical
    my $ua = LWP::UserAgent-&gt;new;
    $ua-&gt;stub_request($uri =&gt; sub { HTTP::Response-&gt;new(500) });
    is $ua-&gt;get($uri)-&gt;code =&gt; 500;
    is LWP::UserAgent-&gt;new-&gt;get($uri)-&gt;code =&gt; 503;

    # reset
    Test::Mock::LWP::Conditional-&gt;reset_all;
    is $ua-&gt;get($uri)-&gt;code =&gt; 200;
    is LWP::UserAgent-&gt;new-&gt;get($uri)-&gt;code =&gt; 200;

=head1 DESCRIPTION

This module stubs out LWP::UserAgent's request.

=head1 METHODS

=over 4

=item * stub_request($uri, $res)

Sets stub response for requesed URI.

=item * reset_all

Clear all stub requests.

=back

=head1 AUTHOR

NAKAGAWA Masaki E&lt;lt&gt;masaki@cpan.orgE&lt;gt&gt;

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L&lt;Test::Mock::LWP&gt;, L&lt;Test::Mock::LWP::Dispatch&gt;, L&lt;Test::MockHTTP&gt;, L&lt;Test::LWP::MockSocket::http&gt;

L&lt;LWP::UserAgent&gt;

L&lt;https://github.com/bblimke/webmock&gt;, L&lt;https://github.com/chrisk/fakeweb&gt;

=cut
</pre></body></html>