view release on metacpan or  search on metacpan

lib/Bio/EnsEMBL/Utils/Exception.pm  view on Meta::CPAN

  my $std = stack_trace_dump(3);

  my $out = sprintf(
             "\n" .
             "-------------------- EXCEPTION --------------------\n" .
             "MSG: %s\n" .
             "%s" .
             "Date (localtime)    = %s\n" .
             "Ensembl API version = %s\n" .
             "---------------------------------------------------\n",
             $string, $std, scalar( localtime() ), software_version() );

  die($out);
} ## end sub throw



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

  # See throw() for this:
  $string = shift if ( ref($string) );    # Skip object if one provided.
  $string = shift if ( $string eq "Bio::EnsEMBL::Utils::Exception" );

  my $level = shift;
  $level = $DEFAULT_WARNING if ( !defined($level) );

  return if ( $VERBOSITY < $level );

  my @caller = caller;
  my $line = $caller[2] || '';

  # Use only two sub-dirs for brevity when reporting the file name.
  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 =
    sprintf( "\n" .
             "-------------------- WARNING ----------------------\n" .
             "MSG: %s\n" .
             "FILE: %s LINE: %d\n",
             $string, $file, $line );

  if ( defined($caller_file) ) {
    $out .= sprintf( "CALLED BY: %s  LINE: %d\n", $caller_file,
                     $caller_line );
  }
  $out .= sprintf(
           "Date (localtime)    = %s\n" .
           "Ensembl API version = %s\n" .
           "---------------------------------------------------\n",
           scalar( localtime() ), software_version() );

  warn($out);

} ## end sub warning



=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));

lib/Bio/EnsEMBL/Utils/Exception.pm  view on Meta::CPAN

      } 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"
      . "Ensembl API version = "
      . software_version() . "\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