Учим Test::Class контролировать зависшие тесты

Есть такой популярный модуль Test::Class -  реализация xUnit для Perl.

Довольно удачная реализация - есть все или почти все, что требуется для xUnit-фреймворка.

TestSuite можно описать с помощью класса (пакета) например так (код не постеснялся скопипастить прямо с cpan):

  package Example::Test;
  use base qw(Test::Class);
  use Test::More;

  # setup methods are run before every test method. 
  sub make_fixture : Test(setup) {
      my $array = [1, 2];
      shift->{test_array} = $array;
  };

  # a test method that runs 1 test
  sub test_push : Test {
      my $array = shift->{test_array};
      push @$array, 3;
      is_deeply($array, [1, 2, 3], 'push worked');
  };

  # a test method that runs 4 tests
  sub test_pop : Test(4) {
      my $array = shift->{test_array};
      is(pop @$array, 2, 'pop = 2');
      is(pop @$array, 1, 'pop = 1');
      is_deeply($array, [], 'array empty');
      is(pop @$array, undef, 'pop = undef');
  };

  # teardown methods are run after every test method.
  sub teardown : Test(teardown) {
      my $array = shift->{test_array};
      diag("array = (@$array) after test(s)");
  };

Вот только контролировать продолжительность тестов по таймауту этот фреймворк не умеет.

Чтобы решить эту проблему, не поручая такой контроль каким бы то ни было внешним утилитам, можно воспользоваться возможностями ООП и fork примерно так:

package TTL::Test::Class; use base qw(Test::Class); use Test::More; use POSIX ":sys_wait_h"; use constant DEFAULT_TIMEOUT => 60; # переопределяем метод запуска тестов sub runtests{ my $t = DEFAULT_TIMEOUT; my $pid = fork; my $child_ret_code; if( $pid > 0 ){ # parent process #child waiting loop my $ok_flag = 0; for(my $i=0; $i < $t; $i++){ if(waitpid($pid, WNOHANG)){ $child_ret_code = $?/256; ok($child_ret_code); $ok_flag = 1; last; }; sleep(1); }; if( not $ok_flag ){ diag "Killing test by its timetolive..."; kill TERM => $pid; return $ok_flag; }; return $child_ret_code; } elsif( $pid == 0 ) { #child exit $self->SUPER::runtests; } elsif ( not defined($pid) ) { #unsuccessfull fork die "Cannot fork child process: $!"; } } 1;

далее в сьюте меняем базовый класс на наш:

#use base qw(Test::Class);
use base qw(TTL::Test::Class);

Теперь каждый сьют будет принудительно завершен через нужный нам таймаут.
Мораль сей басни такова (с),  никакой готовый фреймфорк полностью не удовлетворит всем возможным нуждам при конкретном его применении.
Поэтому можно и нужно допиливать и улучшать.