Exception.pm

# EnsEMBL module for Bio::EnsEMBL::Utils::Exception
#
#

=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 CONTACT

Post questions to the EnsEMBL development list: ensembl-dev@ebi.ac.uk

=head1 METHODS

The rest of the documentation details exported static class methods. 

=cut

use strict;
use warnings;

package Bio::EnsEMBL::Utils::Exception;

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;