—

              
package Test::Stream::Plugin::Mock;
use strict;
use warnings;
use Carp qw/croak/;
use Scalar::Util qw/blessed reftype weaken/;
use Test::Stream::Util qw/try/;
use Test::Stream::Workflow qw/workflow_build workflow_var has_workflow_vars/;
use Test::Stream::Mock();
use Test::Stream::Workflow::Meta();
require Test::Stream::HashBase;
use Test::Stream::Exporter qw/import default_exports exports/;
default_exports qw/mock mocked/;
exports qw{
    mock_obj mock_class
    mock_do  mock_build
    mock_accessor mock_accessors
    mock_getter   mock_getters
    mock_setter   mock_setters
    mock_building
};
no Test::Stream::Exporter;
our @CARP_NOT = (__PACKAGE__, 'Test::Stream::Mock');
my %MOCKS;
my @BUILD;
sub mock_building {
    return unless @BUILD;
    return $BUILD[-1];
}
sub mocked {
    my $proto = shift;
    my $class = blessed($proto) || $proto;
    # Check if we have any mocks.
    my $set = $MOCKS{$class} || return;
    # Remove dead mocks (undef due to weaken)
    pop @$set while @$set && !defined($set->[-1]);
    # Remove the list if it is empty
    delete $MOCKS{$class} unless @$set;
    # Return the controls (may be empty list)
    return @$set;
}
sub _delegate {
    my ($args) = @_;
    my $do    = __PACKAGE__->can('mock_do');
    my $obj   = __PACKAGE__->can('mock_obj');
    my $class = __PACKAGE__->can('mock_class');
    my $build = __PACKAGE__->can('mock_build');
    return $obj unless @$args;
    my ($proto, $arg1) = @$args;
    return $obj if ref($proto) && !blessed($proto);
    if (blessed($proto)) {
        return $class unless $proto->isa('Test::Stream::Mock');
        return $build if $arg1 && ref($arg1) && reftype($arg1) eq 'CODE';
    }
    return $class if $proto =~ m/(?:::|')/;
    return $class if $proto =~ m/^_*[A-Z]/;
    return $do if Test::Stream::Mock->can($proto);
    if (my $sub = __PACKAGE__->can("mock_$proto")) {
        shift @$args;
        return $sub;
    }
    return undef;
}
sub mock {
    croak "undef is not a valid first argument to mock()"
        if @_ && !defined($_[0]);
    my $sub = _delegate(\@_);
    croak "'$_[0]' does not look like a package name, and is not a valid control method"
        unless $sub;
    $sub->(@_);
}
sub mock_build {
    my ($control, $sub) = @_;
    croak "mock_build requires a Test::Stream::Mock object as its first argument"
        unless $control && blessed($control) && $control->isa('Test::Stream::Mock');
    croak "mock_build requires a coderef as its second argument"
        unless $sub && ref($sub) && reftype($sub) eq 'CODE';
    push @BUILD => $control;
    my ($ok, $err) = &try($sub);
    pop @BUILD;
    die $err unless $ok;
}
sub mock_do {
    my ($meth, @args) = @_;
    croak "Not currently building a mock"
        unless @BUILD;
    my $build = $BUILD[-1];
    croak "'$meth' is not a valid action for mock_do()"
        if $meth =~ m/^_/ || !$build->can($meth);
    $build->$meth(@args);
}
sub mock_obj {
    my ($proto) = @_;
    if ($proto && ref($proto) && reftype($proto) ne 'CODE') {
        shift @_;
    }
    else {
        $proto = {};
    }
    my $class = _generate_class();
    my $control;
    if (@_ == 1 && reftype($_[0]) eq 'CODE') {
        my $orig = shift @_;
        $control = mock_class(
            $class,
            sub {
                my $c = mock_building;
                # We want to do these BEFORE anything that the sub may do.
                $c->block_load(1);
                $c->purge_on_destroy(1);
                $c->autoload(1);
                $orig->(@_);
            },
        );
    }
    else {
        $control = mock_class(
            $class,
            # Do these before anything the user specified.
            block_load       => 1,
            purge_on_destroy => 1,
            autoload         => 1,
            @_,
        );
    }
    my $new = bless($proto, $control->class);
    # We need to ensure there is a reference to the control object, and we want
    # it to go away with the object.
    $new->{'~~MOCK~CONTROL~~'} = $control;
    return $new;
}
sub _generate_class {
    my $prefix = __PACKAGE__;
    for (1 .. 100) {
        my $postfix = join '', map { chr(rand(26) + 65) } 1 .. 32;
        my $class = $prefix . '::__TEMP__::' . $postfix;
        my $file = $class;
        $file =~ s{::}{/}g;
        $file .= '.pm';
        next if $INC{$file};
        my $stash = do { no strict 'refs'; \%{"${class}\::"} };
        next if keys %$stash;
        return $class;
    }
    croak "Could not generate a unique class name after 100 attempts";
}
sub mock_class {
    my $proto = shift;
    my $class = blessed($proto) || $proto;
    my @args = @_;
    my $caller = [caller(0)];
    my $void   = !defined(wantarray);
    my $build  = workflow_build();
    my $meta   = Test::Stream::Workflow::Meta->get($caller->[0]);
    croak "mock_class should not be called in a void context except in a workflow"
        unless has_workflow_vars || $build || $meta || !$void;
    my $builder = sub {
        my ($parent) = reverse mocked($class);
        my $control;
        if (@args == 1 && ref($args[0]) && reftype($args[0]) eq 'CODE') {
            $control = Test::Stream::Mock->new(class => $class);
            mock_build($control, @args);
        }
        else {
            $control = Test::Stream::Mock->new(class => $class, @args);
        }
        if ($parent) {
            $control->{parent} = $parent;
            weaken($parent->{child} = $control);
        }
        $MOCKS{$class} ||= [];
        push @{$MOCKS{$class}} => $control;
        weaken($MOCKS{$class}->[-1]);
        return $control;
    };
    return $builder->() unless $void;
    my $set_vars = sub {
        workflow_var(__PACKAGE__, sub { {} })->{$class} = $builder->();
    };
    return $set_vars->() if has_workflow_vars;
    $build ||= $meta->unit;
    my $now = $builder->();
    $build->add_post(sub { $now = undef });
    $build->add_buildup(
        Test::Stream::Workflow::Unit->new(
            name       => "Mock $class",
            package    => $caller->[0],
            file       => $caller->[1],
            start_line => $caller->[2],
            end_line   => $caller->[2],
            type       => 'single',
            primary    => $set_vars,
        ),
    );
    return;
}
sub mock_accessors {
    return map {( $_ => Test::Stream::HashBase->gen_accessor($_) )} @_;
}
sub mock_accessor {
    my ($field) = @_;
    return Test::Stream::HashBase->gen_accessor($field);
}
sub mock_getters {
    my ($prefix, @list) = @_;
    return map {( "$prefix$_" => Test::Stream::HashBase->gen_getter($_) )} @list;
}
sub mock_getter {
    my ($field) = @_;
    return Test::Stream::HashBase->gen_getter($field);
}
sub mock_setters {
    my ($prefix, @list) = @_;
    return map {( "$prefix$_" => Test::Stream::HashBase->gen_setter($_) )} @list;
}
sub mock_setter {
    my ($field) = @_;
    return Test::Stream::HashBase->gen_setter($field);
}
1;
__END__
HideShow 263 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
Test::Stream::Plugin::Mock - Class/Instance mocking for Test::Stream.
=head1 DEPRECATED
B<This distribution is deprecated> in favor of L<Test2>, L<Test2::Suite>, and
L<Test2::Workflow>.
See L<Test::Stream::Manual::ToTest2> for a conversion guide.
=head1 DESCRIPTION
Mocking is often an essential part of testing. This library covers some of the
most common mocking needs. This plugin is heavily influenced by L<Mock::Quick>,
but with an improved API. This plugin is also intended to play well with other
plugins in ways L<Mock::Quick> would be unable to.
=head1 SYNOPSIS
    my $mock = mock 'Some::Class' => (
        add => [
            new_method => sub { ... },
        ],
        override => [
            replace_method => sub { ... },
        ],
    );
    Some::Class->new_method();        # Calls the newly injected method
    Some::Class->replace_method();    # Calls our replacement method.
    $mock->override(...) # Override some more
    $mock = undef; # Undoes all the mocking, restoring all original methods.
=head1 MOCKING + SPEC TESTING
This plugin plays nicely with L<Test::Stream::Plugin::Spec>. Mocks are treated
as a C<before_each> if you use the mock functions without saving the returned
object. The mock will also apply to any describe block in which they are
defined.
    describe stuff => sub {
        # The mock specification
        mock 'My::Class' => (...);
        # Mock applies here, inside the describe block
        tests foo => sub {
            # Mock applies here inside any nested blocks, even though they run
            # later
        };
    };
    # Mock does not apply out here
=head1 EXPORTS
=head2 DEFAULT
=over 4
=item mock
This is a 1-stop shop function that delgates to one of the other methods
depending on how it is used. If you are not comfortable with a function that
has a lot of potential behaviors, you can use one of the other functions
directly.
=item $mock = mocked($object)
=item $mock = mocked($class)
Check if an object or class is mocked. If it is mocked the C<$mock> object
(L<Test::Stream::Mock>) will be returned.
=item $mock = mock $class => ( ... );
=item $mock = mock $instance => ( ... )
=item $mock = mock 'class', $class => ( ... )
These forms delegate to C<mock_class()> to mock a package. The third form is to
be explicit about what type of mocking you want.
=item $obj = mock()
=item $obj = mock { ... }
=item $obj = mock 'obj', ...;
These forms delegate to C<mock_obj()> to create instances of anonymous packages
where methods are vivified into existance as needed.
=item mock $mock => sub { ... }
=item mock $method => ( ... )
These forms go together, the first form will set C<$mock> as the current mock
build, then run the sub. Within the sub you can declare mock specifications
using the second form. The first form delgates to C<mock_build()>.
The second form calls the specified method on the current build. This second
form delgates to C<mock_do()>.
=back
=head2 BY REQUEST
=head3 DEFINING MOCKS
=over 4
=item $obj = mock_obj( ... )
=item $obj = mock_obj { ... } => ( ... )
=item $obj = mock_obj sub { ... }
=item $obj = mock_obj { ... } => sub { ... }
This method lets you quickly generate a blessed object. The object will be an
instance of a randomly generated package name. Methods will vivify as
read/write accessors as needed.
Arguments can be any method available to L<Test::Stream::Mock> followed by an
argument. If the very first argument is a hashref then it will be blessed as
your new object.
If you provide a coderef instead of key/value pairs, the coderef will be run to
build the mock. (See the L</"BUILDING MOCKS"> section).
=item $mock = mock_class $class => ( ... )
=item $mock = mock_class $instance => ( ... )
=item $mock = mock_class ... => sub { ... }
This will create a new instance of L<Test::Stream::Mock> to control the package
specified. If you give it a blessed reference it will use the class of the
instance.
Arguments can be any method available to L<Test::Stream::Mock> followed by an
argument. If the very first argument is a hashref then it will be blessed as
your new object.
If you provide a coderef instead of key/value pairs, the coderef will be run to
build the mock. (See the L</"BUILDING MOCKS"> section).
=back
=head3 BUILDING MOCKS
=over 4
=item mock_build $mock => sub { ... }
Set C<$mock> as the current build, then run the specified code. C<$mock> will
no longer be the current build when the sub is complete.
=item $mock = mock_building()
Get the current building C<$mock> object.
=item mock_do $method => $args
Run the specified method on the currently building object.
=back
=head3 METHOD GENERATORS
=over 4
=item $sub = mock_accessor $field
Generate a read/write accessor for the specified field. This will generate a sub like the following:
    $sub = sub {
        my $self = shift;
        ($self->{$field}) = @_ if @_;
        return $self->{$field};
    };
=item $sub = mock_getter $field
Generate a read obly accessor for the specified field. This will generate a sub like the following:
    $sub = sub {
        my $self = shift;
        return $self->{$field};
    };
=item $sub = mock_setter $field
Generate a write accessor for the specified field. This will generate a sub like the following:
    $sub = sub {
        my $self = shift;
        ($self->{$field}) = @_;
    };
=item %pairs = mock_accessors(qw/name1 name2 name3/)
Generates several read/write accessors at once, returns key/value pairs where
the key is the field name, and the value is the coderef.
=item %pairs = mock_getters(qw/name1 name2 name3/)
Generates several read only accessors at once, returns key/value pairs where
the key is the field name, and the value is the coderef.
=item %pairs = mock_setters(qw/name1 name2 name3/)
Generates several write accessors at once, returns key/value pairs where the
key is the field name, and the value is the coderef.
=back
=head1 MOCK CONTROL OBJECTS
    my $mock = mock(...);
Mock objects are instances of L<Test::Stream::Mock>, see it for their methods.
=head1 SOURCE
The source code repository for Test::Stream can be found at
F<http://github.com/Test-More/Test-Stream/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2015 Chad Granum E<lt>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut