Hatena::ブログ(Diary)

Yet Another Hackadelic

2011-03-08 Forgot it.

Test::Mock::Guard Released

さっき nekokak さんと xaicron さんにそそのかされて Test::Mock::Guard ってモジュールを書いてみました。

そもそも Perl には Test::MockObject と言う汎用の Mock モジュールがあるんですけど、あれこれ余計な機能がたくさんついてたり Mock 化すると多分元に戻せないと言うのがあってもっとシンプルな奴がほしいなと思って作ってみた次第です。SYSNOPSIS のコピペですけど、

use Test::More;
use Test::Mock::Guard qw(mock_guard);

package Some::Class;

sub new { bless {} => shift }
sub foo { "foo" }
sub bar { 1; }

package main;

{
  ### このスコープでは Mock 化されてる
  my $guard = mock_guard( 'Some::Class', +{ foo => sub { "bar" }, bar => 10 } );
  my $obj = Some::Class->new;
  is( $obj->foo, "bar" );
  is( $obj->bar, 10 );
}

### ブロックを抜けると元に戻る
my $obj = Some::Class->new;
is( $obj->foo, "foo" );
is( $obj->bar, 1 );

done_testing;

って感じに書く事が出来ます。下位モジュールがよしなにテストされているとして、それを呼び出すモジュールのテストなんかを書く場合、意図的に下位モジュールの挙動をコントロールしながら書きたいケースがあると思います。

例えば、

package AKB48::Fun;

sub buy_dvd {
  ### 何か色々やる
}

package Hidek;

sub purge_stress {
  AKD48::Fun->buy_dvd;
}

的な感じになっていて、AKB48::Fun モジュールは十分テストされているとすれば、

subtest "buy dvd is success" => sub {
  my $mock_guard = mock_guard( 'AKB48::Fun', +{
    buy_dvd => sub {
      return +{ title => "【特典生写真付き】ここにいたこと(初回限定盤)", price => 3500 },
    }
  } );

  ### テスト書く
};

subtest "buy dvd is failed" => sub {
  my $mock_guard = mock_guard( 'AKB48::Fun', +{
    buy_dvd => sub {
      croak "現金が足りません!カードで支払って下さい";
    },
  } );

  ### テスト書く
};

みたいな感じの事が出来ますよと。

使いどころを適切に選べば Mock を使ったテストはとても有効だと思うのでぜひお試し下さいませ。かしこ。

2010-03-30

MySQL Replication with Test::mysqld

やってみたかったからついやってみた。

#!/usr/bin/perl
 
use strict;
use warnings;
 
use Data::Dump qw(dump);
use DBI;
use Test::More;
use Test::Exception;
use Test::mysqld;
use Test::TCP;
 
sub setup_master {
 
# http://dev.mysql.com/doc/refman/5.1/en/replication-howto-masterbaseconfig.html
    my $mysqld = Test::mysqld->new(
        auto_start => 2,
        mysqld     => '/usr/sbin/mysqld',
        my_cnf     => +{
            'port'      => empty_port(),
            'log-bin'   => 'mysql-bin',
            'server-id' => 1,
        },
    ) or die($Test::mysqld::errstr);
 
    note( $mysqld->dsn );
 
    # http://dev.mysql.com/doc/refman/5.1/en/replication-howto-repuser.html
    my $dbh = DBI->connect( $mysqld->dsn, 'root', '' );
    $dbh->do(
        sprintf(
            q|CREATE USER '%s'@'%s' IDENTIFIED BY '%s'|,
            'repl', '127.0.0.1', 'replpass'
        )
    ) or die( $dbh->errstr );
    $dbh->do(
        sprintf(
            q|GRANT REPLICATION SLAVE ON *.* TO '%s'@'%s'|,
            'repl', '127.0.0.1'
        )
    ) or die( $dbh->errstr );
 
    return $mysqld;
}
 
sub setup_slave {
    my $master_mysqld = shift;
 
 # http://dev.mysql.com/doc/refman/5.1/en/replication-howto-slavebaseconfig.html
    my $mysqld = Test::mysqld->new(
        auto_start => 2,
        mysqld     => '/usr/sbin/mysqld',
        my_cnf     => +{
            'port'      => empty_port(),
            'server-id' => 2,
        },
    ) or die($Test::mysqld::errstr);
 
    note( $mysqld->dsn );
 
    my $dbh_master = DBI->connect( $master_mysqld->dsn, 'root', '' );
 
    my $master_status = $dbh_master->selectrow_hashref( 'SHOW MASTER STATUS' );
 
    my $dbh = DBI->connect( $mysqld->dsn, 'root', '' );
 
    # http://dev.mysql.com/doc/refman/5.1/en/replication-howto-slaveinit.html
    $dbh->do(
        sprintf(
q|CHANGE MASTER TO MASTER_HOST='%s', MASTER_PORT=%d, MASTER_USER='%s', MASTER_PASSWORD='%s', MASTER_LOG_FILE='%s', MASTER_LOG_POS=%d|,
            '127.0.0.1', $master_mysqld->my_cnf->{port},
            'repl', 'replpass', $master_status->{File}, $master_status->{Position},
        )
    );
    $dbh->do(q|START SLAVE|);
 
    note(
        explain(
            $dbh->selectall_arrayref( 'SHOW SLAVE STATUS', +{ Slice => +{} } )
        )
    );
 
    return $mysqld;
}
 
my $master_mysqld;
 
lives_ok(
    sub {
        $master_mysqld = setup_master;
    },
    'setup_master() is success'
);
 
my $slave_mysqld;
 
lives_ok(
    sub {
        $slave_mysqld = setup_slave($master_mysqld);
    },
    'setup_slave() is success'
);
 
my $dbh_master =
  DBI->connect( $master_mysqld->dsn, 'root', '',
    +{ RaiseError => 1, AutoCommit => 0, } );
 
isa_ok( $dbh_master, 'DBI::db' );
 
$dbh_master->do(q|CREATE DATABASE hidek|) or die($dbh_master->errstr);
$dbh_master->do(q|USE hidek|) or die($dbh_master->errstr);
$dbh_master->do(
q|CREATE TABLE hidek ( id int not null primary key auto_increment, name varchar(32) ) ENGINE=InnoDB|
) or die($dbh_master->errstr);
$dbh_master->do( q|INSERT INTO hidek(name) VALUES(?)|, undef, 'yakatabune' ) or die($dbh_master->errstr);
$dbh_master->commit or die($dbh_master->errstr);
 
note( explain( $dbh_master->selectall_arrayref(q|SHOW DATABASES|) ) );
 
sleep 10;
 
my $dbh_slave =
  DBI->connect( $slave_mysqld->dsn, 'root', '',
    +{ RaiseError => 1, AutoCommit => 0, } );
 
note( explain( $dbh_slave->selectall_arrayref(q|SHOW DATABASES|) ) );
$dbh_slave->do(q|USE hidek|);
note( explain( $dbh_slave->selectall_arrayref(q|SHOW TABLES|) ) );
note( explain( $dbh_slave->selectall_arrayref(q|SELECT * FROM hidek|) ) );
 
done_testing;

要約すると my.cnf で言うところの mysqld で設定出来る内容なら何でも出来ると思って良いと。

2009-03-19

DBD::Mock を使ったテスト

DBD::Mock は DBI のドライバの一つで、DBI を使ったプログラムで意図的な状態を作る事が出来ます。

と言う訳でメモ程度に書いて行きます。

データベースハンドルの取得

use strict;
use warnings;

use Test::More;
use DBI;

plan tests => 3;

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1 });

ok($dbh, 'Create database handle');
isa_ok($dbh, 'DBI:db');
is($dbh->{Driver}->{Name}, 'Mock', 'Driver information');

で、普通に Database Handle が取れます。

SELECT してる箇所

事前に mock_add_resultset を定義しておくと任意の resultset を返す事が出来ます。

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use DBI;

plan tests => 2;

my @records = (
    [1, 'zigorou'],
    [2, 'kazuho'],
    [3, 'yappo'],
    [4, 'tokuhirom'],
    [5, 'hidek'],
    [6, 'typester'],
);

my %user_data = (
    sql     => q|SELECT user_id, nickname FROM user_data WHERE user_status = ?|,
    results => [
        [qw/user_id nickname/],
        @records,
    ],
);

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, });
$dbh->{mock_add_resultset} = \%user_data;

my $sth = $dbh->prepare($user_data{sql});
isa_ok($sth, 'DBI::st');
$sth->execute(1);
is_deeply($sth->fetchall_arrayref, \@records, 'resultset');

INSERT, UPDATE, DELETE とか

$sth->rows で返って来る件数を指定するのも mock_add_resultset で定義出来ます。

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use DBI;

plan tests => 2;

my %user_data = (
    sql     => q|INSERT INTO user_data(nickname) VALUES(?)|,
    results => [
        [qw/rows/],
        [],
    ],
);

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, });
$dbh->{mock_add_resultset} = \%user_data;

my $sth = $dbh->prepare($user_data{sql});
isa_ok($sth, 'DBI::st');
$sth->execute('zigorou');
is_deeply($sth->rows, 1, 'affected rows');
$dbh->commit;

追記1 (2009-03-25T17:23:01+09:00)

DBI::connect(), DBI::st->prepare(), DBI::st->execute() でわざと失敗する例

use Test::More;
use Test::Exception;
use Carp;
use DBI;

plan tests => 9;

my $drh = DBI->install_driver('Mock');
isa_ok($drh, 'DBI::dr');

dies_ok(
    sub {
        local $drh->{mock_connect_fail} = 1;
        my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, }) || croak(q|Cannot connect mock database|);
    }, 'mock_connect_fail on'
);

lives_ok(
    sub {
        local $drh->{mock_connect_fail} = 0;
        my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, }) || croak(q|Cannot connect mock database|);
    }, 'mock_connect_fail off'
);

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, }) || croak(q|Cannot connect mock database|);

isa_ok($dbh, 'DBI::db');

lives_ok(
    sub {
        local $dbh->{mock_can_prepare} = 1;
        my $sth = $dbh->prepare(q|SELECT * FROM foo;|);
    },
    'mock_can_prepare on'
);

dies_ok(
    sub {
        local $dbh->{mock_can_prepare} = 0;
        my $sth = $dbh->prepare(q|SELECT * FROM foo;|);
    },
    'mock_can_prepare off'
);

my $sth = $dbh->prepare(q|SELECT * FROM foo;|);

isa_ok($sth, 'DBI::st');

lives_ok(
    sub {
        local $dbh->{mock_can_execute} = 1;
        $sth->execute();
    },
    'mock_can_execute on'
);

dies_ok(
    sub {
        local $dbh->{mock_can_execute} = 0;
        $sth->execute();
    },
    'mock_can_execute off'
);

まとめ

とりあえず上手い事、データベース処理を差し替えてあげて DBD::Mock のデータベースハンドルを作ってやって、外側から resultset を定義してあげたりすると、いい感じでテストを実行出来ます。

また他にも様々な機能を持っていて、意図的に commit 失敗とかそういう状況を作れるみたいなので、網羅的にテストする事が可能だと思います。

SEE ALSO

2009-03-11

Test::Mock::LWP を試す

久しぶりのエントリです。一応元気にやってますよっと。

ここまでのあらすじ

同僚の id:typomaster さんから、Test::Mock::LWP を使ってテスト書きたいんだけど〜と言われたので早速軽く試してみましたよ。

Test::Mock::LWP とは

具体的には、

  • LWP::UserAgent
  • HTTP::Request
  • HTTP::Response

モジュールに対して Test::MockObject 化した物だと考えて良い。それぞれ、

  • Test::Mock::LWP::UserAgent
  • Test::Mock::HTTP::Request
  • Test::Mock::HTTP::Response

モジュールが対応しています。それぞれソースは短いので実際に見てみましょう。

Test::Mock::HTTP::Request
package Test::Mock::HTTP::Request;
use strict;
use warnings;
use Test::MockObject;
use base 'Exporter';
our @EXPORT = qw($Mock_req $Mock_request);

our $Mock_req;
our $Mock_request;

our $VERSION = '0.01';

BEGIN {
    $Mock_request = $Mock_req = Test::MockObject->new;
    $Mock_req->fake_module('HTTP::Request', 
        new => sub { $Mock_req->{new_args} = [@_]; $Mock_req });                       
}                                                                          
$Mock_req->set_always('authorization_basic', '');
$Mock_req->set_always('header', '');
$Mock_req->set_always('content', '');

sub new { $Mock_req };
$Mock_req->mock('-new_args', sub { delete $Mock_req->{new_args} });

package HTTP::Request;

our $VERSION = 'Mocked';

まぁすぐ分かるけど、$Mock_req, $Mock_request ってのは同じ値として Test::MockObject のインスタンスが代入されていて、HTTP::Request を fake しますよと。new した時は new_args フィールドに配列リファレンスとして引数を格納します。

set_always ってのは指定したメソッドの戻り値のデフォをどうするかって話。

Test::Mock::HTTP::Response

こいつも Request と大体似たような感じ

package Test::Mock::HTTP::Response;
use strict;
use warnings;
use Test::MockObject;
use base 'Exporter';
our @EXPORT = qw($Mock_resp $Mock_response);

our $Mock_resp;
our $Mock_response;

our $VERSION = '0.01';

BEGIN {
    $Mock_response = $Mock_resp = Test::MockObject->new;
    $Mock_resp->fake_module('HTTP::Response');                       
    $Mock_resp->fake_new('HTTP::Response');
}                                                                          

our %Headers;
$Mock_resp->mock('header', sub { return $Headers{$_[1]} });
$Mock_resp->set_always('code', 200);
$Mock_resp->set_always('content', '');
$Mock_resp->set_always('is_success', 1);

package HTTP::Response;

our $VERSION = 'Mocked';

さっきと大体同じだったんだけど、今回は new しても引数を格納したりはしない。our %Headers を上手く使えばレスポンスヘッダとかのアクセサを簡単に定義できて、後は初期値は 200 OK なんですね。で、is_success は 1 を返すと。

Test::Mock::LWP::UserAgent
package Test::Mock::LWP::UserAgent;
use strict;
use warnings;
use Test::MockObject;
use Test::Mock::HTTP::Response;
use Test::Mock::HTTP::Request;
use base 'Exporter';
our @EXPORT = qw($Mock_ua);

our $Mock_ua;

our $VERSION = '0.01';

BEGIN {
    $Mock_ua = Test::MockObject->new;
    $Mock_ua->fake_module('LWP::UserAgent');                       
    $Mock_ua->fake_new('LWP::UserAgent');
}                                                                          

$Mock_ua->set_always('simple_request', HTTP::Response->new);
$Mock_ua->set_always('request', HTTP::Response->new);

package LWP::UserAgent;
use strict;
use warnings;

our $VERSION = 'Mocked';

見る限り、request, simple_request しか定義してないので、他のメソッド等使いたい場合は自分で何とかします。

Sample

なんかありがちな処理をテストにしてみよう。

use Test::More;
use Test::Mock::LWP;
use Test::Mock::HTTP::Response;

use LWP::UserAgent;
use HTTP::Request;
use HTTP::Response;

plan tests => 6;

$Mock_request->set_isa('HTTP::Request');
$Mock_response->set_isa('HTTP::Response');
$Mock_ua->set_isa('LWP::UserAgent');

$Mock_response->mock( content => sub {
    return << 'CONTENT';
He should write blog entry as soon as posibble.
CONTENT
} );

%Test::Mock::HTTP::Response::Headers = (
    'Content-Type' => 'text/plain',
);

my $req = HTTP::Request->new(GET => 'http://example.com/');

isa_ok($req, 'HTTP::Request');

my $ua  = LWP::UserAgent->new;

isa_ok($ua, 'LWP::UserAgent');

my $res = $ua->request($req);

isa_ok($res, 'HTTP::Response');

ok($res->is_success, 'is request() success');
is($res->code, 200, 'status code');
is($res->header('Content-Type'), 'text/plain', 'match Content-Type header');

note($res->content);

試しに実行してみると、

$ prove -vc --timer typomaster.t
[00:48:32] typomaster.t ..
1..5
ok 1 - The object isa HTTP::Request
ok 2 - The object isa LWP::UserAgent
ok 3 - The object isa HTTP::Response
ok 4 - is request() success?
ok 5 - status code
# He should write blog entry as soon as posibble.
ok      228 ms
[00:48:33]
All tests successful.
Files=1, Tests=5,  1 wallclock secs ( 0.05 usr  0.09 sys +  0.17 cusr  0.06 csys =  0.37 CPU)
Result: PASS

みたいになる。

ちなみに LWP 使ってる既存のコードにも Test::Mock::LWP を使ったテストを組み込む事が出来ます。また挙動を色々再現する上で Test::MockObject の使い方は何となく知ってた方が良いと思います。

とりあえず手軽に使えるよと。

まとめ

  • 経緯はともかく、叩いてる箇所だけ埋めればいいので基本的にお手軽
  • 但し裏を返せば多少複雑な事をやってる際にはそれが仇になるかも
    • Test::HTTP::Server::Simple とかと使い分けるといいかも

とりあえず、ブログちゃんと書いてください > id:typomaster