File Coverage

blib/lib/Venus/Fault.pm
Criterion Covered Total %
statement 47 47 100.0
branch 6 8 75.0
condition 9 9 100.0
subroutine 12 12 100.0
pod 4 5 80.0
total 78 81 96.3


line stmt bran cond sub pod time code
1             package Venus::Fault;
2              
3 2     2   63 use 5.018;
  2         7  
4              
5 2     2   12 use strict;
  2         4  
  2         48  
6 2     2   16 use warnings;
  2         8  
  2         323  
7              
8             use overload (
9             '""' => 'explain',
10 1     1   23 'eq' => sub{$_[0]->{message} eq "$_[1]"},
11 1     1   22 'ne' => sub{$_[0]->{message} ne "$_[1]"},
12 1     1   2 'qr' => sub{qr/@{[quotemeta($_[0]->{message})]}/},
  1         35  
13 2         48 '~~' => 'explain',
14             fallback => 1,
15 2     2   12 );
  2         4  
16              
17             # METHODS
18              
19             sub new {
20 12   100 12 0 93 return bless({message => $_[1] || 'Exception!'})->trace;
21             }
22              
23             sub explain {
24 23     23 1 780 my ($self) = @_;
25              
26 23 50       36 $self->trace(1) if !@{$self->frames};
  23         46  
27              
28 23         37 my $frames = $self->{'$frames'};
29              
30 23         41 my $file = $frames->[0][1];
31 23         31 my $line = $frames->[0][2];
32 23         40 my $pack = $frames->[0][0];
33 23         33 my $subr = $frames->[0][3];
34              
35 23         34 my $message = $self->{message};
36              
37 23         67 my @stacktrace = ("$message in $file at line $line");
38              
39 23 100       58 push @stacktrace, 'Traceback (reverse chronological order):' if @$frames > 1;
40              
41 23         89 @stacktrace = (join("\n\n", grep defined, @stacktrace), '');
42              
43 23         56 for (my $i = 1; $i < @$frames; $i++) {
44 261         718 my $pack = $frames->[$i][0];
45 261         334 my $file = $frames->[$i][1];
46 261         309 my $line = $frames->[$i][2];
47 261         362 my $subr = $frames->[$i][3];
48              
49 261         769 push @stacktrace, "$subr\n in $file at line $line";
50             }
51              
52 23         239 return join "\n", @stacktrace, "";
53             }
54              
55             sub frames {
56 42     42 1 68 my ($self) = @_;
57              
58 42   100     252 return $self->{'$frames'} //= [];
59             }
60              
61             sub throw {
62 2     2 1 6 my ($self, @args) = @_;
63              
64 2 50       9 $self = $self->new(@args) if !ref $self;
65              
66 2         24 die $self;
67             }
68              
69             sub trace {
70 15     15 1 40 my ($self, $offset, $limit) = @_;
71              
72 15         32 my $frames = $self->frames;
73              
74 15         49 @$frames = ();
75              
76 15   100     150 for (my $i = $offset // 1; my @caller = caller($i); $i++) {
77 186         494 push @$frames, [@caller];
78              
79 186 100 100     1093 last if defined $limit && $i + 1 == $offset + $limit;
80             }
81              
82 15         290 return $self;
83             }
84              
85             1;
86              
87              
88              
89             =head1 NAME
90              
91             Venus::Fault - Fault Class
92              
93             =cut
94              
95             =head1 ABSTRACT
96              
97             Fault Class for Perl 5
98              
99             =cut
100              
101             =head1 SYNOPSIS
102              
103             package main;
104              
105             use Venus::Fault;
106              
107             my $fault = Venus::Fault->new;
108              
109             # $fault->throw;
110              
111             =cut
112              
113             =head1 DESCRIPTION
114              
115             This package represents a generic system error (exception object).
116              
117             =cut
118              
119             =head1 METHODS
120              
121             This package provides the following methods:
122              
123             =cut
124              
125             =head2 explain
126              
127             explain() (Str)
128              
129             The explain method returns the error message and is used in stringification
130             operations.
131              
132             I>
133              
134             =over 4
135              
136             =item explain example 1
137              
138             # given: synopsis;
139              
140             my $explain = $fault->explain;
141              
142             # "Exception! in ...
143              
144             =back
145              
146             =cut
147              
148             =head2 frames
149              
150             frames() (ArrayRef)
151              
152             The frames method returns the compiled and stashed stack trace data.
153              
154             I>
155              
156             =over 4
157              
158             =item frames example 1
159              
160             # given: synopsis;
161              
162             my $frames = $fault->frames;
163              
164             # [
165             # ...
166             # [
167             # "main",
168             # "t/Venus_Fault.t",
169             # ...
170             # ],
171             # ]
172              
173             =back
174              
175             =cut
176              
177             =head2 throw
178              
179             throw(Str $message) (Fault)
180              
181             The throw method throws an error if the invocant is an object, or creates an
182             error object using the arguments provided and throws the created object.
183              
184             I>
185              
186             =over 4
187              
188             =item throw example 1
189              
190             # given: synopsis;
191              
192             my $throw = $fault->throw;
193              
194             # bless({ ... }, 'Venus::Fault')
195              
196             =back
197              
198             =cut
199              
200             =head2 trace
201              
202             trace(Int $offset, Int $limit) (Fault)
203              
204             The trace method compiles a stack trace and returns the object. By default it
205             skips the first frame.
206              
207             I>
208              
209             =over 4
210              
211             =item trace example 1
212              
213             # given: synopsis;
214              
215             my $trace = $fault->trace;
216              
217             # bless({ ... }, 'Venus::Fault')
218              
219             =back
220              
221             =over 4
222              
223             =item trace example 2
224              
225             # given: synopsis;
226              
227             my $trace = $fault->trace(0, 1);
228              
229             # bless({ ... }, 'Venus::Fault')
230              
231             =back
232              
233             =over 4
234              
235             =item trace example 3
236              
237             # given: synopsis;
238              
239             my $trace = $fault->trace(0, 2);
240              
241             # bless({ ... }, 'Venus::Fault')
242              
243             =back
244              
245             =cut
246              
247             =head1 OPERATORS
248              
249             This package overloads the following operators:
250              
251             =cut
252              
253             =over 4
254              
255             =item operation: C<(eq)>
256              
257             This package overloads the C operator.
258              
259             B
260              
261             # given: synopsis;
262              
263             my $result = $fault eq 'Exception!';
264              
265             # 1
266              
267             =back
268              
269             =over 4
270              
271             =item operation: C<(ne)>
272              
273             This package overloads the C operator.
274              
275             B
276              
277             # given: synopsis;
278              
279             my $result = $fault ne 'exception!';
280              
281             # 1
282              
283             =back
284              
285             =over 4
286              
287             =item operation: C<(qr)>
288              
289             This package overloads the C operator.
290              
291             B
292              
293             # given: synopsis;
294              
295             my $test = 'Exception!' =~ qr/$fault/;
296              
297             # 1
298              
299             =back
300              
301             =over 4
302              
303             =item operation: C<("")>
304              
305             This package overloads the C<""> operator.
306              
307             B
308              
309             # given: synopsis;
310              
311             my $result = "$fault";
312              
313             # "Exception!"
314              
315             =back
316              
317             =over 4
318              
319             =item operation: C<(~~)>
320              
321             This package overloads the C<~~> operator.
322              
323             B
324              
325             # given: synopsis;
326              
327             my $result = $fault ~~ 'Exception!';
328              
329             # 1
330              
331             =back
332              
333             =head1 AUTHORS
334              
335             Awncorp, C
336              
337             =cut
338              
339             =head1 LICENSE
340              
341             Copyright (C) 2000, Al Newkirk.
342              
343             This program is free software, you can redistribute it and/or modify it under
344             the terms of the Apache license version 2.0.
345              
346             =cut