副作用関数のユニットテスト

ユニットテストの自動化で困るのが副作用を起こすコード。例えば、ファイルのI/Oを含む関数は自動テスト化に少し悩む。

# hoge.pl
use strict;
use warnings;

package HOGE;
use IO::File;

main(@ARGV) if ($0 eq __FILE__);

# テストしたい関数
sub main {
  my (@args) = @_;
  return 1 unless (@args >= 2);
  return 2 unless defined( my $io = IO::File->new($args[0], 'w') );
  unless ( defined $io->print($args[1]. "\n") ) {
    $io->close;
    return 3
  };
  return 4 unless defined $io->close;
  return 0;
}
1;

この場合、テストドライバから"use lib"でモジュール参照先を変更してIO::Fileを強制的にテストスタブにしてやれば良い。

# テストドライバ
use strict;
use warnings;

use Test::More tests => 3;

use lib 'test';    # モジュール読込先を"test/"に変更する
require 'hoge.pl'; # テスト対象
use IO::File;      # テストスタブ

{  # test-1
  IO::File->init();
  my $r = HOGE::main('out.txt', 'aiueo');

  my $ok_define = [0, [
    "called IO::File::new out.txt w", 
    "called IO::File::print aiueo\n", 
    "called IO::File::close", ]];
  my @op = IO::File->get_operations();
  is_deeply([$r, \@op], $ok_define, "test-1");  # 評価
}

{  # test-2
  IO::File->init();
  IO::File->set_return("IO::File::print", undef);
  my $r = HOGE::main('out2.txt', 'hoge');

  my $ok_define = [3, [
    "called IO::File::new out2.txt w", 
    "called IO::File::print hoge\n", 
    "called IO::File::close", ]];
  my @op = IO::File->get_operations();
  is_deeply([$r, \@op], $ok_define, "test-2");  # 評価
}

{  # test-3
  IO::File->init();
  my $r = HOGE::main();

  my $ok_define = [1, []];
  my @op = IO::File->get_operations();
  is_deeply([$r, \@op], $ok_define, "test-3");  # 評価
}

テスト対象からはテストスタブが呼ばれる。

1..3
ok 1 - test-1
ok 2 - test-2
ok 3 - test-3

テストスタブはこんな感じに実装した。

# テストスタブ - test/IO/File.pm
use strict;
use warnings;

package IO::File;
use base qw(Exporter);

{
  my (@operations, %rets);
  sub init { @operations = %rets = (); }
  sub get_operations { @operations }    # 呼び出されたメソッド
  sub set_return {
    my ($this, $method, $return) = @_;  # メソッドの戻り値
    $rets{$method} = $return;
  }

  sub new {
    my ($class, $path, $mode) = @_;
    my $me = (caller 0)[3];
    push @operations, join " ", ('called', $me, $path, $mode);
    exists $rets{$me} ? $rets{$me} : bless {}, $class;
  }

  sub print {
    my ($this, $text) = @_;
    my $me = (caller 0)[3];
    push @operations, join " ", ('called', $me, $text);
    exists $rets{$me} ? $rets{$me} : (0==0);
  }

  sub close {
    my ($this) = @_;
    my $me = (caller 0)[3];
    push @operations, join " ", ('called', $me);
    exists $rets{$me} ? $rets{$me} : (0==0);
  }
}
1;

応急処置なので結局は設計を改善したほうが良い。