| Filename | /Users/ap13/perl5/lib/perl5/Error.pm |
| Statements | Executed 39 statements in 2.74ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 22µs | 277µs | Error::import |
| 1 | 1 | 1 | 15µs | 15µs | Error::BEGIN@16 |
| 1 | 1 | 1 | 13µs | 28µs | Error::BEGIN@14 |
| 1 | 1 | 1 | 12µs | 63µs | Error::BEGIN@20 |
| 1 | 1 | 1 | 9µs | 37µs | Error::BEGIN@15 |
| 1 | 1 | 1 | 8µs | 28µs | Error::Simple::BEGIN@260 |
| 1 | 1 | 1 | 7µs | 47µs | Error::subs::BEGIN@299 |
| 1 | 1 | 1 | 5µs | 5µs | Error::subs::BEGIN@298 |
| 1 | 1 | 1 | 4µs | 4µs | Error::BEGIN@46 |
| 0 | 0 | 0 | 0s | 0s | Error::Simple::new |
| 0 | 0 | 0 | 0s | 0s | Error::Simple::stringify |
| 0 | 0 | 0 | 0s | 0s | Error::WarnDie::DEATH |
| 0 | 0 | 0 | 0s | 0s | Error::WarnDie::TAXES |
| 0 | 0 | 0 | 0s | 0s | Error::WarnDie::gen_callstack |
| 0 | 0 | 0 | 0s | 0s | Error::WarnDie::import |
| 0 | 0 | 0 | 0s | 0s | Error::__ANON__[:23] |
| 0 | 0 | 0 | 0s | 0s | Error::_throw_Error_Simple |
| 0 | 0 | 0 | 0s | 0s | Error::associate |
| 0 | 0 | 0 | 0s | 0s | Error::catch |
| 0 | 0 | 0 | 0s | 0s | Error::file |
| 0 | 0 | 0 | 0s | 0s | Error::flush |
| 0 | 0 | 0 | 0s | 0s | Error::line |
| 0 | 0 | 0 | 0s | 0s | Error::new |
| 0 | 0 | 0 | 0s | 0s | Error::object |
| 0 | 0 | 0 | 0s | 0s | Error::prior |
| 0 | 0 | 0 | 0s | 0s | Error::record |
| 0 | 0 | 0 | 0s | 0s | Error::stacktrace |
| 0 | 0 | 0 | 0s | 0s | Error::stringify |
| 0 | 0 | 0 | 0s | 0s | Error::subs::__ANON__[:495] |
| 0 | 0 | 0 | 0s | 0s | Error::subs::except |
| 0 | 0 | 0 | 0s | 0s | Error::subs::finally |
| 0 | 0 | 0 | 0s | 0s | Error::subs::otherwise |
| 0 | 0 | 0 | 0s | 0s | Error::subs::run_clauses |
| 0 | 0 | 0 | 0s | 0s | Error::subs::try |
| 0 | 0 | 0 | 0s | 0s | Error::subs::with |
| 0 | 0 | 0 | 0s | 0s | Error::text |
| 0 | 0 | 0 | 0s | 0s | Error::throw |
| 0 | 0 | 0 | 0s | 0s | Error::value |
| 0 | 0 | 0 | 0s | 0s | Error::with |
| 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 | |||||
| 12 | package Error; | ||||
| 13 | |||||
| 14 | 2 | 27µs | 2 | 42µ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 # spent 28µs making 1 call to Error::BEGIN@14
# spent 14µs making 1 call to strict::import |
| 15 | 2 | 25µs | 2 | 65µ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 # spent 37µs making 1 call to Error::BEGIN@15
# spent 28µs making 1 call to vars::import |
| 16 | 2 | 88µs | 1 | 15µs | # spent 15µs within Error::BEGIN@16 which was called:
# once (15µs+0s) by Bio::Root::Root::BEGIN@146 at line 16 # spent 15µs making 1 call to Error::BEGIN@16 |
| 17 | |||||
| 18 | 1 | 1µ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 | ||||
| 21 | '""' => 'stringify', | ||||
| 22 | '0+' => 'value', | ||||
| 23 | 'bool' => sub { return 1; }, | ||||
| 24 | 2 | 13µs | 'fallback' => 1 | ||
| 25 | 1 | 90µs | 2 | 114µs | ); # spent 63µs making 1 call to Error::BEGIN@20
# spent 51µs making 1 call to overload::import |
| 26 | |||||
| 27 | 1 | 300ns | $Error::Depth = 0; # Depth to pass to caller() | ||
| 28 | 1 | 200ns | $Error::Debug = 0; # Generate verbose stack traces | ||
| 29 | 1 | 1µs | @Error::STACK = (); # Clause stack for try | ||
| 30 | 1 | 200ns | $Error::THROWN = undef; # last error thrown, a workaround until die $ref works | ||
| 31 | |||||
| 32 | 1 | 100ns | my $LAST; # Last error created | ||
| 33 | 1 | 200ns | my %ERROR; # Last error associated with package | ||
| 34 | |||||
| 35 | sub _throw_Error_Simple | ||||
| 36 | { | ||||
| 37 | my $args = shift; | ||||
| 38 | return Error::Simple->new($args->{'text'}); | ||||
| 39 | } | ||||
| 40 | |||||
| 41 | 1 | 1µs | $Error::ObjectifyCallback = \&_throw_Error_Simple; | ||
| 42 | |||||
| 43 | |||||
| 44 | # Exported subs are defined in Error::subs | ||||
| 45 | |||||
| 46 | 2 | 739µs | 1 | 4µs | # spent 4µs within Error::BEGIN@46 which was called:
# once (4µs+0s) by Bio::Root::Root::BEGIN@146 at line 46 # 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 | ||||
| 49 | 7 | 20µ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 | |||||
| 63 | 1 | 255µ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 | |||||
| 69 | sub 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 | |||||
| 92 | sub 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 | |||||
| 110 | sub 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 | |||||
| 125 | sub 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 | |||||
| 144 | sub 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 | |||||
| 177 | sub 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 | |||||
| 191 | sub 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 | |||||
| 202 | sub 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 | |||||
| 213 | sub 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 | |||||
| 226 | sub object { | ||||
| 227 | my $self = shift; | ||||
| 228 | exists $self->{'-object'} ? $self->{'-object'} : undef; | ||||
| 229 | } | ||||
| 230 | |||||
| 231 | sub file { | ||||
| 232 | my $self = shift; | ||||
| 233 | exists $self->{'-file'} ? $self->{'-file'} : undef; | ||||
| 234 | } | ||||
| 235 | |||||
| 236 | sub line { | ||||
| 237 | my $self = shift; | ||||
| 238 | exists $self->{'-line'} ? $self->{'-line'} : undef; | ||||
| 239 | } | ||||
| 240 | |||||
| 241 | sub text { | ||||
| 242 | my $self = shift; | ||||
| 243 | exists $self->{'-text'} ? $self->{'-text'} : undef; | ||||
| 244 | } | ||||
| 245 | |||||
| 246 | # overload methods | ||||
| 247 | |||||
| 248 | sub stringify { | ||||
| 249 | my $self = shift; | ||||
| 250 | defined $self->{'-text'} ? $self->{'-text'} : "Died"; | ||||
| 251 | } | ||||
| 252 | |||||
| 253 | sub value { | ||||
| 254 | my $self = shift; | ||||
| 255 | exists $self->{'-value'} ? $self->{'-value'} : undef; | ||||
| 256 | } | ||||
| 257 | |||||
| 258 | package Error::Simple; | ||||
| 259 | |||||
| 260 | 2 | 179µs | 2 | 48µ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 # spent 28µs making 1 call to Error::Simple::BEGIN@260
# spent 20µs making 1 call to vars::import |
| 261 | |||||
| 262 | 1 | 600ns | $VERSION = "0.17021"; | ||
| 263 | |||||
| 264 | 1 | 10µs | @Error::Simple::ISA = qw(Error); | ||
| 265 | |||||
| 266 | sub 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 | |||||
| 282 | sub 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 | |||||
| 296 | package Error::subs; | ||||
| 297 | |||||
| 298 | 2 | 24µs | 1 | 5µ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 # spent 5µs making 1 call to Error::subs::BEGIN@298 |
| 299 | 2 | 1.48ms | 2 | 87µ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 # spent 47µs making 1 call to Error::subs::BEGIN@299
# spent 40µs making 1 call to vars::import |
| 300 | |||||
| 301 | 1 | 2µs | @EXPORT_OK = qw(try with finally except otherwise); | ||
| 302 | 1 | 2µs | %EXPORT_TAGS = (try => \@EXPORT_OK); | ||
| 303 | |||||
| 304 | 1 | 7µs | @ISA = qw(Exporter); | ||
| 305 | |||||
| 306 | sub 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 | |||||
| 396 | sub 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 | |||||
| 465 | sub with (&;$) { | ||||
| 466 | @_ | ||||
| 467 | } | ||||
| 468 | |||||
| 469 | sub 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 | |||||
| 478 | sub 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 | |||||
| 502 | sub 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 | |||||
| 516 | 1; | ||||
| 517 | |||||
| 518 | package Error::WarnDie; | ||||
| 519 | |||||
| 520 | sub 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 | |||||
| 534 | 1 | 100ns | my $old_DIE; | ||
| 535 | 1 | 100ns | my $old_WARN; | ||
| 536 | |||||
| 537 | sub 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 | |||||
| 582 | sub 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 | |||||
| 603 | sub import | ||||
| 604 | { | ||||
| 605 | $old_DIE = $SIG{__DIE__}; | ||||
| 606 | $old_WARN = $SIG{__WARN__}; | ||||
| 607 | |||||
| 608 | $SIG{__DIE__} = \&DEATH; | ||||
| 609 | $SIG{__WARN__} = \&TAXES; | ||||
| 610 | } | ||||
| 611 | |||||
| 612 | 1 | 25µs | 1; | ||
| 613 | |||||
| 614 | __END__ |