examples/root/exceptions1.pl

   1 #!/usr/bin/env perl
   2
   3 # A simple tester script for demonstrating how to throw and catch
   4 # Error.pm objects. It also shows how to define new types of
   5 # Error.pm-based objects.
   6 #
   7 # It relies on the tester modules TestObject.pm and TestInterface.pm
   8 # which you should also look at.
   9 #
  10 # Note that Bio::Root::NotImplemented is a subclass of Error.pm
  11 # and is defined in Bio::Root::Exception.pm
  12 #
  13 # This code requires Graham Barr's Error.pm module available from CPAN.
  14 #
  15 # Author: Steve Chervitz <sac@bioperl.org>
  16 #
  17
  18 use strict;
  19 use lib qw(lib/ ../../);
  20 use Error qw(:try);
  21 use TestObject;
  22 use Getopt::Long;
  23
  24 # Command-line options:
  25 my $eg = 0;        # which example to run (a number 1-4)
  26 my $help = 0;      # print usage info
  27
  28 # $Error::Debug is set to true by default in Bio::Root::Interface.
  29 $Error::Debug = 1; # enables verbose stack trace
  30
  31 GetOptions( "debug!" => \$Error::Debug,
  32             "eg=s"   => \$eg,
  33             "h"      => \$help
  34           );
  35
  36 my $options = << "OPTS";
  37       -eg  1|2|3|4   Run a particular example
  38       -nodebug       Deactivate verbose stacktrace
  39       -h             Print this usage
  40 OPTS
  41
  42 (!$eg || $help) and die "Usage: $0 -eg 1|2|3|4 [-nodebug] [-h]\nOptions:\n$options";
  43
  44 print $Error::Debug ? "Try a -nodebug option to supress stack trace." : "Verbose stacktrace off.";
  45 print "\n\n";
  46
  47 # Set up a tester object.
  48 my $test = TestObject->new();
  49 $test->data('Eeny meeny miney moe.');
  50
  51 try {
  52
  53     test_notimplemented( $test ) if $eg == 1;
  54
  55     test_custom_error( $test ) if $eg == 2;
  56
  57     test_simple_error() if $eg == 3;
  58
  59     # This subroutine doesn't even exist. But because it occurs within a try block,
  60     # the Error module will create a Error::Simple to capture it. Handy eh?
  61     if(  $eg == 4 ) {
  62         print "Test #4: Calling an undefined subroutine.\n";
  63         test_foobar();
  64     }
  65
  66     # We shouldn't see this stuff.
  67     print "----\n";
  68     print "----\n";
  69     print "Some other code within the try block after the last throw...\n";
  70     print "----\n";
  71     print "----\n";
  72 }
  73
  74 # Multiple catch blocks to handle different types of errors:
  75
  76 catch Bio::Root::NotImplemented with {
  77     my $error = shift;
  78     print "\nCaught a Bio::Root::NotImplemented.\n",
  79       "  file  : ", $error->file, "\n",
  80       "  line  : ", $error->line, "\n",
  81       "  text  : ", $error->text, "\n",
  82       "  value : ", $error->value, "\n",
  83       "  object: ", ref($error->object), "\n";
  84
  85     print "\nstacktrace:\n", $error->stacktrace, "\n";
  86
  87     print "\nstringify:\n$error\n";
  88     # The above line is equivalent to this:
  89     #print "\nstringify:\n", $error->stringify, "\n";
  90 }
  91
  92 catch Bio::TestException with {
  93     # Since we know what type of error we're getting,
  94     # we can extract more information about the offending object
  95     # which is retrievable from the error object.
  96     my $error = shift;
  97     print "\nCaught a Bio::TestException.\n",
  98       "  file  : ", $error->file, "\n",
  99       "  line  : ", $error->line, "\n",
 100       "  text  : ", $error->text, "\n",
 101       "  value : ", $error->value, "\n",
 102       "  object: ", ref($error->object), "\n",
 103       "  data  : ", $error->object->data, "\n";
 104
 105     print "\nstacktrace:\n", $error->stacktrace, "\n";
 106     print "\nstringify:\n", $error->stringify, "\n";
 107
 108 }
 109
 110 otherwise {
 111     # This is a catch-all handler for any type of error not handled above.
 112     my $error = shift;
 113     print "\nCaught an other type of error: ", ref($error), "\n",
 114       "  file  : ", $error->file, "\n",
 115       "  line  : ", $error->line, "\n",
 116       "  text  : ", $error->text, "\n",
 117       "  value : ", $error->value, "\n",
 118       "  object: ", ref($error->object), "\n";
 119
 120 #    print "\nstack_trace_dump:\n", $error->stack_trace_dump(), "\n";
 121
 122     print "\nstacktrace:\n", $error->stacktrace, "\n";
 123
 124     print "\nstringify:\n$error\n";
 125
 126 };  # This semicolon is essential.
 127
 128 print "\nDone $0\n";
 129
 130 sub test_notimplemented {
 131
 132     my $test = shift;
 133     # This demonstrates what will happen if a method defined in an interface
 134     # that is not implemented in the implementating object.
 135
 136     print "Test #1: Inducing a Bio::Root::NotImplemented exception from TestObject\n";
 137
 138     $test->foo();
 139 }
 140
 141
 142 sub test_custom_error {
 143
 144     my $test = shift;
 145
 146     # TestObject::bar() deliberately throws a Bio::TestException,
 147     # which is defined in TestObject.pm
 148
 149     print "Test #2: Throwing a Bio::TestException exception from TestObject\n";
 150
 151     $test->bar;
 152
 153 }
 154
 155
 156 sub test_simple_error {
 157
 158     # Error::Simple comes with Error.pm and can have only a string and a value.
 159
 160     print "Test #3: Throwing a Error::Simple object\n";
 161
 162     throw Error::Simple( "A simple error", 42 );
 163 }
 164
 165