comparison variant_effect_predictor/Bio/Root/Root.pm @ 0:1f6dce3d34e0

Uploaded

0:1f6dce3d34e0

package Bio::Root::Root;
use strict;

# $Id: Root.pm,v 1.30 2002/12/16 09:44:28 birney Exp $

=head1 NAME

Bio::Root::Root - Hash-based implementation of Bio::Root::RootI

=head1 SYNOPSIS

  # any bioperl or bioperl compliant object is a RootI 
  # compliant object

  # Here's how to throw and catch an exception using the eval-based syntax.

  $obj->throw("This is an exception");

  eval {
      $obj->throw("This is catching an exception");
  };

  if( $@ ) {
      print "Caught exception";
  } else {
      print "no exception";
  }

  # Alternatively, using the new typed exception syntax in the throw() call:

    $obj->throw( -class => 'Bio::Root::BadParameter',
                 -text  => "Can't open file $file",
                 -value  => $file);

  # Exceptions can be used in an eval{} block as shown above or within
  # a try{} block if you have installed the Error.pm module.
  # Here's a brief example. For more, see Bio::Root::Exception

  use Error qw(:try);

    try {
    $obj->throw(  # arguments as above );
    }
    catch Bio::Root::FileOpenException with {
        my $err = shift;
        print "Handling exception $err\n";
   };

=head1 DESCRIPTION

This is a hashref-based implementation of the Bio::Root::RootI
interface.  Most bioperl objects should inherit from this.

See the documentation for Bio::Root::RootI for most of the methods
implemented by this module.  Only overridden methods are described
here.

=head2 Throwing Exceptions

One of the functionalities that Bio::Root::RootI provides is the
ability to throw() exceptions with pretty stack traces. Bio::Root::Root
enhances this with the ability to use B<Error.pm> (available from CPAN)
if it has also been installed. 

If Error.pm has been installed, throw() will use it. This causes an
Error.pm-derived object to be thrown. This can be caught within a
C<catch{}> block, from wich you can extract useful bits of
information. If Error.pm is not installed, it will use the 
Bio::Root::RootI-based exception throwing facilty.

=head2 Typed Exception Syntax 

The typed exception syntax of throw() has the advantage of plainly
indicating the nature of the trouble, since the name of the class
is included in the title of the exception output.

To take advantage of this capability, you must specify arguments
as named parameters in the throw() call. Here are the parameters:

=over 4

=item -class

name of the class of the exception.
This should be one of the classes defined in B<Bio::Root::Exception>,
or a custom error of yours that extends one of the exceptions
defined in B<Bio::Root::Exception>.

=item -text

a sensible message for the exception

=item -value

the value causing the exception or $!, if appropriate.

=back

Note that Bio::Root::Exception does not need to be imported into
your module (or script) namespace in order to throw exceptions
via Bio::Root::Root::throw(), since Bio::Root::Root imports it.

=head2 Try-Catch-Finally Support

In addition to using an eval{} block to handle exceptions, you can
also use a try-catch-finally block structure if B<Error.pm> has been
installed in your system (available from CPAN).  See the documentation
for Error for more details.

Here's an example. See the B<Bio::Root::Exception> module for 
other pre-defined exception types:

   try {
    open( IN, $file) || $obj->throw( -class => 'Bio::Root::FileOpenException',
                                     -text => "Cannot open file $file for reading",
                                     -value => $!);
   }
   catch Bio::Root::BadParameter with {
       my $err = shift;   # get the Error object
       # Perform specific exception handling code for the FileOpenException
   }
   catch Bio::Root::Exception with {
       my $err = shift;   # get the Error object
       # Perform general exception handling code for any Bioperl exception.
   }
   otherwise {
       # A catch-all for any other type of exception
   }
   finally {
       # Any code that you want to execute regardless of whether or not
       # an exception occurred.
   };  
   # the ending semicolon is essential!


=head1 CONTACT

Functions originally from Steve Chervitz. Refactored by Ewan Birney.
Re-refactored by Lincoln Stein.

=head1 APPENDIX

The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _

=cut

#'

use vars qw(@ISA $DEBUG $ID $Revision $VERSION $VERBOSITY $ERRORLOADED);
use strict;
use Bio::Root::RootI;
use Bio::Root::IO;

@ISA = 'Bio::Root::RootI';

BEGIN { 

    $ID        = 'Bio::Root::Root';
    $VERSION   = 1.0;
    $Revision  = '$Id: Root.pm,v 1.30 2002/12/16 09:44:28 birney Exp $ ';
    $DEBUG     = 0;
    $VERBOSITY = 0;
    $ERRORLOADED = 0;

    # Check whether or not Error.pm is available.

    # $main::DONT_USE_ERROR is intended for testing purposes and also
    # when you don't want to use the Error module, even if it is installed.
    # Just put a INIT { $DONT_USE_ERROR = 1; } at the top of your script.
    if( not $main::DONT_USE_ERROR ) {
        if ( eval "require Error"  ) {
            import Error qw(:try);
            require Bio::Root::Exception;
            $ERRORLOADED = 1;
            $Error::Debug = 1; # enable verbose stack trace 
        }
    } 
    if( !$ERRORLOADED ) {
        require Carp; import Carp qw( confess );
    }    
    $main::DONT_USE_ERROR;  # so that perl -w won't warn "used only once"

}



=head2 new

 Purpose   : generic instantiation function can be overridden if 
             special needs of a module cannot be done in _initialize

=cut

sub new {
#    my ($class, %param) = @_;
    my $class = shift;
    my $self = {};
    bless $self, ref($class) || $class;

    if(@_ > 1) {
	# if the number of arguments is odd but at least 3, we'll give
	# it a try to find -verbose
	shift if @_ % 2;
	my %param = @_;
	## See "Comments" above regarding use of _rearrange().
	$self->verbose($param{'-VERBOSE'} || $param{'-verbose'});
    }
    return $self;
}

		     
=head2 verbose

 Title   : verbose
 Usage   : $self->verbose(1)
 Function: Sets verbose level for how ->warn behaves
           -1 = no warning
            0 = standard, small warning
            1 = warning with stack trace
            2 = warning becomes throw
 Returns : The current verbosity setting (integer between -1 to 2)
 Args    : -1,0,1 or 2


=cut

sub verbose {
   my ($self,$value) = @_;
   # allow one to set global verbosity flag
   return $DEBUG  if $DEBUG;
   return $VERBOSITY unless ref $self;
   
    if (defined $value || ! defined $self->{'_root_verbose'}) {
       $self->{'_root_verbose'} = $value || 0;
    }
    return $self->{'_root_verbose'};
}

sub _register_for_cleanup {
  my ($self,$method) = @_;
  if($method) {
    if(! exists($self->{'_root_cleanup_methods'})) {
      $self->{'_root_cleanup_methods'} = [];
    }
    push(@{$self->{'_root_cleanup_methods'}},$method);
  }
}

sub _unregister_for_cleanup {
  my ($self,$method) = @_;
  my @methods = grep {$_ ne $method} $self->_cleanup_methods;
  $self->{'_root_cleanup_methods'} = \@methods;
}


sub _cleanup_methods {
  my $self = shift;
  return unless ref $self && $self->isa('HASH');
  my $methods = $self->{'_root_cleanup_methods'} or return;
  @$methods;

}

=head2 throw

 Title   : throw
 Usage   : $obj->throw("throwing exception message");
           or
           $obj->throw( -class => 'Bio::Root::Exception',
                        -text  => "throwing exception message",
                        -value => $bad_value  );
 Function: Throws an exception, which, if not caught with an eval or
           a try block will provide a nice stack trace to STDERR 
           with the message.
           If Error.pm is installed, and if a -class parameter is
           provided, Error::throw will be used, throwing an error 
           of the type specified by -class.
           If Error.pm is installed and no -class parameter is provided
           (i.e., a simple string is given), A Bio::Root::Exception 
           is thrown.
 Returns : n/a
 Args    : A string giving a descriptive error message, optional
           Named parameters:
           '-class'  a string for the name of a class that derives 
                     from Error.pm, such as any of the exceptions 
                     defined in Bio::Root::Exception.
                     Default class: Bio::Root::Exception
           '-text'   a string giving a descriptive error message
           '-value'  the value causing the exception, or $! (optional)

           Thus, if only a string argument is given, and Error.pm is available,
           this is equivalent to the arguments:
                 -text  => "message",
                 -class => Bio::Root::Exception
 Comments : If Error.pm is installed, and you don't want to use it
            for some reason, you can block the use of Error.pm by
           Bio::Root::Root::throw() by defining a scalar named
           $main::DONT_USE_ERROR (define it in your main script
           and you don't need the main:: part) and setting it to 
           a true value; you must do this within a BEGIN subroutine.

=cut

#'

sub throw{
   my ($self,@args) = @_;
   
   my ( $text, $class ) = $self->_rearrange( [qw(TEXT CLASS)], @args);

   if( $ERRORLOADED ) {
#       print STDERR "  Calling Error::throw\n\n";

       # Enable re-throwing of Error objects.
       # If the error is not derived from Bio::Root::Exception, 
       # we can't guarantee that the Error's value was set properly
       # and, ipso facto, that it will be catchable from an eval{}.
       # But chances are, if you're re-throwing non-Bio::Root::Exceptions,
       # you're probably using Error::try(), not eval{}.
       # TODO: Fix the MSG: line of the re-thrown error. Has an extra line
       # containing the '----- EXCEPTION -----' banner.
       if( ref($args[0])) {
           if( $args[0]->isa('Error')) {
               my $class = ref $args[0];
               throw $class ( @args );
           } else {
               my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0];
               my $class = "Bio::Root::Exception";
               throw $class ( '-text' => $text, '-value' => $args[0] ); 
           }
       } else {
           $class ||= "Bio::Root::Exception";

   	   my %args;
	   if( @args % 2 == 0 && $args[0] =~ /^-/ ) {
	       %args = @args;
	       $args{-text} = $text;
	       $args{-object} = $self;
	   }

           throw $class ( scalar keys %args > 0 ? %args : @args ); # (%args || @args) puts %args in scalar context!
       }
   }
   else {
#       print STDERR "  Not calling Error::throw\n\n";
       $class ||= '';
       my $std = $self->stack_trace_dump();
       my $title = "------------- EXCEPTION $class -------------";
       my $footer = "\n" . '-' x CORE::length($title);
       $text ||= '';

       my $out = "\n$title\n" .
           "MSG: $text\n". $std . $footer . "\n";

       die $out;
   }
}

=head2 debug

 Title   : debug
 Usage   : $obj->debug("This is debugging output");
 Function: Prints a debugging message when verbose is > 0
 Returns : none
 Args    : message string(s) to print to STDERR

=cut

sub debug{
   my ($self,@msgs) = @_;
   
   if( $self->verbose > 0 ) { 
       print STDERR join("", @msgs);
   }   
}

=head2 _load_module

 Title   : _load_module
 Usage   : $self->_load_module("Bio::SeqIO::genbank");
 Function: Loads up (like use) the specified module at run time on demand.
 Example : 
 Returns : TRUE on success. Throws an exception upon failure.
.
 Args    : The module to load (_without_ the trailing .pm).

=cut

sub _load_module {
    my ($self, $name) = @_;
    my ($module, $load, $m);
    $module = "_<$name.pm";
    return 1 if $main::{$module};

    # untaint operation for safe web-based running (modified after a fix
    # a fix by Lincoln) HL
    if ($name !~ /^([\w:]+)$/) {
	$self->throw("$name is an illegal perl package name");
    }

    $load = "$name.pm";
    my $io = Bio::Root::IO->new();
    # catfile comes from IO
    $load = $io->catfile((split(/::/,$load)));
    eval {
        require $load;
    };
    if ( $@ ) {
        $self->throw("Failed to load module $name. ".$@);
    }
    return 1;
}


sub DESTROY {
    my $self = shift;
    my @cleanup_methods = $self->_cleanup_methods or return;
    for my $method (@cleanup_methods) {
      $method->($self);
    }
}



1;