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;
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__

=pod

=encoding UTF-8

=head1 NAME

Test::Stream::Plugin::Mock - Class/Instance mocking for Test::Stream.

=head1 EXPERIMENTAL CODE WARNING

B<This is an experimental release!> Test-Stream, and all its components are
still in an experimental phase. This dist has been released to cpan in order to
allow testers and early adopters the chance to write experimental new tools
with it, or to add experimental support for it into old tools.

B<PLEASE DO NOT COMPLETELY CONVERT OLD TOOLS YET>. This experimental release is
very likely to see a lot of code churn. API's may break at any time.
Test-Stream should NOT be depended on by any toolchain level tools until the
experimental phase is over.

=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://www.perl.com/perl/misc/Artistic.html>

=cut
