Bio::Root Root
SummaryIncluded librariesPackage variablesSynopsisDescriptionGeneral documentationMethods
Toolbar
WebCvs
Summary
Bio::Root::Root - Hash-based implementation of Bio::Root::RootI
Package variables
Privates (from "my" definitions)
($self, $orig, $level) = @_
$reftype = Scalar::Util::reftype($orig) || ''
$data;
$class = Scalar::Util::blessed($orig) || ''
Included modules
Bio::Root::IO
Scalar::Util qw ( blessed reftype )
Inherit
Bio::Root::RootI
Synopsis
  # Any 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 not open file $file",
               -value  => $file );

  # Want to see debug() outputs for this object

  my $obj = Bio::Object->new(-verbose=>1);

  my $obj = Bio::Object->new(%args);
  $obj->verbose(2);

  # Print debug messages which honour current verbosity setting

  $obj->debug("Boring output only to be seen if verbose > 0\n");

  # Deep-object copy

  my $clone = $obj->clone;
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. 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 Error (available from CPAN)
if it has also been installed.
If Error has been installed, throw() will use it. This causes an
Error.pm-derived object to be thrown. This can be caught within a
catch{} block, from wich you can extract useful bits of
information. If Error is not installed, it will use the
Bio::Root::RootI-based exception throwing facilty. 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:
    -class
    name of the class of the exception.
This should be one of the classes defined in Bio::Root::Exception,
or a custom error of yours that extends one of the exceptions
defined in Bio::Root::Exception.
    -text
    a sensible message for the exception
    -value
    the value causing the exception or $!, if appropriate.
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. In addition to using an eval{} block to handle exceptions, you can
also use a try-catch-finally block structure if Error has been
installed in your system (available from CPAN). See the documentation
for Error for more details.
Here's an example. See the 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!
Methods
BEGIN Code
newDescriptionCode
cloneDescriptionCode
verboseDescriptionCode
_register_for_cleanup
No description
Code
_unregister_for_cleanup
No description
Code
_cleanup_methods
No description
Code
throwDescriptionCode
debugDescriptionCode
_load_moduleDescriptionCode
DESTROY
No description
Code
Methods description
newcode    nextTop
 Purpose   : generic instantiation function can be overridden if
             special needs of a module cannot be done in _initialize
clonecodeprevnextTop
 Title   : clone
 Usage   : my $clone = $obj->clone();
           or
           my $clone = $obj->clone( -start => 110 );
 Function: Deep recursion copying of any object via Storable dclone()
 Returns : A cloned object.
 Args    : Any named parameters provided will be set on the new object.
           Unnamed parameters are ignored.
 Comments: Where possible, faster clone methods are used, in order:
           Clone::Fast::clone(), Clone::clone(), Storable::dclone.  If neither
           is present, a pure perl fallback (not very well tested) is used
           instead. Storable dclone() cannot clone CODE references.  Therefore,
           any CODE reference in your original object will remain, but will not
           exist in the cloned object.  This should not be used for anything
           other than cloning of simple objects. Developers of subclasses are
           encouraged to override this method with one of their own.
verbosecodeprevnextTop
 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
throwcodeprevnextTop
 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.
debugcodeprevnextTop
 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
_load_modulecodeprevnextTop
 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).
Methods code
BEGINTop
BEGIN {
    $ID        = 'Bio::Root::Root';
    $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 );
    }

    # set up _dclone()
    for my $class (qw(Clone::Fast Clone Storable)) {
        eval "require $class; 1;";
        if (!$@) {
            $CLONE_CLASS = $class;
            if ($class eq 'Clone::Fast') {
                *Bio::Root::Root::_dclone = sub {shift; return Clone::Fast::clone(shift)};
            } elsif ($class eq 'Clone') {
                *Bio::Root::Root::_dclone = sub {shift; return Clone::clone(shift)};
            } else {
                *Bio::Root::Root::_dclone = sub {shift; return Storable::dclone(shift)};
}
newdescriptionprevnextTop
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;
}
clonedescriptionprevnextTop
sub clone {
    my ($orig, %named_params) = @_;

    __PACKAGE__->throw("Can't call clone() as a class method") unless
        ref $orig && $orig->isa('Bio::Root::Root');

    # Can't dclone CODE references...
    # Should we shallow copy these? Should be harmless for these specific
    # methods...

    my %put_these_back = (
       _root_cleanup_methods => $orig->{'_root_cleanup_methods'},
    );
    delete $orig->{_root_cleanup_methods};

    # call the proper clone method, set lazily above
    my $clone = __PACKAGE__->_dclone($orig);

    $orig->{_root_cleanup_methods} = $put_these_back{_root_cleanup_methods};

    foreach my $key (grep { /^-/ } keys %named_params) {
        my $method = $key;
        $method =~ s/^-//;
        if ($clone->can($method)) {
            $clone->$method($named_params{$key})
        } else {
            $orig->warn("Parameter $method is not a method for ".ref($clone));
        }
    }
    return $clone;
}
verbosedescriptionprevnextTop
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'};
}
_register_for_cleanupdescriptionprevnextTop
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);
    }
}
_unregister_for_cleanupdescriptionprevnextTop
sub _unregister_for_cleanup {
    my ($self,$method) = @_;
    my @methods = grep {$_ ne $method} $self->_cleanup_methods;
    $self->{'_root_cleanup_methods'} =\@ methods;
}
_cleanup_methodsdescriptionprevnextTop
sub _cleanup_methods {
    my $self = shift;
    return unless ref $self && $self->isa('HASH');
    my $methods = $self->{'_root_cleanup_methods'} or return;
    @$methods;
}
throwdescriptionprevnextTop
sub throw {
    my ($self, @args) = @_;

    my ($text, $class, $value) = $self->_rearrange( [qw(TEXT
                                                        CLASS
                                                        VALUE)], @args);
    $text ||= $args[0] if @args == 1;

    if ($ERRORLOADED) {
        # 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];
                $class->throw( @args );
            }
            else {
                my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0];
                my $class = "Bio::Root::Exception";
                $class->throw( '-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;
            }

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

        die "\n$title\n", "MSG: $text\n", $std, $footer, "\n";
    }
}
debugdescriptionprevnextTop
sub debug {
    my ($self, @msgs) = @_;
    # using CORE::warn doesn't give correct backtrace information; we want the
    # line from the previous call in the call stack, not this call (similar to
    # cluck).  For now, just add a stack trace dump and simple comment under the
    # correct conditions.
    if (defined $self->verbose && $self->verbose > 0) {
        if (!@msgs || $msgs[-1] !~ /\n$/) {
            push @msgs, "Debugging comment:" if !@msgs;
            push @msgs, sprintf("%s %s:%s", @{($self->stack_trace)[2]}[3,1,2])."\n";
        }
        CORE::warn @msgs;
    }
}
_load_moduledescriptionprevnextTop
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 by Lincoln) HL
    if ($name !~ /^([\w:]+)$/) {
        $self->throw("$name is an illegal perl package name");
    } else {
        $name = $1;
    }

    $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;
}
DESTROYdescriptionprevnextTop
sub DESTROY {
    my $self = shift;
    my @cleanup_methods = $self->_cleanup_methods or return;
    for my $method (@cleanup_methods) {
        $method->($self);
    }
}

1;
}
General documentation
FEEDBACKTop
Mailing ListsTop
User feedback is an integral part of the evolution of this
and other Bioperl modules. Send your comments and suggestions preferably
to one of the Bioperl mailing lists.
Your participation is much appreciated.
  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
SupportTop
Please direct usage questions or support issues to the mailing list:
bioperl-l@bioperl.org
rather than to the module maintainer directly. Many experienced and
reponsive experts will be able look at the problem and quickly
address it. Please include a thorough description of the problem
with code and data examples if at all possible.
Reporting BugsTop
Report bugs to the Bioperl bug tracking system to help us keep track
the bugs and their resolution. Bug reports can be submitted via the
web:
  https://redmine.open-bio.org/projects/bioperl/
AUTHORTop
Functions originally from Steve Chervitz.
Refactored by Ewan Birney.
Re-refactored by Lincoln Stein.
APPENDIXTop
The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _
_dcloneTop
 Title   : clone
 Usage   : my $clone = $obj->_dclone($ref);
           or
           my $clone = $obj->_dclone($ref);
 Function: Returns a copy of the object passed to it (a deep clone)
 Returns : clone of passed argument
 Args    : Anything
 NOTE    : This differs from clone significantly in that it does not clone
           self, but the data passed to it.  This code may need to be optimized
           or overridden as needed.
 Comments: This is set in the BEGIN block to take advantage of optimized
           cloning methods if Clone or Storable is present, falling back to a
           pure perl kludge. May be moved into a set of modules if the need
           arises. At the moment, code ref cloning is not supported.