PerlとDBIxでトランザクションのテストをするときに注意したいこと

複数のテーブルを操作するときトランザクションを貼る必要がありますよね？？
そこでよくTest::Mock::Guardなどのモジュールを使って
擬似的にエラーを吐かせたりするんですが、ちょっと詰まったとこがあったのでここにメモしておきます。

下の関数はとあるスキーマのレコードを2つ渡すとそのname属性を"c"と"d"に変更してくれるなんともクソみたいな関数です。
面倒臭かったので引数でエラーの制御をしちゃってます(ちゃんとTest::Mock::Guardモジュールを使いましょう！！)

#!/usr/bin/env perl

use strict;
use warnings;

use utf8;

use MySchema;

use Test::More;

run_test() if $ENV{ HARNESS_ACTIVE };

sub update_a_and_b {
  my ( $schema, $a, $b, $is_occurred ) = @_;

  $schema->txn_do( sub {
      $a->update( { name => 'c' } );
      die if $is_occurred;
      $b->update( { name => 'd' } );
    } );

  return;
}

sub run_test {
  my $schema = MySchema->connect(
    'DBI:mysql:database=my_schema;host=localhost;',
    'username',
    'password'
  ) or die 'Can not connect database $!';

  # Create tables with Result classes.
  # "add_drop_table" option is executing "drop table" at beforehand.
  $schema->deploy( {
      add_drop_table => 1,
    } );

  my $my_table_rs = $schema->resultset( 'MyTable' );

  note( 'Not occurred error in transction.' );
  {
    my $a = $my_table_rs->find_or_create( { name => 'a' } );
    my $b = $my_table_rs->find_or_create( { name => 'b' } );

    eval{ update_a_and_b( $schema, $a, $b, 0 ) };
    note( "Error: $@" ) if $@;

    is( $a->name, 'c' );
    is( $b->name, 'd' );
  }

  note( 'Not occurred error in transction.' );
  {
    my $a = $my_table_rs->find_or_create( { name => 'a' } );
    my $b = $my_table_rs->find_or_create( { name => 'b' } );

    eval{ update_a_and_b( $schema, $a, $b, 1 ) };
    note( "Error: $@" ) if $@;

    is( $a->name, 'a' );
    is( $b->name, 'b' );
  }

  done_testing;

  return;
}

一見、2回目のupdate_a_and_b関数でエラーが発生し、更新されていたaのname属性がロールバックされそうです。
それではテストを実行してみましょう。

akata:^_^[~/perl/dbix-transaction]$ prove -Ilib -v main.pl
main.pl ..
# Not occurred error in transction.
ok 1
ok 2
# Not occurred error in transction.
# Error: DBIx::Class::Schema::txn_do(): Died at main.pl line 21.
not ok 3

#   Failed test at main.pl line 64.
#          got: 'c'
#     expected: 'a'
ok 4
1..4
# Looks like you failed 1 test of 4.
Dubious, test returned 1 (wstat 256, 0x100)
Failed 1/4 subtests

Test Summary Report
-------------------
main.pl (Wstat: 256 Tests: 4 Failed: 1)
  Failed test:  3
  Non-zero exit status: 1
Files=1, Tests=4,  0 wallclock secs ( 0.02 usr  0.01 sys +  0.15 cusr  0.05 csys =  0.23 CPU)
Result: FAIL

はい、エラー

実はDBのデータはちゃんとロールバックされるのですが、Resultオブジェクトのカラムは元に戻らないみたいなんですよね・・
なので、テストを行う前にきちんとデータをDBから引っ張ってきましょう。
データの取得はdiscard_changesメソッドで簡単にできます。

こうかな？？

  note( 'Not occurred error in transction.' );
  {
    my $a = $my_table_rs->find_or_create( { name => 'a' } );
    my $b = $my_table_rs->find_or_create( { name => 'b' } );

    eval{ update_a_and_b( $schema, $a, $b, 1 ) };
    note( "Error: $@" ) if $@;
    $a->discard_changes;

    is( $a->name, 'a' );
    is( $b->name, 'b' );
  }

こっちのほうがいいかな？？

sub update_a_and_b {
  my ( $schema, $a, $b, $is_occurred ) = @_;

  # use Try::Tinyすること
  try {
    $schema->txn_do( sub {
        $a->update( { name => 'c' } );
        die if $is_occurred;
        $b->update( { name => 'd' } );
      } );
  } catch {
    $a->discard_changes;
    $b->discard_changes;
  };

  return;
}

テスト以前に、後々処理が続く機能(そもそもそういうのはいいのか？？)のことを考えたら、
個人的には下かな〜と思うのですが、一応どちらでもテストは通りますよ。

akata:^_^[~]$ prove -Ilib -v main.pl
main.pl ..
# Not occurred error in transction.
ok 1
ok 2
# Not occurred error in transction.
ok 3
ok 4
1..4
ok
All tests successful.
Files=1, Tests=4,  1 wallclock secs ( 0.02 usr  0.00 sys +  0.18 cusr  0.04 csys =  0.24 CPU)
Result: PASS

あと、たまにロールバックされる前にテストが呼ばれることもあったので、
きちんとロールバックされているか確認したほうがいいかもしれません。