Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment