catalyst-mock-testing-higherorder.t

use strict;
use warnings;

use Test::More;
use Test::Exception;

use Moose ();
use Moose::Object;
use Class::MOP::Class;
use Catalyst::Request;
use Catalyst::Response;
use Catalyst::Utils;

my $mock_ctx_meta = Class::MOP::Class->create_anon_class( superclasses => ['Moose::Object'] );
$mock_ctx_meta->add_attribute('stash', accessor => 'stash', required => 1, default => sub { {} });
$mock_ctx_meta->add_around_method_modifier( stash => sub { # Nicked straight from Catalyst.pm 
    my $orig = shift;
    my $c = shift;
    my $stash = $orig->($c);
    if (@_) {
        my $new_stash = @_ > 1 ? {@_} : $_[0];
        croak('stash takes a hash or hashref') unless ref $new_stash;
        foreach my $key ( keys %$new_stash ) {
          $stash->{$key} = $new_stash->{$key};
        }
    }
    return $stash;
});
$mock_ctx_meta->add_attribute($_, accessor => $_, required => 1) for qw/request response/;

{
    my $ctx = $mock_ctx_meta->new_object;
    ok $ctx;
    $ctx->stash->{foo} = 'bar';
    is_deeply $ctx->stash, { foo => 'bar' };
    $ctx->stash(baz => 'quux');
    is_deeply $ctx->stash, { foo => 'bar', baz => 'quux' };
}

our $ctx_gen = sub {
    my ($cb, $stash) = @_;
    $stash ||= {};
    my $ctx = $mock_ctx_meta->new_object(
        response => Catalyst::Response->new,
        request => Catalyst::Request->new,
        stash => { %$stash }, # Shallow copy to try and help the user out. Should we clone?
    );
    $ctx->response->_context($ctx);
    $ctx->request->_context($ctx);
    $cb->($ctx) if $cb;
    return $ctx;
};

{
    my $ctx = $ctx_gen->(undef, { foo => 'bar' });
    ok $ctx;
    $ctx->stash->{baz} = 'quux';
    is_deeply $ctx->stash, { foo => 'bar', baz => 'quux' };
}

{
    my $ctx = $ctx_gen->(sub { shift->request->header('Allow', 'application/json') });
    is $ctx->request->header('Allow'), 'application/json';
}

my $curry_ctx_gen = sub {
    my ($ctx_gen, $cb, $stash) = @_;
    sub {
        my ($later_cb, $stash_rhs) = @_;
        my $ctx = $ctx_gen->($cb, Catalyst::Utils::merge_hashes($stash, $stash_rhs));
        $later_cb->($ctx) if $later_cb;
        return $ctx;
    };
};

{
    local $ctx_gen = $curry_ctx_gen->(
        $ctx_gen,
        sub {
            $_[0]->request->header('X-Set-First', 1);
            $_[0]->request->header('X-Set-Second', 1);
        },
        { foo => 'baz', bar => 'quux' },
    );
    # Note that the stuff curried in should happen _before_ the stuff in the ctx you get back
    my $ctx = $ctx_gen->(
        sub { shift->request->header('X-Set-First', 2) },
        { foo => 'quux', frob => 'fnoo' }
    );

    is_deeply $ctx->stash, { foo => 'quux', bar => 'quux', frob => 'fnoo' };
    is $ctx->request->header('X-Set-First'), 2;
    is $ctx->request->header('X-Set-Second'), 1;
    
    # And lets take our already curried ctx generator and curry it again.
    {
        local $ctx_gen = $curry_ctx_gen->(
            $ctx_gen,
            sub { shift->request->header('X-Set-Second', 2) },
            { bar => 'fnoo' },
        );

        # This is where we get powerful. Lets wrap some tests up in a function..
        my $combine_tests = sub {
            my @tests = @_;
            sub {
                my $ctx = shift;
                foreach my $t (@tests) {
                    $t->($ctx);
                }
            };
        };
        
        my $some_tests = sub {
            my $ctx = shift;
            is_deeply $ctx->stash, { foo => 'baz', bar => 'fnoo' };
            is $ctx->request->header('X-Set-First'), 1;
        };
        my $some_more_tests = sub {
            my $ctx = shift;
            is $ctx->request->header('X-Set-Second'), 2;
        };
        
        # And run a combined set of tests against a context
        $combine_tests->($some_tests, $some_more_tests)->($ctx_gen->()); 
    }
}

done_testing;