File Coverage

blib/lib/LWP/UserAgent/Mockable.pm

Criterion	Covered	Total	%
statement	96	101	95.0
branch	30	36	83.3
condition	5	5	100.0
subroutine	18	18	100.0
pod	6	6	100.0
total	155	166	93.3

package LWP::UserAgent::Mockable;

use warnings;
use strict;

use Hook::LexWrap;
use LWP::UserAgent;
use Safe::Isa '$_isa';
use Storable qw( dclone nstore retrieve );

our $VERSION = '1.16';

my $instance = __PACKAGE__->__instance;
sub __instance {
    my ( $class ) = @_;

    if ( not defined $instance ) {
        $instance = bless {
            action          => undef,
            file            => undef,
            current_request => undef,
            actions         => [],
            callbacks       => {},
            wrappers        => {},
        }, $class;

        my $action = defined $ENV{ LWP_UA_MOCK }
          ? lc $ENV{ LWP_UA_MOCK }
          : 'passthrough';

        $instance->reset( $action, $ENV{ LWP_UA_MOCK_FILE } );
    }

    return $instance;
}

sub reset {
    my ( $class, $action, $file ) = @_;

    if ( scalar @{ $instance->{ actions } } ) {
        die "Can't reset state whilst pending actions.  Need to call finish first";
    }

    if ( not defined $action ) {
        $action = "passthrough";
    }

    if ( $action !~ /^(playback|record|passthrough)/ ) {
        die "Action must be one of 'passthrough', 'playback' or 'record'";
    }

    if ( $action ne 'passthrough' and not defined $file ) {
        die "No file defined.  Should point to file you wish to record to or playback from";
    }

    $instance->{ wrappers } = {};
    $instance->{ action } = $action;
    $instance->{ file } = $file;
    $instance->{ callbacks } = {};

    $instance->__reset;
}

sub __reset {
    my ( $self ) = @_;

    my ( $action, $file, $callbacks, $wrappers )
      = @{ $self }{ qw( action file callbacks wrappers ) };

    if ( $action eq 'playback' ) {
        local $Storable::Eval = 1;

        $self->{ actions } = retrieve( $file );

        $wrappers->{ pre } = wrap 'LWP::UserAgent::simple_request',
            pre     => sub {
                my ( $wrapped, $request ) = @_;

                my $current = shift @{ $self->{ actions } };
                if ( not defined $current ) {
                    die "No further HTTP requests exist.  You possibly need to re-record the LWP session";
                }

                my $response = $current->{ response };

                if ( $callbacks->{ playback_validation } ) {
                    my $mock_request = $current->{ request };

                    $callbacks->{ playback_validation }( $request, $mock_request );
                }

                if ( $callbacks->{ playback }) {
                    $response = $callbacks->{ playback }( $request, $response );

                    if ( not $response->$_isa( 'HTTP::Response' ) ) {
                        die "playback callback didn't return an HTTP::Response object";
                    }
                }

                $_[ -1 ] = $response;
            };
    } else {
        $wrappers->{ pre } = wrap 'LWP::UserAgent::simple_request',
            pre     => sub {
                my ( $wrapped, $request ) = @_;

                $self->{ current_request } = $request;

                if ( $callbacks->{ pre_record } ) {
                    $_[ -1 ] = $callbacks->{ pre_record }( $request );

                    if ( not $_[ -1 ]->$_isa( 'HTTP::Response' ) ) {
                        die "pre-record callback didn't return an HTTP::Response object";
                    }
                }
            };

        # It's intentional that wrap is called separately for this.  We want the
        # post action to always be called, even if the pre-action short-circuits
        # the request.  Otherwise, would need to duplicate the storing logic.
        # This does mean that, when both pre- and post-record callbacks are being
        # used, that the post-callback will take precedence.

        $wrappers->{ post } = wrap 'LWP::UserAgent::simple_request',
            post    => sub {
                my $response = $_[ -1 ];
                if ( $callbacks->{ record }) {
                    $response = $callbacks->{ record }(
                        $self->{ current_request },
                        $response
                    );

                    if ( not $response->$_isa( 'HTTP::Response' ) ) {
                        die "record callback didn't return an HTTP::Response object";
                    }
                }

                if ( $action eq 'record' ) {
                    local $Storable::Eval = 1;
                    local $Storable::Deparse = 1;

                    my $cloned = dclone {
                        request     => $self->{ current_request },
                        response    => $response
                    };

                    push @{ $self->{ actions } }, $cloned;
                }
            };
    }
}

sub finished {
    my ( $class ) = @_;

    my $action = $instance->{ action };

    if ( $action eq 'record' ) {
        local $Storable::Deparse = 1;
        local $Storable::Eval = 1;

        nstore $instance->{ actions }, $instance->{ file };
    } elsif ( $action eq 'playback' and scalar @{ $instance->{ actions } } ) {
        warn "Not all HTTP requests have been played back.  You possibly need to re-record the LWP session";
    }

    $instance->{ actions } = [];
    $instance->{ action } = 'passthrough';
    $instance->{ file } = undef;

    $instance->reset;
}

sub set_playback_callback {
    my ( $class, $cb ) = @_;

    $instance->__set_cb( playback => $cb );
}

sub set_record_callback {
    my ( $class, $cb ) = @_;

    $instance->__set_cb( record => $cb );
}

sub set_record_pre_callback {
    my ( $class, $cb ) = @_;

    $instance->__set_cb( pre_record => $cb );
}

sub set_playback_validation_callback {
    my ( $class, $cb ) = @_;

    $instance->__set_cb( playback_validation => $cb );
}

sub __set_cb {
    my ( $self, $type, $cb ) = @_;

    $self->{ callbacks }{ $type } = $cb;
}

1;

__END__