| Filename | /Users/ap13/perl5/lib/perl5/Bio/Root/Root.pm |
| Statements | Executed 35 statements in 1.77ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 5.34ms | 6.48ms | Bio::Root::Root::BEGIN@146 |
| 1 | 1 | 1 | 3.75ms | 26.1ms | Bio::Root::Root::BEGIN@3 |
| 1 | 1 | 1 | 18µs | 33µs | Bio::Root::Root::BEGIN@2 |
| 1 | 1 | 1 | 14µs | 14µs | Bio::Root::Root::new |
| 1 | 1 | 1 | 11µs | 2.10ms | Bio::Root::Root::BEGIN@5 |
| 1 | 1 | 1 | 11µs | 51µs | Bio::Root::Root::BEGIN@4 |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::DESTROY |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::__ANON__[:175] |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::__ANON__[:182] |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::__ANON__[:206] |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::_cleanup_methods |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::_load_module |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::_register_for_cleanup |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::_unregister_for_cleanup |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::clone |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::debug |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::throw |
| 0 | 0 | 0 | 0s | 0s | Bio::Root::Root::verbose |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Bio::Root::Root; | ||||
| 2 | 2 | 28µs | 2 | 48µs | # spent 33µs (18+15) within Bio::Root::Root::BEGIN@2 which was called:
# once (18µs+15µs) by base::import at line 2 # spent 33µs making 1 call to Bio::Root::Root::BEGIN@2
# spent 15µs making 1 call to strict::import |
| 3 | 2 | 131µs | 1 | 26.1ms | # spent 26.1ms (3.75+22.3) within Bio::Root::Root::BEGIN@3 which was called:
# once (3.75ms+22.3ms) by base::import at line 3 # spent 26.1ms making 1 call to Bio::Root::Root::BEGIN@3 |
| 4 | 2 | 28µs | 2 | 91µs | # spent 51µs (11+40) within Bio::Root::Root::BEGIN@4 which was called:
# once (11µs+40µs) by base::import at line 4 # spent 51µs making 1 call to Bio::Root::Root::BEGIN@4
# spent 40µs making 1 call to Exporter::import |
| 5 | 2 | 437µs | 2 | 2.10ms | # spent 2.10ms (11µs+2.09) within Bio::Root::Root::BEGIN@5 which was called:
# once (11µs+2.09ms) by base::import at line 5 # spent 2.10ms making 1 call to Bio::Root::Root::BEGIN@5
# spent 2.09ms making 1 call to base::import, recursion: max depth 1, sum of overlapping time 2.09ms |
| 6 | |||||
| 7 | # ABSTRACT: hash-based implementation of L<Bio::Root::RootI> | ||||
| 8 | # AUTHOR: Steve Chervitz <sac@bioperl.org> | ||||
| 9 | # AUTHOR: Ewan Birney | ||||
| 10 | # AUTHOR: Lincoln Stein | ||||
| 11 | # OWNER: Steve Chervitz | ||||
| 12 | # OWNER: Ewan Birney | ||||
| 13 | # OWNER: Lincoln Stein | ||||
| 14 | # LICENSE: Perl_5 | ||||
| 15 | |||||
| 16 | =head1 SYNOPSIS | ||||
| 17 | |||||
| 18 | # Any Bioperl-compliant object is a RootI compliant object | ||||
| 19 | |||||
| 20 | # Here's how to throw and catch an exception using the eval-based syntax. | ||||
| 21 | |||||
| 22 | $obj->throw("This is an exception"); | ||||
| 23 | |||||
| 24 | eval { | ||||
| 25 | $obj->throw("This is catching an exception"); | ||||
| 26 | }; | ||||
| 27 | |||||
| 28 | if( $@ ) { | ||||
| 29 | print "Caught exception"; | ||||
| 30 | } else { | ||||
| 31 | print "no exception"; | ||||
| 32 | } | ||||
| 33 | |||||
| 34 | # Alternatively, using the new typed exception syntax in the throw() call: | ||||
| 35 | |||||
| 36 | $obj->throw( -class => 'Bio::Root::BadParameter', | ||||
| 37 | -text => "Can not open file $file", | ||||
| 38 | -value => $file ); | ||||
| 39 | |||||
| 40 | # Want to see debug() outputs for this object | ||||
| 41 | |||||
| 42 | my $obj = Bio::Object->new(-verbose=>1); | ||||
| 43 | |||||
| 44 | my $obj = Bio::Object->new(%args); | ||||
| 45 | $obj->verbose(2); | ||||
| 46 | |||||
| 47 | # Print debug messages which honour current verbosity setting | ||||
| 48 | |||||
| 49 | $obj->debug("Boring output only to be seen if verbose > 0\n"); | ||||
| 50 | |||||
| 51 | # Deep-object copy | ||||
| 52 | |||||
| 53 | my $clone = $obj->clone; | ||||
| 54 | |||||
| 55 | =head1 DESCRIPTION | ||||
| 56 | |||||
| 57 | This is a hashref-based implementation of the Bio::Root::RootI | ||||
| 58 | interface. Most Bioperl objects should inherit from this. | ||||
| 59 | |||||
| 60 | See the documentation for L<Bio::Root::RootI> for most of the methods | ||||
| 61 | implemented by this module. Only overridden methods are described | ||||
| 62 | here. | ||||
| 63 | |||||
| 64 | =head2 Throwing Exceptions | ||||
| 65 | |||||
| 66 | One of the functionalities that L<Bio::Root::RootI> provides is the | ||||
| 67 | ability to L<throw>() exceptions with pretty stack traces. Bio::Root::Root | ||||
| 68 | enhances this with the ability to use L<Error> (available from CPAN) | ||||
| 69 | if it has also been installed. | ||||
| 70 | |||||
| 71 | If L<Error> has been installed, L<throw>() will use it. This causes an | ||||
| 72 | Error.pm-derived object to be thrown. This can be caught within a | ||||
| 73 | C<catch{}> block, from wich you can extract useful bits of | ||||
| 74 | information. If L<Error> is not installed, it will use the | ||||
| 75 | L<Bio::Root::RootI>-based exception throwing facilty. | ||||
| 76 | |||||
| 77 | =head2 Typed Exception Syntax | ||||
| 78 | |||||
| 79 | The typed exception syntax of L<throw>() has the advantage of plainly | ||||
| 80 | indicating the nature of the trouble, since the name of the class | ||||
| 81 | is included in the title of the exception output. | ||||
| 82 | |||||
| 83 | To take advantage of this capability, you must specify arguments | ||||
| 84 | as named parameters in the L<throw>() call. Here are the parameters: | ||||
| 85 | |||||
| 86 | =over 4 | ||||
| 87 | |||||
| 88 | =item -class | ||||
| 89 | |||||
| 90 | name of the class of the exception. | ||||
| 91 | This should be one of the classes defined in L<Bio::Root::Exception>, | ||||
| 92 | or a custom error of yours that extends one of the exceptions | ||||
| 93 | defined in L<Bio::Root::Exception>. | ||||
| 94 | |||||
| 95 | =item -text | ||||
| 96 | |||||
| 97 | a sensible message for the exception | ||||
| 98 | |||||
| 99 | =item -value | ||||
| 100 | |||||
| 101 | the value causing the exception or $!, if appropriate. | ||||
| 102 | |||||
| 103 | =back | ||||
| 104 | |||||
| 105 | Note that Bio::Root::Exception does not need to be imported into | ||||
| 106 | your module (or script) namespace in order to throw exceptions | ||||
| 107 | via Bio::Root::Root::throw(), since Bio::Root::Root imports it. | ||||
| 108 | |||||
| 109 | =head2 Try-Catch-Finally Support | ||||
| 110 | |||||
| 111 | In addition to using an eval{} block to handle exceptions, you can | ||||
| 112 | also use a try-catch-finally block structure if L<Error> has been | ||||
| 113 | installed in your system (available from CPAN). See the documentation | ||||
| 114 | for Error for more details. | ||||
| 115 | |||||
| 116 | Here's an example. See the L<Bio::Root::Exception> module for | ||||
| 117 | other pre-defined exception types: | ||||
| 118 | |||||
| 119 | my $IN; | ||||
| 120 | try { | ||||
| 121 | open $IN, '<', $file or $obj->throw( -class => 'Bio::Root::FileOpenException', | ||||
| 122 | -text => "Cannot read file '$file'", | ||||
| 123 | -value => $!); | ||||
| 124 | } | ||||
| 125 | catch Bio::Root::BadParameter with { | ||||
| 126 | my $err = shift; # get the Error object | ||||
| 127 | # Perform specific exception handling code for the FileOpenException | ||||
| 128 | } | ||||
| 129 | catch Bio::Root::Exception with { | ||||
| 130 | my $err = shift; # get the Error object | ||||
| 131 | # Perform general exception handling code for any Bioperl exception. | ||||
| 132 | } | ||||
| 133 | otherwise { | ||||
| 134 | # A catch-all for any other type of exception | ||||
| 135 | } | ||||
| 136 | finally { | ||||
| 137 | # Any code that you want to execute regardless of whether or not | ||||
| 138 | # an exception occurred. | ||||
| 139 | }; | ||||
| 140 | # the ending semicolon is essential! | ||||
| 141 | |||||
| 142 | =cut | ||||
| 143 | |||||
| 144 | 1 | 300ns | our ($DEBUG, $ID, $VERBOSITY, $ERRORLOADED, $CLONE_CLASS); | ||
| 145 | |||||
| 146 | # spent 6.48ms (5.34+1.14) within Bio::Root::Root::BEGIN@146 which was called:
# once (5.34ms+1.14ms) by base::import at line 210 | ||||
| 147 | 20 | 193µs | $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;" ) { # spent 91µs executing statements in string eval | ||||
| 159 | 1 | 277µs | import Error qw(:try); # spent 277µs making 1 call to Error::import | ||
| 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;"; # spent 83µs executing statements in string eval | ||||
| 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 | 1 | 933µs | 1 | 6.48ms | } # spent 6.48ms making 1 call to Bio::Root::Root::BEGIN@146 |
| 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 | |||||
| 219 | # spent 14µs within Bio::Root::Root::new which was called:
# once (14µs+0s) by Bio::Location::WidestCoordPolicy::new at line 84 of Bio/Location/WidestCoordPolicy.pm | ||||
| 220 | # my ($class, %param) = @_; | ||||
| 221 | 5 | 18µs | 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 | |||||
| 258 | sub 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 | |||||
| 324 | sub 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 | |||||
| 340 | sub _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 | |||||
| 354 | sub _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 | |||||
| 364 | sub _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 | |||||
| 411 | sub 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 | |||||
| 474 | sub 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 | |||||
| 501 | sub _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 | |||||
| 532 | sub 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 | |||||
| 540 | 1 | 4µs | 1; |