line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package X::Tiny::Base; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
1555
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
50
|
|
4
|
2
|
|
|
2
|
|
9
|
use warnings; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
92
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
my %CALL_STACK; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
my %PROPAGATIONS; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=encoding utf-8 |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
X::Tiny::Base - super-light exception base class |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 SYNOPSIS |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
package My::Module::X::Base; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
use parent qw( X::Tiny::Base ); |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub _new { |
23
|
|
|
|
|
|
|
my ($class, @args) = @_; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
... |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#Optionally, redefine this: |
29
|
|
|
|
|
|
|
sub get { |
30
|
|
|
|
|
|
|
my ($self, $attr_name) = @_; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
... |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
#Optionally, redefine this: |
36
|
|
|
|
|
|
|
sub get_message { ... } |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
#Optionally, redefine this: |
39
|
|
|
|
|
|
|
sub to_string { ... } |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
#If you override this, be sure also to call the base method. |
42
|
|
|
|
|
|
|
sub DESTROY { |
43
|
|
|
|
|
|
|
my ($self) = @_; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
... |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
#vv This. Be sure to do this in your override method. |
48
|
|
|
|
|
|
|
$self->SUPER::DESTROY(); |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
=head1 DESCRIPTION |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
This base class can be subclassed into your distribution’s own |
54
|
|
|
|
|
|
|
exception base class (e.g., C), or you can treat it |
55
|
|
|
|
|
|
|
as that base class itself (i.e., forgo C). |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
C serves two functions: |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=over |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
=item 1) It is a useful set of defaults for overridable methods. |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
=item 2) Framework handling of L stringification behavior, |
64
|
|
|
|
|
|
|
e.g., when an uncaught exception is printed. |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=back |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
That stringification’s precise formatting is not defined; however, it |
69
|
|
|
|
|
|
|
will always include, in addition to the exception’s main message: |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
=over |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=item * A stack trace (including function arguments) |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
B For security purposes, take care not to expose any function |
76
|
|
|
|
|
|
|
arguments that might contain sensitive information (e.g., passwords). |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
=item * Propagations |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
=back |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
There is currently no access provided in code to these; if that’s something |
83
|
|
|
|
|
|
|
you’d like to have, let me know. |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
B The overload stringification doesn’t seem to work as implemented in |
86
|
|
|
|
|
|
|
Perl 5.8 or earlier. Perl 5.8 went end-of-life on 14 December 2008. Yeah. |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
=head1 SUBCLASS INTERFACE |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
The default behaviors seem pretty usable and desirable to me, but there may |
91
|
|
|
|
|
|
|
be circumstances where someone wants other behaviors. Toward that end, |
92
|
|
|
|
|
|
|
the following methods are meant to be overridden in subclasses: |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head2 I->OVERLOAD() |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
Returns a boolean to indicate whether this exception class should load |
97
|
|
|
|
|
|
|
L as part of creating exceptions. If you don’t want the |
98
|
|
|
|
|
|
|
memory overhead of L, then make this return 0. It returns 1 |
99
|
|
|
|
|
|
|
by default. |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
You might also make this 0 if, for example, you want to handle the |
102
|
|
|
|
|
|
|
L behavior yourself. (But at that point, why use X::Tiny??) |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
=cut |
105
|
|
|
|
|
|
|
|
106
|
2
|
|
|
2
|
|
8
|
use constant OVERLOAD => 1; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
1332
|
|
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=head2 I->_new( MESSAGE, KEY1 => VALUE1, .. ) |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
The main constructor. Whatever args this accepts are the args that |
111
|
|
|
|
|
|
|
you should use to create exceptions via your L subclass’s |
112
|
|
|
|
|
|
|
C method. You’re free to design whatever internal representation |
113
|
|
|
|
|
|
|
you want for your class: hash reference, array reference, etc. |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
The default implementation accepts a string message and, optionally, a |
116
|
|
|
|
|
|
|
list of key/value pairs. It is useful that subclasses of your base class |
117
|
|
|
|
|
|
|
define their own MESSAGE, so all you’ll pass in is a specific piece of |
118
|
|
|
|
|
|
|
information about this instance—e.g., an error code, a parameter name, etc. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=cut |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub _new { |
123
|
5
|
|
|
5
|
|
20
|
my ( $class, $string, %attrs ) = @_; |
124
|
|
|
|
|
|
|
|
125
|
5
|
|
|
|
|
15
|
return bless [ $string, \%attrs ], $class; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=head2 I->get_messaage() |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
Return the exception’s main MESSAGE. |
131
|
|
|
|
|
|
|
This is useful for contexts where you want to encapsulate the error |
132
|
|
|
|
|
|
|
internals from how you’re reporting them, e.g., for protocols. |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=cut |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub get_message { |
137
|
1
|
|
|
1
|
0
|
5
|
return $_[0][0]; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=head2 I->get( ATTRIBUTE_NAME ) |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
Retrieves the value of an attribute. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=cut |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub get { |
147
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $attr ) = @_; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
#Do we need to clone this? Could JSON suffice, or do we need Clone? |
150
|
0
|
|
|
|
|
0
|
return $self->[1]{$attr}; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=head2 I->to_string() |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
Creates a simple string representation of your exception. The default |
156
|
|
|
|
|
|
|
implementation contains the class and the MESSAGE given on instantiation. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
This method’s return value should B include a strack trace; |
159
|
|
|
|
|
|
|
L’s internals handle that one for you. |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=cut |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
sub to_string { |
164
|
5
|
|
|
5
|
1
|
8
|
my ($self) = @_; |
165
|
|
|
|
|
|
|
|
166
|
5
|
|
|
|
|
23
|
return sprintf '%s: %s', ref($self), $self->[0]; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=head1 DESTRUCTOR METHODS |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
If you define your own C method, make sure you also call |
174
|
|
|
|
|
|
|
C, or else you’ll get memory leaks as L’s |
175
|
|
|
|
|
|
|
internal tracking of object properties will never be cleared out. |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=cut |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub DESTROY { |
180
|
5
|
|
|
5
|
|
2150
|
my ($self) = @_; |
181
|
|
|
|
|
|
|
|
182
|
5
|
|
|
|
|
12
|
delete $CALL_STACK{$self->_get_strval()}; |
183
|
5
|
|
|
|
|
34
|
delete $PROPAGATIONS{$self->_get_strval()}; |
184
|
|
|
|
|
|
|
|
185
|
5
|
|
|
|
|
57
|
return; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub new { |
191
|
5
|
|
|
5
|
0
|
14
|
my ($class, @args) = @_; |
192
|
|
|
|
|
|
|
|
193
|
5
|
50
|
|
|
|
35
|
$class->_check_overload() if $class->OVERLOAD(); |
194
|
|
|
|
|
|
|
|
195
|
5
|
|
|
|
|
15
|
my $self = $class->_new(@args); |
196
|
|
|
|
|
|
|
|
197
|
5
|
|
|
|
|
12
|
$CALL_STACK{$self->_get_strval()} = [ _get_call_stack(2) ]; |
198
|
|
|
|
|
|
|
|
199
|
5
|
|
|
|
|
71
|
return $self; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub PROPAGATE { |
205
|
1
|
|
|
1
|
0
|
2
|
my ($self, $file, $line) = @_; |
206
|
|
|
|
|
|
|
|
207
|
1
|
|
|
|
|
2
|
push @{ $PROPAGATIONS{$self->_get_strval()} }, [ $file, $line ]; |
|
1
|
|
|
|
|
2
|
|
208
|
|
|
|
|
|
|
|
209
|
1
|
|
|
|
|
8
|
return $self; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
my %_OVERLOADED; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
sub _check_overload { |
215
|
5
|
|
|
5
|
|
9
|
my ( $class, $str ) = @_; |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
#cf. eval_bug.readme |
218
|
5
|
|
|
|
|
9
|
my $eval_err = $@; |
219
|
|
|
|
|
|
|
|
220
|
2
|
|
66
|
2
|
|
12
|
$_OVERLOADED{$class} ||= eval qq{ |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
28
|
|
|
5
|
|
|
|
|
220
|
|
221
|
|
|
|
|
|
|
package $class; |
222
|
|
|
|
|
|
|
use overload (q<""> => __PACKAGE__->can('__spew')); |
223
|
|
|
|
|
|
|
1; |
224
|
|
|
|
|
|
|
}; |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
#Should never happen as long as overload.pm is available. |
227
|
5
|
50
|
|
|
|
14
|
warn if !$_OVERLOADED{$class}; |
228
|
|
|
|
|
|
|
|
229
|
5
|
|
|
|
|
9
|
$@ = $eval_err; |
230
|
|
|
|
|
|
|
|
231
|
5
|
|
|
|
|
9
|
return; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
sub _get_strval { |
235
|
27
|
|
|
27
|
|
48
|
my ($self) = @_; |
236
|
|
|
|
|
|
|
|
237
|
27
|
50
|
33
|
|
|
125
|
if ( overload->can('Overloaded') && overload::Overloaded($self) ) { |
238
|
27
|
|
|
|
|
3370
|
return overload::StrVal($self); |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
0
|
|
|
|
|
0
|
return q<> . $self; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
sub _get_call_stack { |
245
|
5
|
|
|
5
|
|
10
|
my ($level) = @_; |
246
|
|
|
|
|
|
|
|
247
|
5
|
|
|
|
|
6
|
my @stack; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
package DB; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
#This local() causes pre-5.16 Perl to segfault. |
252
|
5
|
50
|
|
|
|
58
|
local @DB::args if $^V ge v5.16.0; |
253
|
|
|
|
|
|
|
|
254
|
5
|
|
|
|
|
42
|
while ( my @call = (caller $level)[3, 1, 2] ) { |
255
|
11
|
|
|
|
|
64
|
my ($pkg) = ($call[0] =~ m<(.+)::>); |
256
|
|
|
|
|
|
|
|
257
|
11
|
50
|
66
|
|
|
71
|
if (!$pkg || !$pkg->isa(__PACKAGE__)) { |
258
|
11
|
|
|
|
|
22
|
push @call, \@DB::args; |
259
|
11
|
|
|
|
|
16
|
push @stack, \@call; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
11
|
|
|
|
|
51
|
$level++; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
5
|
|
|
|
|
27
|
return @stack; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
sub __spew { |
269
|
5
|
|
|
5
|
|
393
|
my ($self) = @_; |
270
|
|
|
|
|
|
|
|
271
|
5
|
|
|
|
|
18
|
my $spew = $self->to_string(); |
272
|
|
|
|
|
|
|
|
273
|
5
|
50
|
|
|
|
23
|
if ( rindex($spew, $/) != (length($spew) - length($/)) ) { |
274
|
5
|
|
|
|
|
8
|
my $args; |
275
|
|
|
|
|
|
|
$spew .= $/ . join( q<>, map { |
276
|
14
|
|
|
|
|
43
|
$args = join(', ', @{ $_->[3] } ); |
|
14
|
|
|
|
|
27
|
|
277
|
14
|
|
|
|
|
61
|
"\t==> $_->[0]($args) (called in $_->[1] at line $_->[2])$/" |
278
|
5
|
|
|
|
|
8
|
} @{ $CALL_STACK{$self->_get_strval()} } ); |
|
5
|
|
|
|
|
12
|
|
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
5
|
100
|
|
|
|
15
|
if ( $PROPAGATIONS{ $self->_get_strval() } ) { |
282
|
1
|
|
|
|
|
6
|
$spew .= join( q<>, map { "\t...propagated at $_->[0], line $_->[1]$/" } @{ $PROPAGATIONS{$self->_get_strval()} } ); |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
2
|
|
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
5
|
|
|
|
|
52
|
return $spew; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
1; |