IMAKADO::BLOG

Amonでctx_request

perl, Amon

Ark::Test や Catalyst::Test でおなじみの ctx_request をつかってテストを書く必要があったので書いてみました.

Data::Util or Moose を使う程ではないと思ったので, ベタっといった感じ.俺はそんな感じ.

正しい実装ではない可能性があることを断っておきます.

package Amon::Test::WWW::Mechanize::PSGI;
use parent 'Test::WWW::Mechanize::PSGI';
use strict;
use warnings;

our $VERSION = '0.01';

use Clone::PP qw/clone/;

sub ctx_request {
    my $self = shift;

    amon_install_context_getter();

    my $res = $self->request(@_);

    return $res, amon_context();
}

my $_amon_installed;
sub amon_install_context_getter {

    return if $_amon_installed;

    no strict 'refs';
    no warnings 'redefine';
    do {
        my $orig = *{'Amon::Web::Response::finalize'}{CODE};
        *{'Amon::Web::Response::finalize'} = sub {

            my @r;
            if (!defined wantarray) {
                $orig->(@_);
            }
            elsif (wantarray) {
                @r = $orig->(@_);
            }
            else {
                $r[0] = $orig->(@_);
            }

            amon_context(Amon->context);

            return wantarray ? @r : $r[0];
        };
    };
    do {
        my $orig = *{'Amon::Web::run'}{CODE};
        *{'Amon::Web::run'} = sub {

            my @r;
            if (!defined wantarray) {
                $orig->(@_);
            }
            elsif (wantarray) {
                @r = $orig->(@_);
            }
            else {
                $r[0] = $orig->(@_);
            }

            $Amon::_context = amon_context();

            return wantarray ? @r : $r[0];
        };
    };

    $_amon_installed = 1;
}

do {
    my $context;
    sub amon_context {
        if ($_[0]) {
            $context = $_[0];
            $context  = clone($context);
        }
        $context;
    }
};

1;
__END__

次のテストは通る。

use strict;
use warnings;
use Test::More;
use TestApp::Web;
use Amon::Test::WWW::Mechanize::PSGI;
use HTTP::Request::Common;

my $app = TestApp::Web->to_app;
my $mech = Amon::Test::WWW::Mechanize::PSGI->new(app => $app);

my ($ret, $c) = $mech->ctx_request(GET '/');

isa_ok $ret, 'HTTP::Response';

use Amon::Web::Declare;
isa_ok( c(), 'Amon::Web' );
isa_ok $c, 'Amon::Web';
isa_ok( Amon->context, 'Amon::Web' );
is_deeply( $c, Amon->context );

isa_ok $c->request, 'Amon::Web::Request';
isa_ok( Amon->context->request, 'Amon::Web::Request' );

is_deeply( Amon->context->pnotes, +{} );
is_deeply $c->pnotes, +{};

($ret, $c) = $mech->ctx_request(POST '/', { foo => 'bar' });

isa_ok $ret, 'HTTP::Response';
isa_ok $c, 'Amon::Web';

is $c->request->param_decoded('foo'), 'bar', 'param_decoded';
is param_decoded('foo'), 'bar', 'param_decoded';

done_testing;

Permalink | コメント(0) | トラックバック(0) | 03:44