← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/pan_genome_post_analysis
  Run on Fri Mar 27 11:43:32 2015
Reported on Fri Mar 27 11:45:43 2015

Filename/Users/ap13/perl5/lib/perl5/Bio/Root/Root.pm
StatementsExecuted 35 statements in 1.77ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1115.34ms6.48msBio::Root::Root::::BEGIN@146Bio::Root::Root::BEGIN@146
1113.75ms26.1msBio::Root::Root::::BEGIN@3Bio::Root::Root::BEGIN@3
11118µs33µsBio::Root::Root::::BEGIN@2Bio::Root::Root::BEGIN@2
11114µs14µsBio::Root::Root::::newBio::Root::Root::new
11111µs2.10msBio::Root::Root::::BEGIN@5Bio::Root::Root::BEGIN@5
11111µs51µsBio::Root::Root::::BEGIN@4Bio::Root::Root::BEGIN@4
0000s0sBio::Root::Root::::DESTROYBio::Root::Root::DESTROY
0000s0sBio::Root::Root::::__ANON__[:175]Bio::Root::Root::__ANON__[:175]
0000s0sBio::Root::Root::::__ANON__[:182]Bio::Root::Root::__ANON__[:182]
0000s0sBio::Root::Root::::__ANON__[:206]Bio::Root::Root::__ANON__[:206]
0000s0sBio::Root::Root::::_cleanup_methodsBio::Root::Root::_cleanup_methods
0000s0sBio::Root::Root::::_load_moduleBio::Root::Root::_load_module
0000s0sBio::Root::Root::::_register_for_cleanupBio::Root::Root::_register_for_cleanup
0000s0sBio::Root::Root::::_unregister_for_cleanupBio::Root::Root::_unregister_for_cleanup
0000s0sBio::Root::Root::::cloneBio::Root::Root::clone
0000s0sBio::Root::Root::::debugBio::Root::Root::debug
0000s0sBio::Root::Root::::throwBio::Root::Root::throw
0000s0sBio::Root::Root::::verboseBio::Root::Root::verbose
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Bio::Root::Root;
2228µs248µ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
use strict;
# spent 33µs making 1 call to Bio::Root::Root::BEGIN@2 # spent 15µs making 1 call to strict::import
32131µs126.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
use Bio::Root::IO;
# spent 26.1ms making 1 call to Bio::Root::Root::BEGIN@3
4228µs291µ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
use Scalar::Util qw(blessed reftype);
# spent 51µs making 1 call to Bio::Root::Root::BEGIN@4 # spent 40µs making 1 call to Exporter::import
52437µs22.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
use base qw(Bio::Root::RootI);
# 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
57This is a hashref-based implementation of the Bio::Root::RootI
58interface. Most Bioperl objects should inherit from this.
59
60See the documentation for L<Bio::Root::RootI> for most of the methods
61implemented by this module. Only overridden methods are described
62here.
63
64=head2 Throwing Exceptions
65
66One of the functionalities that L<Bio::Root::RootI> provides is the
67ability to L<throw>() exceptions with pretty stack traces. Bio::Root::Root
68enhances this with the ability to use L<Error> (available from CPAN)
69if it has also been installed.
70
71If L<Error> has been installed, L<throw>() will use it. This causes an
72Error.pm-derived object to be thrown. This can be caught within a
73C<catch{}> block, from wich you can extract useful bits of
74information. If L<Error> is not installed, it will use the
75L<Bio::Root::RootI>-based exception throwing facilty.
76
77=head2 Typed Exception Syntax
78
79The typed exception syntax of L<throw>() has the advantage of plainly
80indicating the nature of the trouble, since the name of the class
81is included in the title of the exception output.
82
83To take advantage of this capability, you must specify arguments
84as named parameters in the L<throw>() call. Here are the parameters:
85
86=over 4
87
88=item -class
89
90name of the class of the exception.
91This should be one of the classes defined in L<Bio::Root::Exception>,
92or a custom error of yours that extends one of the exceptions
93defined in L<Bio::Root::Exception>.
94
95=item -text
96
97a sensible message for the exception
98
99=item -value
100
101the value causing the exception or $!, if appropriate.
102
103=back
104
105Note that Bio::Root::Exception does not need to be imported into
106your module (or script) namespace in order to throw exceptions
107via Bio::Root::Root::throw(), since Bio::Root::Root imports it.
108
109=head2 Try-Catch-Finally Support
110
111In addition to using an eval{} block to handle exceptions, you can
112also use a try-catch-finally block structure if L<Error> has been
113installed in your system (available from CPAN). See the documentation
114for Error for more details.
115
116Here's an example. See the L<Bio::Root::Exception> module for
117other 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
1441300nsour ($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
BEGIN {
14799µ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.
157114µs if( not $main::DONT_USE_ERROR ) {
1584146µs if ( eval "require Error; 1;" ) {
# spent 91µs executing statements in string eval
1591277µ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)) {
171217µs eval "require $class; 1;";
# spent 83µs executing statements in string eval
17232µs if (!$@) {
173 $CLONE_CLASS = $class;
17415µs 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"
2101933µs16.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
sub new {
220# my ($class, %param) = @_;
221518µ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
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
54014µs1;