File Coverage

blib/lib/X/Tiny/Base.pm
Criterion Covered Total %
statement 63 66 95.4
branch 8 14 57.1
condition 5 9 55.5
subroutine 14 15 93.3
pod 2 5 40.0
total 92 109 84.4


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