← 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:27 2015

Filename/Users/ap13/perl5/lib/perl5/Error.pm
StatementsExecuted 39 statements in 2.74ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11122µs277µsError::::import Error::import
11115µs15µsError::::BEGIN@16 Error::BEGIN@16
11113µs28µsError::::BEGIN@14 Error::BEGIN@14
11112µs63µsError::::BEGIN@20 Error::BEGIN@20
1119µs37µsError::::BEGIN@15 Error::BEGIN@15
1118µs28µsError::Simple::::BEGIN@260 Error::Simple::BEGIN@260
1117µs47µsError::subs::::BEGIN@299 Error::subs::BEGIN@299
1115µs5µsError::subs::::BEGIN@298 Error::subs::BEGIN@298
1114µs4µsError::::BEGIN@46 Error::BEGIN@46
0000s0sError::Simple::::new Error::Simple::new
0000s0sError::Simple::::stringify Error::Simple::stringify
0000s0sError::WarnDie::::DEATHError::WarnDie::DEATH
0000s0sError::WarnDie::::TAXESError::WarnDie::TAXES
0000s0sError::WarnDie::::gen_callstackError::WarnDie::gen_callstack
0000s0sError::WarnDie::::importError::WarnDie::import
0000s0sError::::__ANON__[:23] Error::__ANON__[:23]
0000s0sError::::_throw_Error_Simple Error::_throw_Error_Simple
0000s0sError::::associate Error::associate
0000s0sError::::catch Error::catch
0000s0sError::::file Error::file
0000s0sError::::flush Error::flush
0000s0sError::::line Error::line
0000s0sError::::new Error::new
0000s0sError::::object Error::object
0000s0sError::::prior Error::prior
0000s0sError::::record Error::record
0000s0sError::::stacktrace Error::stacktrace
0000s0sError::::stringify Error::stringify
0000s0sError::subs::::__ANON__[:495] Error::subs::__ANON__[:495]
0000s0sError::subs::::except Error::subs::except
0000s0sError::subs::::finally Error::subs::finally
0000s0sError::subs::::otherwise Error::subs::otherwise
0000s0sError::subs::::run_clauses Error::subs::run_clauses
0000s0sError::subs::::try Error::subs::try
0000s0sError::subs::::with Error::subs::with
0000s0sError::::text Error::text
0000s0sError::::throw Error::throw
0000s0sError::::value Error::value
0000s0sError::::with Error::with
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# Error.pm
2#
3# Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. All rights reserved.
4# This program is free software; you can redistribute it and/or
5# modify it under the same terms as Perl itself.
6#
7# Based on my original Error.pm, and Exceptions.pm by Peter Seibel
8# <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>.
9#
10# but modified ***significantly***
11
12package Error;
13
14227µs242µs
# spent 28µs (13+14) within Error::BEGIN@14 which was called: # once (13µs+14µs) by Bio::Root::Root::BEGIN@146 at line 14
use strict;
# spent 28µs making 1 call to Error::BEGIN@14 # spent 14µs making 1 call to strict::import
15225µs265µs
# spent 37µs (9+28) within Error::BEGIN@15 which was called: # once (9µs+28µs) by Bio::Root::Root::BEGIN@146 at line 15
use vars qw($VERSION);
# spent 37µs making 1 call to Error::BEGIN@15 # spent 28µs making 1 call to vars::import
16288µs115µs
# spent 15µs within Error::BEGIN@16 which was called: # once (15µs+0s) by Bio::Root::Root::BEGIN@146 at line 16
use 5.004;
# spent 15µs making 1 call to Error::BEGIN@16
17
1811µs$VERSION = "0.17021";
19
20
# spent 63µs (12+51) within Error::BEGIN@20 which was called: # once (12µs+51µs) by Bio::Root::Root::BEGIN@146 at line 25
use overload (
21 '""' => 'stringify',
22 '0+' => 'value',
23 'bool' => sub { return 1; },
24213µs 'fallback' => 1
25190µs2114µs);
# spent 63µs making 1 call to Error::BEGIN@20 # spent 51µs making 1 call to overload::import
26
271300ns$Error::Depth = 0; # Depth to pass to caller()
281200ns$Error::Debug = 0; # Generate verbose stack traces
2911µs@Error::STACK = (); # Clause stack for try
301200ns$Error::THROWN = undef; # last error thrown, a workaround until die $ref works
31
321100nsmy $LAST; # Last error created
331200nsmy %ERROR; # Last error associated with package
34
35sub _throw_Error_Simple
36{
37 my $args = shift;
38 return Error::Simple->new($args->{'text'});
39}
40
4111µs$Error::ObjectifyCallback = \&_throw_Error_Simple;
42
43
44# Exported subs are defined in Error::subs
45
462739µs14µs
# spent 4µs within Error::BEGIN@46 which was called: # once (4µs+0s) by Bio::Root::Root::BEGIN@146 at line 46
use Scalar::Util ();
# spent 4µs making 1 call to Error::BEGIN@46
47
48
# spent 277µs (22+255) within Error::import which was called: # once (22µs+255µs) by Bio::Root::Root::BEGIN@146 at line 159 of Bio/Root/Root.pm
sub import {
49720µs shift;
50 my @tags = @_;
51 local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
52
53 @tags = grep {
54 if( $_ eq ':warndie' ) {
55 Error::WarnDie->import();
56 0;
57 }
58 else {
59 1;
60 }
61 } @tags;
62
631255µs Error::subs->import(@tags);
# spent 255µs making 1 call to Exporter::import
64}
65
66# I really want to use last for the name of this method, but it is a keyword
67# which prevent the syntax last Error
68
69sub prior {
70 shift; # ignore
71
72 return $LAST unless @_;
73
74 my $pkg = shift;
75 return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
76 unless ref($pkg);
77
78 my $obj = $pkg;
79 my $err = undef;
80 if($obj->isa('HASH')) {
81 $err = $obj->{'__Error__'}
82 if exists $obj->{'__Error__'};
83 }
84 elsif($obj->isa('GLOB')) {
85 $err = ${*$obj}{'__Error__'}
86 if exists ${*$obj}{'__Error__'};
87 }
88
89 $err;
90}
91
92sub flush {
93 shift; #ignore
94
95 unless (@_) {
96 $LAST = undef;
97 return;
98 }
99
100 my $pkg = shift;
101 return unless ref($pkg);
102
103 undef $ERROR{$pkg} if defined $ERROR{$pkg};
104}
105
106# Return as much information as possible about where the error
107# happened. The -stacktrace element only exists if $Error::DEBUG
108# was set when the error was created
109
110sub stacktrace {
111 my $self = shift;
112
113 return $self->{'-stacktrace'}
114 if exists $self->{'-stacktrace'};
115
116 my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
117
118 $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
119 unless($text =~ /\n$/s);
120
121 $text;
122}
123
124
125sub associate {
126 my $err = shift;
127 my $obj = shift;
128
129 return unless ref($obj);
130
131 if($obj->isa('HASH')) {
132 $obj->{'__Error__'} = $err;
133 }
134 elsif($obj->isa('GLOB')) {
135 ${*$obj}{'__Error__'} = $err;
136 }
137 $obj = ref($obj);
138 $ERROR{ ref($obj) } = $err;
139
140 return;
141}
142
143
144sub new {
145 my $self = shift;
146 my($pkg,$file,$line) = caller($Error::Depth);
147
148 my $err = bless {
149 '-package' => $pkg,
150 '-file' => $file,
151 '-line' => $line,
152 @_
153 }, $self;
154
155 $err->associate($err->{'-object'})
156 if(exists $err->{'-object'});
157
158 # To always create a stacktrace would be very inefficient, so
159 # we only do it if $Error::Debug is set
160
161 if($Error::Debug) {
162 require Carp;
163 local $Carp::CarpLevel = $Error::Depth;
164 my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
165 my $trace = Carp::longmess($text);
166 # Remove try calls from the trace
167 $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
168 $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
169 $err->{'-stacktrace'} = $trace
170 }
171
172 $@ = $LAST = $ERROR{$pkg} = $err;
173}
174
175# Throw an error. this contains some very gory code.
176
177sub throw {
178 my $self = shift;
179 local $Error::Depth = $Error::Depth + 1;
180
181 # if we are not rethrow-ing then create the object to throw
182 $self = $self->new(@_) unless ref($self);
183
184 die $Error::THROWN = $self;
185}
186
187# syntactic sugar for
188#
189# die with Error( ... );
190
191sub with {
192 my $self = shift;
193 local $Error::Depth = $Error::Depth + 1;
194
195 $self->new(@_);
196}
197
198# syntactic sugar for
199#
200# record Error( ... ) and return;
201
202sub record {
203 my $self = shift;
204 local $Error::Depth = $Error::Depth + 1;
205
206 $self->new(@_);
207}
208
209# catch clause for
210#
211# try { ... } catch CLASS with { ... }
212
213sub catch {
214 my $pkg = shift;
215 my $code = shift;
216 my $clauses = shift || {};
217 my $catch = $clauses->{'catch'} ||= [];
218
219 unshift @$catch, $pkg, $code;
220
221 $clauses;
222}
223
224# Object query methods
225
226sub object {
227 my $self = shift;
228 exists $self->{'-object'} ? $self->{'-object'} : undef;
229}
230
231sub file {
232 my $self = shift;
233 exists $self->{'-file'} ? $self->{'-file'} : undef;
234}
235
236sub line {
237 my $self = shift;
238 exists $self->{'-line'} ? $self->{'-line'} : undef;
239}
240
241sub text {
242 my $self = shift;
243 exists $self->{'-text'} ? $self->{'-text'} : undef;
244}
245
246# overload methods
247
248sub stringify {
249 my $self = shift;
250 defined $self->{'-text'} ? $self->{'-text'} : "Died";
251}
252
253sub value {
254 my $self = shift;
255 exists $self->{'-value'} ? $self->{'-value'} : undef;
256}
257
258package Error::Simple;
259
2602179µs248µs
# spent 28µs (8+20) within Error::Simple::BEGIN@260 which was called: # once (8µs+20µs) by Bio::Root::Root::BEGIN@146 at line 260
use vars qw($VERSION);
# spent 28µs making 1 call to Error::Simple::BEGIN@260 # spent 20µs making 1 call to vars::import
261
2621600ns$VERSION = "0.17021";
263
264110µs@Error::Simple::ISA = qw(Error);
265
266sub new {
267 my $self = shift;
268 my $text = "" . shift;
269 my $value = shift;
270 my(@args) = ();
271
272 local $Error::Depth = $Error::Depth + 1;
273
274 @args = ( -file => $1, -line => $2)
275 if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s);
276 push(@args, '-value', 0 + $value)
277 if defined($value);
278
279 $self->SUPER::new(-text => $text, @args);
280}
281
282sub stringify {
283 my $self = shift;
284 my $text = $self->SUPER::stringify;
285 $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
286 unless($text =~ /\n$/s);
287 $text;
288}
289
290##########################################################################
291##########################################################################
292
293# Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
294# Peter Seibel <peter@weblogic.com>
295
296package Error::subs;
297
298224µs15µs
# spent 5µs within Error::subs::BEGIN@298 which was called: # once (5µs+0s) by Bio::Root::Root::BEGIN@146 at line 298
use Exporter ();
# spent 5µs making 1 call to Error::subs::BEGIN@298
29921.48ms287µs
# spent 47µs (7+40) within Error::subs::BEGIN@299 which was called: # once (7µs+40µs) by Bio::Root::Root::BEGIN@146 at line 299
use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
# spent 47µs making 1 call to Error::subs::BEGIN@299 # spent 40µs making 1 call to vars::import
300
30112µs@EXPORT_OK = qw(try with finally except otherwise);
30212µs%EXPORT_TAGS = (try => \@EXPORT_OK);
303
30417µs@ISA = qw(Exporter);
305
306sub run_clauses ($$$\@) {
307 my($clauses,$err,$wantarray,$result) = @_;
308 my $code = undef;
309
310 $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err);
311
312 CATCH: {
313
314 # catch
315 my $catch;
316 if(defined($catch = $clauses->{'catch'})) {
317 my $i = 0;
318
319 CATCHLOOP:
320 for( ; $i < @$catch ; $i += 2) {
321 my $pkg = $catch->[$i];
322 unless(defined $pkg) {
323 #except
324 splice(@$catch,$i,2,$catch->[$i+1]->($err));
325 $i -= 2;
326 next CATCHLOOP;
327 }
328 elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) {
329 $code = $catch->[$i+1];
330 while(1) {
331 my $more = 0;
332 local($Error::THROWN, $@);
333 my $ok = eval {
334 $@ = $err;
335 if($wantarray) {
336 @{$result} = $code->($err,\$more);
337 }
338 elsif(defined($wantarray)) {
339 @{$result} = ();
340 $result->[0] = $code->($err,\$more);
341 }
342 else {
343 $code->($err,\$more);
344 }
345 1;
346 };
347 if( $ok ) {
348 next CATCHLOOP if $more;
349 undef $err;
350 }
351 else {
352 $err = $@ || $Error::THROWN;
353 $err = $Error::ObjectifyCallback->({'text' =>$err})
354 unless ref($err);
355 }
356 last CATCH;
357 };
358 }
359 }
360 }
361
362 # otherwise
363 my $owise;
364 if(defined($owise = $clauses->{'otherwise'})) {
365 my $code = $clauses->{'otherwise'};
366 my $more = 0;
367 local($Error::THROWN, $@);
368 my $ok = eval {
369 $@ = $err;
370 if($wantarray) {
371 @{$result} = $code->($err,\$more);
372 }
373 elsif(defined($wantarray)) {
374 @{$result} = ();
375 $result->[0] = $code->($err,\$more);
376 }
377 else {
378 $code->($err,\$more);
379 }
380 1;
381 };
382 if( $ok ) {
383 undef $err;
384 }
385 else {
386 $err = $@ || $Error::THROWN;
387
388 $err = $Error::ObjectifyCallback->({'text' =>$err})
389 unless ref($err);
390 }
391 }
392 }
393 $err;
394}
395
396sub try (&;$) {
397 my $try = shift;
398 my $clauses = @_ ? shift : {};
399 my $ok = 0;
400 my $err = undef;
401 my @result = ();
402
403 unshift @Error::STACK, $clauses;
404
405 my $wantarray = wantarray();
406
407 do {
408 local $Error::THROWN = undef;
409 local $@ = undef;
410
411 $ok = eval {
412 if($wantarray) {
413 @result = $try->();
414 }
415 elsif(defined $wantarray) {
416 $result[0] = $try->();
417 }
418 else {
419 $try->();
420 }
421 1;
422 };
423
424 $err = $@ || $Error::THROWN
425 unless $ok;
426 };
427
428 shift @Error::STACK;
429
430 $err = run_clauses($clauses,$err,wantarray,@result)
431 unless($ok);
432
433 $clauses->{'finally'}->()
434 if(defined($clauses->{'finally'}));
435
436 if (defined($err))
437 {
438 if (Scalar::Util::blessed($err) && $err->can('throw'))
439 {
440 throw $err;
441 }
442 else
443 {
444 die $err;
445 }
446 }
447
448 wantarray ? @result : $result[0];
449}
450
451# Each clause adds a sub to the list of clauses. The finally clause is
452# always the last, and the otherwise clause is always added just before
453# the finally clause.
454#
455# All clauses, except the finally clause, add a sub which takes one argument
456# this argument will be the error being thrown. The sub will return a code ref
457# if that clause can handle that error, otherwise undef is returned.
458#
459# The otherwise clause adds a sub which unconditionally returns the users
460# code reference, this is why it is forced to be last.
461#
462# The catch clause is defined in Error.pm, as the syntax causes it to
463# be called as a method
464
465sub with (&;$) {
466 @_
467}
468
469sub finally (&) {
470 my $code = shift;
471 my $clauses = { 'finally' => $code };
472 $clauses;
473}
474
475# The except clause is a block which returns a hashref or a list of
476# key-value pairs, where the keys are the classes and the values are subs.
477
478sub except (&;$) {
479 my $code = shift;
480 my $clauses = shift || {};
481 my $catch = $clauses->{'catch'} ||= [];
482
483 my $sub = sub {
484 my $ref;
485 my(@array) = $code->($_[0]);
486 if(@array == 1 && ref($array[0])) {
487 $ref = $array[0];
488 $ref = [ %$ref ]
489 if(UNIVERSAL::isa($ref,'HASH'));
490 }
491 else {
492 $ref = \@array;
493 }
494 @$ref
495 };
496
497 unshift @{$catch}, undef, $sub;
498
499 $clauses;
500}
501
502sub otherwise (&;$) {
503 my $code = shift;
504 my $clauses = shift || {};
505
506 if(exists $clauses->{'otherwise'}) {
507 require Carp;
508 Carp::croak("Multiple otherwise clauses");
509 }
510
511 $clauses->{'otherwise'} = $code;
512
513 $clauses;
514}
515
5161;
517
518package Error::WarnDie;
519
520sub gen_callstack($)
521{
522 my ( $start ) = @_;
523
524 require Carp;
525 local $Carp::CarpLevel = $start;
526 my $trace = Carp::longmess("");
527 # Remove try calls from the trace
528 $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
529 $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
530 my @callstack = split( m/\n/, $trace );
531 return @callstack;
532}
533
5341100nsmy $old_DIE;
5351100nsmy $old_WARN;
536
537sub DEATH
538{
539 my ( $e ) = @_;
540
541 local $SIG{__DIE__} = $old_DIE if( defined $old_DIE );
542
543 die @_ if $^S;
544
545 my ( $etype, $message, $location, @callstack );
546 if ( ref($e) && $e->isa( "Error" ) ) {
547 $etype = "exception of type " . ref( $e );
548 $message = $e->text;
549 $location = $e->file . ":" . $e->line;
550 @callstack = split( m/\n/, $e->stacktrace );
551 }
552 else {
553 # Don't apply subsequent layer of message formatting
554 die $e if( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ );
555 $etype = "perl error";
556 my $stackdepth = 0;
557 while( caller( $stackdepth ) =~ m/^Error(?:$|::)/ ) {
558 $stackdepth++
559 }
560
561 @callstack = gen_callstack( $stackdepth + 1 );
562
563 $message = "$e";
564 chomp $message;
565
566 if ( $message =~ s/ at (.*?) line (\d+)\.$// ) {
567 $location = $1 . ":" . $2;
568 }
569 else {
570 my @caller = caller( $stackdepth );
571 $location = $caller[1] . ":" . $caller[2];
572 }
573 }
574
575 shift @callstack;
576 # Do it this way in case there are no elements; we don't print a spurious \n
577 my $callstack = join( "", map { "$_\n"} @callstack );
578
579 die "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n";
580}
581
582sub TAXES
583{
584 my ( $message ) = @_;
585
586 local $SIG{__WARN__} = $old_WARN if( defined $old_WARN );
587
588 $message =~ s/ at .*? line \d+\.$//;
589 chomp $message;
590
591 my @callstack = gen_callstack( 1 );
592 my $location = shift @callstack;
593
594 # $location already starts in a leading space
595 $message .= $location;
596
597 # Do it this way in case there are no elements; we don't print a spurious \n
598 my $callstack = join( "", map { "$_\n"} @callstack );
599
600 warn "$message:\n$callstack";
601}
602
603sub import
604{
605 $old_DIE = $SIG{__DIE__};
606 $old_WARN = $SIG{__WARN__};
607
608 $SIG{__DIE__} = \&DEATH;
609 $SIG{__WARN__} = \&TAXES;
610}
611
612125µs1;
613
614__END__