t/Exception.t

   1 # -*-Perl-*-
   2 ## Bioperl Test Harness Script for Modules
   3 ## $Id$
   4
   5 # Before `make install' is performed this script should be runnable with
   6 # `make test'. After `make install' it should work as `perl test.t'
   7
   8 my $error;
   9
  10 use strict;
  11 use lib '.';
  12 use lib './examples/root/lib';
  13
  14 BEGIN {
  15     # to handle systems with no installed Test module
  16     # we include the t dir (where a copy of Test.pm is located)
  17     # as a fallback
  18     eval { require Test; };
  19     if( $@ ) {
  20         use lib 't';
  21     }
  22     use vars qw($NTESTS $SKIPERROR);
  23     $NTESTS = 8;
  24     $error = 0;
  25
  26     use Test;
  27
  28     eval { require Error; };
  29     if( $@ ) {
  30         $NTESTS = 3;
  31         $SKIPERROR = 1;
  32     }
  33
  34     plan tests => $NTESTS;
  35 }
  36
  37 if( $error == 1 ) {
  38     exit(0);
  39 }
  40
  41 use Bio::Root::Exception;
  42 use TestObject;
  43 use Error qw(:try);
  44
  45 ok(1);
  46
  47 $Error::Debug = 1;
  48
  49 # Set up a tester object.
  50 my $test = TestObject->new();
  51
  52 ok($test);
  53
  54 ok($test->data('Eeny meeny miney moe.'), 'Eeny meeny miney moe.');
  55
  56 exit if $SKIPERROR; # bail if we don't have Error installed
  57
  58 # This demonstrates what will happen if a method defined in an
  59 # interface that is not implemented in the implementating object.
  60
  61 eval {
  62     try {
  63         $test->foo();
  64     }
  65     catch Bio::Root::NotImplemented with {
  66         my $err = shift;
  67         ok(ref $err, 'Bio::Root::NotImplemented');
  68     };
  69
  70 };
  71 if( $@ ) {
  72 #    warn($@);
  73 }
  74 # TestObject::bar() deliberately throws a Bio::TestException,
  75 # which is defined in TestObject.pm
  76 try {
  77     $test->bar;
  78 }
  79 catch Bio::TestException with {
  80     my $err = shift;
  81     ok(ref $err, 'Bio::TestException');
  82 };
  83
  84
  85 # Use the non-object-oriented syntax to throw a generic Bio::Root::Exception.
  86 try {
  87     throw Bio::Root::Exception( "A generic error", 42 );
  88 }
  89 catch Bio::Root::Exception with {
  90     my $err = shift;
  91     ok(ref $err, 'Bio::Root::Exception');
  92     ok($err->value, 42);
  93 };
  94
  95 # Try to call a subroutine that doesn't exist. But because it occurs
  96 # within a try block, the Error module will create a Error::Simple to
  97 # capture it. Handy eh?
  98
  99 if( $] >= 5.006001 ) {
 100     try {
 101         $test->foobar();
 102     }
 103     otherwise {
 104         my $err = shift;
 105         ok(ref $err, 'Error::Simple');
 106     };
 107 } else {
 108     skip("Can't run this test on perl < 5.6.1",1);
 109 }
 110