line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Devel::DollarAt; |
2
|
1
|
|
|
1
|
|
14245
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
23
|
|
3
|
1
|
|
|
1
|
|
3
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
24
|
|
4
|
1
|
|
|
1
|
|
3
|
use base qw(Class::Accessor::Fast); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
447
|
|
5
|
1
|
|
|
1
|
|
2415
|
use Devel::Backtrace; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
50
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '0.02'; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
__PACKAGE__->mk_accessors( |
10
|
|
|
|
|
|
|
qw(backtrace err propagated inputline inputhandle filename line) |
11
|
|
|
|
|
|
|
); |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# Note that to_string also internally called if an exception isn't catched by |
14
|
|
|
|
|
|
|
# any eval and the error must be printed to STDERR. |
15
|
1
|
|
|
1
|
|
6
|
use overload '""' => \&to_string; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
7
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
$SIG{__DIE__} = \&_diehandler; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our $FRAME; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# This will be called every time the code says "die". However it won't be |
22
|
|
|
|
|
|
|
# called for other errors, such as division by zero. So we still have to use |
23
|
|
|
|
|
|
|
# $SIG{__DIE__}. |
24
|
|
|
|
|
|
|
*CORE::GLOBAL::die = sub (@) { |
25
|
0
|
|
|
0
|
|
0
|
my $text = ''; |
26
|
0
|
|
0
|
|
|
0
|
defined and $text .= $_ for @_; |
27
|
|
|
|
|
|
|
|
28
|
0
|
|
|
|
|
0
|
my $err = $@; |
29
|
|
|
|
|
|
|
|
30
|
0
|
0
|
0
|
|
|
0
|
if (defined($err) && length($err) && !length $text) { |
|
|
|
0
|
|
|
|
|
31
|
|
|
|
|
|
|
# In this case, perl would pass "$@\t...propagated at foo line bar.\n" |
32
|
|
|
|
|
|
|
# to the __DIE__ handler. Because we don't want to parse that, we make |
33
|
|
|
|
|
|
|
# perl think $text is not empty. |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# We have to store $err in our NullMessage because perl will cleanse $@ |
36
|
|
|
|
|
|
|
# before calling the __DIE__ handler. This is very strange, because it |
37
|
|
|
|
|
|
|
# won't get cleansed if we don't override *CORE::GLOBAL::die. |
38
|
0
|
|
|
|
|
0
|
$text = Devel::DollarAt::NullMessage->_new(propagated=>$err); |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
0
|
|
|
|
|
0
|
CORE::die($text); |
42
|
|
|
|
|
|
|
}; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub _diehandler { |
45
|
3
|
|
|
3
|
|
62
|
my ($err) = @_; |
46
|
|
|
|
|
|
|
|
47
|
3
|
|
|
|
|
5
|
my $propagated = $@; |
48
|
|
|
|
|
|
|
|
49
|
3
|
50
|
33
|
|
|
10
|
if (ref($err) && $err->isa('Devel::DollarAt::NullMessage')) { |
50
|
0
|
|
|
|
|
0
|
$propagated = $err->{propagated}; |
51
|
0
|
|
|
|
|
0
|
$err = ''; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
3
|
|
|
|
|
16
|
my $backtrace = Devel::Backtrace->new(1); |
55
|
3
|
|
|
|
|
9
|
my $skip = $backtrace->skipmysubs(); # skips this handler plus our overridden |
56
|
|
|
|
|
|
|
# CORE::GLOBAL::die if possible |
57
|
3
|
50
|
|
|
|
11
|
CORE::die "Strange:\n$backtrace" unless $skip; |
58
|
|
|
|
|
|
|
|
59
|
3
|
|
|
|
|
5
|
my ($inputhandle, $inputline); |
60
|
3
|
50
|
|
|
|
37
|
if ($err =~ s/^(.*) at .*?(?:<(.*)> line (\d+)|)\.\n\z/$1/s) { |
61
|
3
|
|
|
|
|
6
|
($inputhandle, $inputline) = ($2, $3); |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
3
|
|
|
|
|
8
|
my $dollarat = __PACKAGE__->_new({ |
65
|
|
|
|
|
|
|
backtrace => $backtrace, |
66
|
|
|
|
|
|
|
err => $err, |
67
|
|
|
|
|
|
|
filename => $skip->filename, |
68
|
|
|
|
|
|
|
line => $skip->line, |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
); |
71
|
|
|
|
|
|
|
|
72
|
3
|
50
|
|
|
|
9
|
if (defined $inputline) { |
73
|
0
|
|
|
|
|
0
|
$dollarat->inputline($inputline); |
74
|
0
|
|
|
|
|
0
|
$dollarat->inputhandle($inputhandle); |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
3
|
100
|
66
|
|
|
14
|
if (defined $propagated and length $propagated) { |
78
|
1
|
|
|
|
|
2
|
$dollarat->propagated($propagated); |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
3
|
|
|
|
|
67
|
CORE::die($dollarat); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# Try to appear exactly like the normal $@ |
85
|
|
|
|
|
|
|
sub to_string { |
86
|
3
|
|
|
3
|
1
|
10
|
my $this = shift; |
87
|
|
|
|
|
|
|
|
88
|
3
|
|
|
|
|
7
|
my $text = $this->err; |
89
|
|
|
|
|
|
|
|
90
|
3
|
50
|
|
|
|
13
|
if (defined ($this->propagated)) { |
91
|
0
|
0
|
|
|
|
0
|
if (!length($text)) { |
92
|
0
|
|
|
|
|
0
|
$text = $this->propagated . "\t...propagated"; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
3
|
50
|
|
|
|
16
|
unless ($text =~ /\n\z/) { |
97
|
3
|
|
|
|
|
8
|
$text .= ' at ' . $this->filename . ' line ' . $this->line; |
98
|
3
|
50
|
|
|
|
24
|
if (defined $this->inputline) { |
99
|
0
|
|
|
|
|
0
|
$text .= ', <'.$this->inputhandle . '> line ' . $this->inputline; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
3
|
|
|
|
|
11
|
$text .= '.'; |
104
|
3
|
50
|
|
|
|
5
|
$text = "[[$text]]" if $FRAME; |
105
|
3
|
|
|
|
|
4
|
$text .= "\n"; |
106
|
|
|
|
|
|
|
|
107
|
3
|
|
|
|
|
22
|
return $text; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub _new { |
111
|
3
|
|
|
3
|
|
26
|
my $class = shift; |
112
|
3
|
|
|
|
|
13
|
my $this = $class->SUPER::new(@_); |
113
|
|
|
|
|
|
|
|
114
|
3
|
|
|
|
|
20
|
return $this; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub import { |
118
|
1
|
|
|
1
|
|
7
|
my $class = shift; |
119
|
1
|
|
|
|
|
1021
|
for (@_) { |
120
|
0
|
0
|
|
|
|
|
if ('frame' eq $_) { |
121
|
0
|
|
|
|
|
|
$FRAME = 1; |
122
|
|
|
|
|
|
|
} else { |
123
|
0
|
|
|
|
|
|
die 'Unknown parameter for '.__PACKAGE__.": $_"; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
}; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
sub redie { |
129
|
0
|
|
|
0
|
1
|
|
my $this = shift; |
130
|
0
|
|
|
|
|
|
my ($package, $filename, $line) = caller; |
131
|
0
|
|
|
|
|
|
push @{$this->{redispatch_points}}, Devel::DollarAt::RedispatchPoint->new({ |
|
0
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
package => $package, |
133
|
|
|
|
|
|
|
filename => $filename, |
134
|
|
|
|
|
|
|
line => $line, |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
); |
137
|
0
|
|
|
|
|
|
local $SIG{__DIE__}; |
138
|
0
|
|
|
|
|
|
CORE::die($this); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
sub redispatch_points { |
142
|
0
|
|
|
0
|
1
|
|
my $this = shift; |
143
|
0
|
0
|
|
|
|
|
return @{$this->{redispatch_points} || []}; |
|
0
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
package # hide from pause |
147
|
|
|
|
|
|
|
Devel::DollarAt::NullMessage; |
148
|
|
|
|
|
|
|
#use overload '""' => sub {''}; |
149
|
0
|
|
|
0
|
|
|
sub _new { shift; bless {@_}; } |
|
0
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
package # hide from pause |
152
|
|
|
|
|
|
|
Devel::DollarAt::RedispatchPoint; |
153
|
1
|
|
|
1
|
|
569
|
use base qw(Class::Accessor::Fast); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
129
|
|
154
|
|
|
|
|
|
|
__PACKAGE__->mk_ro_accessors(qw(package filename line)); |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
use overload '""' => sub { |
157
|
0
|
|
|
0
|
|
0
|
my $this = shift; |
158
|
|
|
|
|
|
|
|
159
|
0
|
|
|
|
|
0
|
return 'redispatched from '.$this->package.' at ' |
160
|
|
|
|
|
|
|
.$this->filename.':'.$this->line."\n"; |
161
|
1
|
|
|
1
|
|
4
|
}; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
14
|
|
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
1 |
164
|
|
|
|
|
|
|
__END__ |