1package Bio::Root::Root; 2$Bio::Root::Root::VERSION = '1.7.7'; 3use strict; 4use Bio::Root::IO; 5use Scalar::Util qw(blessed reftype); 6use base qw(Bio::Root::RootI); 7 8=head1 NAME 9 10Bio::Root::Root - implementation of Bio::Root::RootI interface 11 12=head1 SYNOPSIS 13 14 # Any Bioperl-compliant object is a RootI compliant object 15 16 # Here's how to throw and catch an exception using the eval-based syntax. 17 18 $obj->throw("This is an exception"); 19 20 eval { 21 $obj->throw("This is catching an exception"); 22 }; 23 24 if( $@ ) { 25 print "Caught exception"; 26 } else { 27 print "no exception"; 28 } 29 30 # Alternatively, using the new typed exception syntax in the throw() call: 31 32 $obj->throw( -class => 'Bio::Root::BadParameter', 33 -text => "Can not open file $file", 34 -value => $file ); 35 36 # Want to see debug() outputs for this object 37 38 my $obj = Bio::Object->new(-verbose=>1); 39 40 my $obj = Bio::Object->new(%args); 41 $obj->verbose(2); 42 43 # Print debug messages which honour current verbosity setting 44 45 $obj->debug("Boring output only to be seen if verbose > 0\n"); 46 47 # Deep-object copy 48 49 my $clone = $obj->clone; 50 51=head1 DESCRIPTION 52 53This is a hashref-based implementation of the Bio::Root::RootI 54interface. Most Bioperl objects should inherit from this. 55 56See the documentation for L<Bio::Root::RootI> for most of the methods 57implemented by this module. Only overridden methods are described 58here. 59 60=head2 Throwing Exceptions 61 62One of the functionalities that L<Bio::Root::RootI> provides is the 63ability to L<throw>() exceptions with pretty stack traces. Bio::Root::Root 64enhances this with the ability to use L<Error> (available from CPAN) 65if it has also been installed. 66 67If L<Error> has been installed, L<throw>() will use it. This causes an 68Error.pm-derived object to be thrown. This can be caught within a 69C<catch{}> block, from which you can extract useful bits of 70information. If L<Error> is not installed, it will use the 71L<Bio::Root::RootI>-based exception throwing facilty. 72 73=head2 Typed Exception Syntax 74 75The typed exception syntax of L<throw>() has the advantage of plainly 76indicating the nature of the trouble, since the name of the class 77is included in the title of the exception output. 78 79To take advantage of this capability, you must specify arguments 80as named parameters in the L<throw>() call. Here are the parameters: 81 82=over 4 83 84=item -class 85 86name of the class of the exception. 87This should be one of the classes defined in L<Bio::Root::Exception>, 88or a custom error of yours that extends one of the exceptions 89defined in L<Bio::Root::Exception>. 90 91=item -text 92 93a sensible message for the exception 94 95=item -value 96 97the value causing the exception or $!, if appropriate. 98 99=back 100 101Note that Bio::Root::Exception does not need to be imported into 102your module (or script) namespace in order to throw exceptions 103via Bio::Root::Root::throw(), since Bio::Root::Root imports it. 104 105=head2 Try-Catch-Finally Support 106 107In addition to using an eval{} block to handle exceptions, you can 108also use a try-catch-finally block structure if L<Error> has been 109installed in your system (available from CPAN). See the documentation 110for Error for more details. 111 112Here's an example. See the L<Bio::Root::Exception> module for 113other pre-defined exception types: 114 115 my $IN; 116 try { 117 open $IN, '<', $file or $obj->throw( -class => 'Bio::Root::FileOpenException', 118 -text => "Cannot read file '$file'", 119 -value => $!); 120 } 121 catch Bio::Root::BadParameter with { 122 my $err = shift; # get the Error object 123 # Perform specific exception handling code for the FileOpenException 124 } 125 catch Bio::Root::Exception with { 126 my $err = shift; # get the Error object 127 # Perform general exception handling code for any Bioperl exception. 128 } 129 otherwise { 130 # A catch-all for any other type of exception 131 } 132 finally { 133 # Any code that you want to execute regardless of whether or not 134 # an exception occurred. 135 }; 136 # the ending semicolon is essential! 137 138=head1 AUTHOR Steve Chervitz 139 140Ewan Birney, Lincoln Stein 141 142=cut 143 144our ($DEBUG, $ID, $VERBOSITY, $ERRORLOADED, $CLONE_CLASS); 145 146BEGIN { 147 $ID = 'Bio::Root::Root'; 148 $DEBUG = 0; 149 $VERBOSITY = 0; 150 $ERRORLOADED = 0; 151 152 # Check whether or not Error.pm is available. 153 154 # $main::DONT_USE_ERROR is intended for testing purposes and also 155 # when you don't want to use the Error module, even if it is installed. 156 # Just put a INIT { $DONT_USE_ERROR = 1; } at the top of your script. 157 if( not $main::DONT_USE_ERROR ) { 158 if ( eval "require Error; 1;" ) { 159 import Error qw(:try); 160 require Bio::Root::Exception; 161 $ERRORLOADED = 1; 162 $Error::Debug = 1; # enable verbose stack trace 163 } 164 } 165 if( !$ERRORLOADED ) { 166 require Carp; import Carp qw( confess ); 167 } 168 169 # set up _dclone() 170 for my $class (qw(Clone Storable)) { 171 eval "require $class; 1;"; 172 if (!$@) { 173 $CLONE_CLASS = $class; 174 if ($class eq 'Clone') { 175 *Bio::Root::Root::_dclone = sub {shift; return Clone::clone(shift)}; 176 } else { 177 *Bio::Root::Root::_dclone = sub { 178 shift; 179 local $Storable::Deparse = 1; 180 local $Storable::Eval = 1; 181 return Storable::dclone(shift); 182 }; 183 } 184 last; 185 } 186 } 187 if (!defined $CLONE_CLASS) { 188 *Bio::Root::Root::_dclone = sub { 189 my ($self, $orig, $level) = @_; 190 my $class = Scalar::Util::blessed($orig) || ''; 191 my $reftype = Scalar::Util::reftype($orig) || ''; 192 my $data; 193 if (!$reftype) { 194 $data = $orig 195 } elsif ($reftype eq "ARRAY") { 196 $data = [map $self->_dclone($_), @$orig]; 197 } elsif ($reftype eq "HASH") { 198 $data = { map { $_ => $self->_dclone($orig->{$_}) } keys %$orig }; 199 } elsif ($reftype eq 'CODE') { # nothing, maybe shallow copy? 200 $self->throw("Code reference cloning not supported; install Clone or Storable from CPAN"); 201 } else { $self->throw("What type is $_?")} 202 if ($class) { 203 bless $data, $class; 204 } 205 $data; 206 } 207 } 208 209 $main::DONT_USE_ERROR; # so that perl -w won't warn "used only once" 210} 211 212=head2 new 213 214 Purpose : generic instantiation function can be overridden if 215 special needs of a module cannot be done in _initialize 216 217=cut 218 219sub new { 220# my ($class, %param) = @_; 221 my $class = shift; 222 my $self = {}; 223 bless $self, ref($class) || $class; 224 225 if(@_ > 1) { 226 # if the number of arguments is odd but at least 3, we'll give 227 # it a try to find -verbose 228 shift if @_ % 2; 229 my %param = @_; 230 ## See "Comments" above regarding use of _rearrange(). 231 $self->verbose($param{'-VERBOSE'} || $param{'-verbose'}); 232 } 233 return $self; 234} 235 236 237=head2 clone 238 239 Title : clone 240 Usage : my $clone = $obj->clone(); 241 or 242 my $clone = $obj->clone( -start => 110 ); 243 Function: Deep recursion copying of any object via Storable dclone() 244 Returns : A cloned object. 245 Args : Any named parameters provided will be set on the new object. 246 Unnamed parameters are ignored. 247 Comments: Where possible, faster clone methods are used, in order: 248 Clone::Fast::clone(), Clone::clone(), Storable::dclone. If neither 249 is present, a pure perl fallback (not very well tested) is used 250 instead. Storable dclone() cannot clone CODE references. Therefore, 251 any CODE reference in your original object will remain, but will not 252 exist in the cloned object. This should not be used for anything 253 other than cloning of simple objects. Developers of subclasses are 254 encouraged to override this method with one of their own. 255 256=cut 257 258sub clone { 259 my ($orig, %named_params) = @_; 260 261 __PACKAGE__->throw("Can't call clone() as a class method") unless 262 ref $orig && $orig->isa('Bio::Root::Root'); 263 264 # Can't dclone CODE references... 265 # Should we shallow copy these? Should be harmless for these specific 266 # methods... 267 268 my %put_these_back = ( 269 _root_cleanup_methods => $orig->{'_root_cleanup_methods'}, 270 ); 271 delete $orig->{_root_cleanup_methods}; 272 273 # call the proper clone method, set lazily above 274 my $clone = __PACKAGE__->_dclone($orig); 275 276 $orig->{_root_cleanup_methods} = $put_these_back{_root_cleanup_methods}; 277 278 foreach my $key (grep { /^-/ } keys %named_params) { 279 my $method = $key; 280 $method =~ s/^-//; 281 if ($clone->can($method)) { 282 $clone->$method($named_params{$key}) 283 } else { 284 $orig->warn("Parameter $method is not a method for ".ref($clone)); 285 } 286 } 287 return $clone; 288} 289 290=head2 _dclone 291 292 Title : clone 293 Usage : my $clone = $obj->_dclone($ref); 294 or 295 my $clone = $obj->_dclone($ref); 296 Function: Returns a copy of the object passed to it (a deep clone) 297 Returns : clone of passed argument 298 Args : Anything 299 NOTE : This differs from clone significantly in that it does not clone 300 self, but the data passed to it. This code may need to be optimized 301 or overridden as needed. 302 Comments: This is set in the BEGIN block to take advantage of optimized 303 cloning methods if Clone or Storable is present, falling back to a 304 pure perl kludge. May be moved into a set of modules if the need 305 arises. At the moment, code ref cloning is not supported. 306 307=cut 308 309=head2 verbose 310 311 Title : verbose 312 Usage : $self->verbose(1) 313 Function: Sets verbose level for how ->warn behaves 314 -1 = no warning 315 0 = standard, small warning 316 1 = warning with stack trace 317 2 = warning becomes throw 318 Returns : The current verbosity setting (integer between -1 to 2) 319 Args : -1,0,1 or 2 320 321 322=cut 323 324sub verbose { 325 my ($self,$value) = @_; 326 # allow one to set global verbosity flag 327 return $DEBUG if $DEBUG; 328 return $VERBOSITY unless ref $self; 329 330 if (defined $value || ! defined $self->{'_root_verbose'}) { 331 $self->{'_root_verbose'} = $value || 0; 332 } 333 return $self->{'_root_verbose'}; 334} 335 336=head2 _register_for_cleanup 337 338=cut 339 340sub _register_for_cleanup { 341 my ($self,$method) = @_; 342 if ($method) { 343 if(! exists($self->{'_root_cleanup_methods'})) { 344 $self->{'_root_cleanup_methods'} = []; 345 } 346 push(@{$self->{'_root_cleanup_methods'}},$method); 347 } 348} 349 350=head2 _unregister_for_cleanup 351 352=cut 353 354sub _unregister_for_cleanup { 355 my ($self,$method) = @_; 356 my @methods = grep {$_ ne $method} $self->_cleanup_methods; 357 $self->{'_root_cleanup_methods'} = \@methods; 358} 359 360=head2 _cleanup_methods 361 362=cut 363 364sub _cleanup_methods { 365 my $self = shift; 366 return unless ref $self && $self->isa('HASH'); 367 my $methods = $self->{'_root_cleanup_methods'} or return; 368 @$methods; 369} 370 371=head2 throw 372 373 Title : throw 374 Usage : $obj->throw("throwing exception message"); 375 or 376 $obj->throw( -class => 'Bio::Root::Exception', 377 -text => "throwing exception message", 378 -value => $bad_value ); 379 Function: Throws an exception, which, if not caught with an eval or 380 a try block will provide a nice stack trace to STDERR 381 with the message. 382 If Error.pm is installed, and if a -class parameter is 383 provided, Error::throw will be used, throwing an error 384 of the type specified by -class. 385 If Error.pm is installed and no -class parameter is provided 386 (i.e., a simple string is given), A Bio::Root::Exception 387 is thrown. 388 Returns : n/a 389 Args : A string giving a descriptive error message, optional 390 Named parameters: 391 '-class' a string for the name of a class that derives 392 from Error.pm, such as any of the exceptions 393 defined in Bio::Root::Exception. 394 Default class: Bio::Root::Exception 395 '-text' a string giving a descriptive error message 396 '-value' the value causing the exception, or $! (optional) 397 398 Thus, if only a string argument is given, and Error.pm is available, 399 this is equivalent to the arguments: 400 -text => "message", 401 -class => Bio::Root::Exception 402 Comments : If Error.pm is installed, and you don't want to use it 403 for some reason, you can block the use of Error.pm by 404 Bio::Root::Root::throw() by defining a scalar named 405 $main::DONT_USE_ERROR (define it in your main script 406 and you don't need the main:: part) and setting it to 407 a true value; you must do this within a BEGIN subroutine. 408 409=cut 410 411sub throw { 412 my ($self, @args) = @_; 413 414 my ($text, $class, $value) = $self->_rearrange( [qw(TEXT 415 CLASS 416 VALUE)], @args); 417 $text ||= $args[0] if @args == 1; 418 419 if ($ERRORLOADED) { 420 # Enable re-throwing of Error objects. 421 # If the error is not derived from Bio::Root::Exception, 422 # we can't guarantee that the Error's value was set properly 423 # and, ipso facto, that it will be catchable from an eval{}. 424 # But chances are, if you're re-throwing non-Bio::Root::Exceptions, 425 # you're probably using Error::try(), not eval{}. 426 # TODO: Fix the MSG: line of the re-thrown error. Has an extra line 427 # containing the '----- EXCEPTION -----' banner. 428 if (ref($args[0])) { 429 if( $args[0]->isa('Error')) { 430 my $class = ref $args[0]; 431 $class->throw( @args ); 432 } 433 else { 434 my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0]; 435 my $class = "Bio::Root::Exception"; 436 $class->throw( '-text' => $text, '-value' => $args[0] ); 437 } 438 } 439 else { 440 $class ||= "Bio::Root::Exception"; 441 442 my %args; 443 if( @args % 2 == 0 && $args[0] =~ /^-/ ) { 444 %args = @args; 445 $args{-text} = $text; 446 $args{-object} = $self; 447 } 448 449 $class->throw( scalar keys %args > 0 ? %args : @args ); # (%args || @args) puts %args in scalar context! 450 } 451 } 452 else { 453 $class ||= ''; 454 $class = ': '.$class if $class; 455 my $std = $self->stack_trace_dump(); 456 my $title = "------------- EXCEPTION$class -------------"; 457 my $footer = ('-' x CORE::length($title))."\n"; 458 $text ||= ''; 459 460 die "\n$title\n", "MSG: $text\n", $std, $footer, "\n"; 461 } 462} 463 464=head2 debug 465 466 Title : debug 467 Usage : $obj->debug("This is debugging output"); 468 Function: Prints a debugging message when verbose is > 0 469 Returns : none 470 Args : message string(s) to print to STDERR 471 472=cut 473 474sub debug { 475 my ($self, @msgs) = @_; 476 477 # using CORE::warn doesn't give correct backtrace information; we want the 478 # line from the previous call in the call stack, not this call (similar to 479 # cluck). For now, just add a stack trace dump and simple comment under the 480 # correct conditions. 481 if (defined $self->verbose && $self->verbose > 0) { 482 if (!@msgs || $msgs[-1] !~ /\n$/) { 483 push @msgs, "Debugging comment:" if !@msgs; 484 push @msgs, sprintf("%s %s:%s", @{($self->stack_trace)[2]}[3,1,2])."\n"; 485 } 486 CORE::warn @msgs; 487 } 488} 489 490=head2 _load_module 491 492 Title : _load_module 493 Usage : $self->_load_module("Bio::SeqIO::genbank"); 494 Function: Loads up (like use) the specified module at run time on demand. 495 Example : 496 Returns : TRUE on success. Throws an exception upon failure. 497 Args : The module to load (_without_ the trailing .pm). 498 499=cut 500 501sub _load_module { 502 my ($self, $name) = @_; 503 my ($module, $load, $m); 504 $module = "_<$name.pm"; 505 return 1 if $main::{$module}; 506 507 # untaint operation for safe web-based running (modified after 508 # a fix by Lincoln) HL 509 if ($name !~ /^([\w:]+)$/) { 510 $self->throw("$name is an illegal perl package name"); 511 } else { 512 $name = $1; 513 } 514 515 $load = "$name.pm"; 516 my $io = Bio::Root::IO->new(); 517 # catfile comes from IO 518 $load = $io->catfile((split(/::/,$load))); 519 eval { 520 require $load; 521 }; 522 if ( $@ ) { 523 $self->throw("Failed to load module $name. ".$@); 524 } 525 return 1; 526} 527 528=head2 DESTROY 529 530=cut 531 532sub DESTROY { 533 my $self = shift; 534 my @cleanup_methods = $self->_cleanup_methods or return; 535 for my $method (@cleanup_methods) { 536 $method->($self); 537 } 538} 539 5401; 541