Raw content of Bio::EnsEMBL::Utils::Exception
<![CDATA[=head1 LICENSE
Copyright (c) 1999-2009 The European Bioinformatics Institute and
Genome Research Limited. All rights reserved.
This software is distributed under a modified Apache license.
For license details, please see
/info/about/code_licence.html
=head1 CONTACT
Please email comments or questions to the public Ensembl
developers list at <ensembl-dev@ebi.ac.uk>.
Questions may also be sent to the Ensembl help desk at
<helpdesk@ensembl.org>.
=cut
=head1 NAME
Bio::EnsEMBL::Utils::Exception - Utility functions for error handling
=head1 SYNOPSIS
use Bio::EnsEMBL::Utils::Exception
qw(throw warning deprecate verbose try catch);
or to get all methods just
use Bio::EnsEMBL::Utils::Exception;
eval { throw("this is an exception with a stack trace") };
if ($@) {
print "Caught exception:\n$@";
}
# Or you can us the try/catch confortable syntax instead to deal with
# throw or die. Don't forget the ";" after the catch block. With
# this syntax, the original $@ is in $_ in the catch subroutine.
try {
throw("this is an exception with a stack trace");
}
catch { print "Caught exception:\n$_" };
# silence warnings
verbose('OFF');
warning('this is a silent warning');
#show deprecated and warning messages but not info
verbose('DEPRECATE');
warning('this is a warning');
# show all messages
verbose('ALL');
info('this is an informational message');
sub my_sub { deprecate('use other_sub() instead') }
verbose('EXCEPTION');
info( 'This is a high priority info message.', 1000 );
=head1 DESCRIPTION
This is derived from the Bio::Root module in BioPerl. Some formatting
has been changed and the deprecate function has been added. Most
notably the object methods are now static class methods that can be
called without inheriting from Bio::Root or Bio::EnsEMBL::Root. This is
especially useful for throwing exceptions with stack traces outside of a
blessed context.
The originaly implementations of these methods were by Steve Chervitz
and refactored by Ewan Birney.
It is recommended that these functions be used instead of inheriting
unnecessarily from the Bio::EnsEMBL::Root or Bio::Root object. The
functions exported by this package provide a set of useful error
handling methods.
=head1 METHODS
=cut
package Bio::EnsEMBL::Utils::Exception;
use strict;
use warnings;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(throw warning stack_trace_dump
stack_trace verbose deprecate info try catch);
my $VERBOSITY = 3000;
my $DEFAULT_INFO = 4000;
my $DEFAULT_DEPRECATE = 3000;
my $DEFAULT_WARNING = 2000;
my $DEFAULT_EXCEPTION = 1000;
=head2 throw
Arg [1] : string $msg
Arg [2] : (optional) int $level
override the default level of exception throwing
Example : use Bio::EnsEMBL::Utils::Exception qw(throw);
throw('We have a problem');
Description: Throws an exception which if not caught by an eval will
provide a stack trace to STDERR and die. If the verbosity level
is lower than the level of the throw, then no error message is
displayed but the program will still die (unless the exception
is caught).
Returntype : none
Exceptions : thrown every time
Caller : generally on error
=cut
sub throw {
my $string = shift;
#for backwards compatibility with Bio::EnsEMBL::Root::throw
#allow to be called as an object method as well as class method
#Root function now deprecated so call will have the string instead.
$string = shift if(ref($string)); #skip object if one provided
$string = shift if($string eq "Bio::EnsEMBL::Utils::Exception");
my $level = shift;
$level = $DEFAULT_EXCEPTION if(!defined($level));
if($VERBOSITY < $level) {
die("\n"); #still die, but silently
}
my $std = stack_trace_dump(3);
my $out = "\n-------------------- EXCEPTION --------------------\n" .
"MSG: $string\n" .
"$std" .
"---------------------------------------------------\n";
die $out;
}
=head2 warning
Arg [1] : string warning(message);
Arg [2] : (optional) int level
Override the default level of this warning changning the level
of verbosity at which it is displayed.
Example : use Bio::EnsEMBL::Utils::Exception qw(warning)
warning('This is a warning');
Description: If the verbosity level is higher or equal to the level of this
warning then a warning message is printed to STDERR. If the
verbosity lower then nothing is done. Under the default
levels of warning and verbosity warnings will be displayed.
Returntype : none
Exceptions : warning every time
Caller : general
=cut
sub warning {
my $string = shift;
$string = shift if($string eq "Bio::EnsEMBL::Utils::Exception"); #skip object if one provided
my $level = shift;
$level = $DEFAULT_WARNING if(!defined($level));
return if ($VERBOSITY < $level);
my @caller = caller;
my $line = $caller[2] || '';
#use only 2 subdirs for brevity when reporting the filename
my $file;
my @path = split(/\//, $caller[1]);
$file = pop(@path);
my $i = 0;
while(@path && $i < 2) {
$i++;
$file = pop(@path) ."/$file";
}
@caller = caller(1);
my $caller_line;
my $caller_file;
$i=0;
if(@caller) {
@path = split(/\//, $caller[1]);
$caller_line = $caller[2];
$caller_file = pop(@path);
while(@path && $i < 2) {
$i++;
$caller_file = pop(@path) ."/$caller_file";
}
}
my $out = "\n-------------------- WARNING ----------------------\n".
"MSG: $string\n".
"FILE: $file LINE: $line\n";
$out .= "CALLED BY: $caller_file LINE: $caller_line\n" if($caller_file);
$out .= "---------------------------------------------------\n";
print STDERR $out;
}
=head2 info
Arg [1] : string $string
The message to be displayed
Arg [2] : (optional) int $level
Override the default level of this message so it is displayed at
a different level of verbosity than it normally would be.
Example : use Bio::EnsEMBL::Utils::Exception qw(verbose info)
Description: This prints an info message to STDERR if verbosity is higher
than the level of the message. By default info messages are not
displayed.
Returntype : none
Exceptions : none
Caller : general
=cut
sub info {
my $string = shift;
$string = shift if($string eq "Bio::EnsEMBL::Utils::Exception");
my $level = shift;
$level = $DEFAULT_INFO if(!defined($level));
return if($VERBOSITY < $level);
print STDERR "INFO: $string\n";
}
=head2 verbose
Arg [1] : (optional) int
Example : use Bio::EnsEMBL::Utils::Exception qw(verbose warning);
#turn warnings and everything more important on (e.g. exception)
verbose('WARNING');
warning("Warning displayed");
info("This won't be displayed");
deprecate("This won't be diplayed");
#turn exception messages on
verbose('EXCEPTION');
warning("This won't do anything");
throw("Die with a message");
#turn everying off
verbose('OFF'); #same as verbose(0);
warning("This won't do anything");
throw("Die silently without a message");
#turn on all messages
verbose('ALL');
info("All messages are now displayed");
if(verbose() > 3000) {
print "Verbosity is pretty high";
}
Description: Gets/Sets verbosity level which defines which messages are
to be displayed. An integer value may be passed or one of the
following strings:
'OFF' (= 0)
'EXCEPTION' (= 1000)
'WARNING' (= 2000)
'DEPRECATE' (= 3000)
'INFO' (= 4000)
'ALL' (= 1000000)
Returntype : int
Exceptions : none
Caller : general
=cut
sub verbose {
if(@_) {
my $verbosity = shift;
$verbosity = shift if($verbosity eq "Bio::EnsEMBL::Utils::Exception");
if($verbosity =~ /\d+/) { #check if verbosity is an integer
$VERBOSITY = $verbosity;
} else {
$verbosity = uc($verbosity);
if($verbosity eq 'OFF' || $verbosity eq 'NOTHING' ||
$verbosity eq 'NONE') {
$VERBOSITY = 0;
} elsif($verbosity eq 'EXCEPTION' || $verbosity eq 'THROW') {
$VERBOSITY = $DEFAULT_EXCEPTION;
} elsif($verbosity eq 'WARNING' || $verbosity eq 'WARN') {
$VERBOSITY = $DEFAULT_WARNING;
} elsif($verbosity eq 'DEPRECATE' || $verbosity eq 'DEPRECATED') {
$VERBOSITY = $DEFAULT_DEPRECATE;
} elsif($verbosity eq 'INFO') {
$VERBOSITY = $DEFAULT_INFO;
} elsif($verbosity eq 'ON' || $verbosity eq 'ALL') {
$VERBOSITY = 1e6;
} else {
$VERBOSITY = $DEFAULT_WARNING;
warning("Unknown level of verbosity: $verbosity");
}
}
}
return $VERBOSITY;
}
=head2 stack_trace_dump
Arg [1] : (optional) int $levels
The number of levels to ignore from the top of the stack when
creating the dump. This is useful when this is called internally
from a warning or throw function when the immediate caller and
stack_trace_dump function calls are themselves uninteresting.
Example : use Bio::EnsEMBL::Utils::Exception qw(stack_trace_dump);
print STDERR stack_trace_dump();
Description: Returns a stack trace formatted as a string
Returntype : string
Exceptions : none
Caller : general, throw, warning
=cut
sub stack_trace_dump{
my @stack = stack_trace();
my $levels = 2; #default is 2 levels so stack_trace_dump call is not present
$levels = shift if(@_);
$levels = shift if($levels eq "Bio::EnsEMBL::Utils::Exception");
$levels = 1 if($levels < 1);
while($levels) {
$levels--;
shift @stack;
}
my $out;
my ($module,$function,$file,$position);
foreach my $stack ( @stack) {
($module,$file,$position,$function) = @{$stack};
$out .= "STACK $function $file:$position\n";
}
return $out;
}
=head2 stack_trace
Arg [1] : none
Example : use Bio::EnsEMBL::Utils::Exception qw(stack_trace)
Description: Gives an array to a reference of arrays with stack trace info
each coming from the caller(stack_number) call
Returntype : array of listrefs of strings
Exceptions : none
Caller : general, stack_trace_dump()
=cut
sub stack_trace {
my $i = 0;
my @out;
my $prev;
while ( my @call = caller($i++)) {
# major annoyance that caller puts caller context as
# function name. Hence some monkeying around...
$prev->[3] = $call[3];
push(@out,$prev);
$prev = \@call;
}
$prev->[3] = 'toplevel';
push(@out,$prev);
return @out;
}
=head2 deprecate
Arg [1] : string $mesg
A message describing why a method is deprecated
Example : use Bio::EnsEMBL::Utils::Exception qw(deprecate)
sub old_sub {
deprecate('Please use new_sub() instead');
}
Description: Prints a warning to STDERR that the method which called
deprecate() is deprecated. Also prints the line number and
file from which the deprecated method was called. Deprecated
warnings only appear once for each location the method was
called from. No message is displayed if the level of verbosity
is lower than the level of the warning.
Returntype : none
Exceptions : warning every time
Caller : deprecated methods
=cut
my %DEPRECATED;
sub deprecate {
my $mesg = shift;
$mesg = shift if($mesg eq "Bio::EnsEMBL::Utils::Exception"); #skip object if one provided
my $level = shift;
$level = $DEFAULT_DEPRECATE if(!defined($level));
return if($VERBOSITY < $level);
my @caller = caller(1);
my $subname = $caller[3] ;
my $line = $caller[2];
#use only 2 subdirs for brevity when reporting the filename
my $file;
my @path = $caller[1];
$file = pop(@path);
my $i = 0;
while(@path && $i < 2) {
$i++;
$file .= pop(@path);
}
#keep track of who called this method so that the warning is only displayed
#once per deprecated call
return if $DEPRECATED{"$line:$file:$subname"};
if($VERBOSITY > -1) {
print STDERR "\n------------------ DEPRECATED ---------------------\n" .
"Deprecated method call in file $file line $line.\n" .
"Method $subname is deprecated.\n" .
"$mesg\n" .
"---------------------------------------------------\n";
}
$DEPRECATED{"$line:$file:$subname"} = 1;
}
=head2 try/catch
Arg [1] : anonymous subroutine
the block to be tried
Arg [2] : return value of the catch function
Example : use Bio::EnsEMBL::Utils::Exception qw(throw try catch)
The syntax is:
try { block1 } catch { block2 };
{ block1 } is the 1st argument
catch { block2 } is the 2nd argument
e.g.
try {
throw("this is an exception with a stack trace");
} catch {
print "Caught exception:\n$_";
};
In block2, $_ is assigned the value of the first
throw or die statement executed in block 1.
Description: Replaces the classical syntax
eval { block1 };
if ($@) { block2 }
by a more confortable one.
In the try/catch syntax, the original $@ is in $_ in the catch subroutine.
This try/catch implementation is a copy and paste from
"Programming Perl" 3rd Edition, July 2000, by L.Wall, T. Christiansen
& J. Orwant. p227, and is only possible because of subroutine prototypes.
Returntype : depend on what is implemented the try or catch block
Exceptions : none
Caller : general
=cut
sub try (&$) {
my ($try, $catch) = @_;
eval { &$try };
if ($@) {
chop $@;
local $_ = $@;
&$catch;
}
}
sub catch (&) {
shift;
}
1;
]]>