ext/threads/t/err.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9
  10     require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
  11
  12     use Config;
  13     if (! $Config{'useithreads'}) {
  14         skip_all(q/Perl not compiled with 'useithreads'/);
  15     }
  16
  17     plan(10);
  18 }
  19
  20 use ExtUtils::testlib;
  21
  22 use_ok('threads');
  23
  24 ### Start of Testing ###
  25
  26 no warnings 'threads';
  27
  28 # Create a thread that generates an error
  29 my $thr = threads->create(sub { my $x = Foo->new(); });
  30
  31 # Check that thread returns 'undef'
  32 my $result = $thr->join();
  33 ok(! defined($result), 'thread died');
  34
  35 # Check error
  36 like($thr->error(), q/Can't locate object method/, 'thread error');
  37
  38
  39 # Create a thread that 'die's with an object
  40 $thr = threads->create(sub {
  41                     threads->yield();
  42                     sleep(1);
  43                     die(bless({ error => 'bogus' }, 'Err::Class'));
  44                 });
  45
  46 my $err = $thr->error();
  47 ok(! defined($err), 'no error yet');
  48
  49 # Check that thread returns 'undef'
  50 $result = $thr->join();
  51 ok(! defined($result), 'thread died');
  52
  53 # Check that error object is retrieved
  54 $err = $thr->error();
  55 isa_ok($err, 'Err::Class', 'error object');
  56 is($err->{error}, 'bogus', 'error field');
  57
  58 # Check that another thread can reference the error object
  59 my $thrx = threads->create(sub { die(bless($thr->error(), 'Foo')); });
  60
  61 # Check that thread returns 'undef'
  62 $result = $thrx->join();
  63 ok(! defined($result), 'thread died');
  64
  65 # Check that the rethrown error object is retrieved
  66 $err = $thrx->error();
  67 isa_ok($err, 'Foo', 'error object');
  68 is($err->{error}, 'bogus', 'error field');
  69
  70 # EOF