view release on metacpan or  search on metacpan

lib/Test/Ratchet.pm  view on Meta::CPAN

use strict;
use warnings;
package Test::Ratchet;

use Exporter::Easy ( OK => [ qw/ratchet clank/ ] );
use Data::Munge qw(rec);
use Scalar::Util qw(refaddr);

our $VERSION = '0.005';

# ABSTRACT: Mocking helper that swaps out implementations automatically


sub ratchet {
    my @subrefs = @_;

    my $ratchet = rec {
        my $recurse = shift;
        if (! @subrefs) {
            die "Tried to run a ratchet but there was nothing left to do!";
        }

        my $now = $subrefs[0];

        # simple scalar should be a number. Run the next item as a subref if
        # that number is not 0. If it's reached 0, shift them both off and redo.
        # Or it's an asterisk, in which case do the next subref forever.
        if (not ref $now) {
            if ($now eq '*') {
                return $subrefs[1]->(@_);
            }

            if ($now > 0) {
                $now = $subrefs[1];
                $subrefs[0]--;
                return $now->(@_);
            }
            else {
                shift @subrefs; shift @subrefs;
                # redo
                return $recurse->(@_);
            }
        }

        else {
            shift @subrefs;
        }

        $now->(@_);
    };
}


sub clank($) {
    my $subref = shift;
    my $caller = sprintf "%s, line %s", (caller)[1,2];
    my $clank = rec { my $rec = shift; delete $Test::Ratchet::Clank::CLANK{ refaddr $rec }; &$subref };
    $Test::Ratchet::Clank::CLANK{refaddr $clank} = $caller;
    bless $clank, "Test::Ratchet::Clank";
}

package Test::Ratchet::Clank;

use Scalar::Util qw(refaddr);

our %CLANK;

sub DESTROY {
    my $self = shift;
    require Test::More;
    Test::More::fail("A Clank was never run! Created at " . $CLANK{refaddr $self}) if $CLANK{ refaddr $self };
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Ratchet - Mocking helper that swaps out implementations automatically

=head1 VERSION

version 0.005

=head1 SYNOPSIS

    use Test::Ratchet qw(ratchet clank);
    use Test::MockModule;
    use Test::More;

    use Some::Module;

    my $mock = Test::MockModule->new('Some::Module');
    $mock->mock( magic_method => ratchet(
        \&first_implementation,
        \&second_implementation,

        # A clank *must* be run, or the test fails!
        clank \&third_implementation,
    ));

    # In reality, you will have no control over the use of this object - which
    # is the purpose of the module in the first place! The actual use of this
    # object would be deep in the code you are actually testing.
    my $obj = Some::Module->new;

    $obj->magic_method('foo'); # Returns { something => 'relevant' }
    $obj->magic_method('bar'); # Returns { something => 'else' }

    # This test will fail! magic_method was only run twice, but there are three
    # implementations - and the third one is a clank! Failing to run a clank