File Coverage

blib/lib/Venus/Throw.pm
Criterion Covered Total %
statement 62 77 80.5
branch 16 20 80.0
condition 21 33 63.6
subroutine 13 15 86.6
pod 4 7 57.1
total 116 152 76.3


line stmt bran cond sub pod time code
1             package Venus::Throw;
2              
3 34     34   824 use 5.018;
  34         117  
4              
5 34     25   1587 use strict;
  25         102  
  25         623  
6 25     25   647 use warnings;
  25         56  
  25         839  
7              
8 25     24   226 use Venus::Class 'attr', 'base', 'with';
  24         61  
  24         212  
9              
10             base 'Venus::Kind::Utility';
11              
12             with 'Venus::Role::Stashable';
13              
14             use overload (
15 15     15   650 '""' => sub{$_[0]->catch('error')->explain},
16 0     0   0 '~~' => sub{$_[0]->catch('error')->explain},
17 24         420 fallback => 1,
18 24     24   197 );
  24         57  
19              
20             # ATTRIBUTES
21              
22             attr 'frame';
23             attr 'name';
24             attr 'message';
25             attr 'package';
26             attr 'parent';
27             attr 'context';
28              
29             # BUILDERS
30              
31             sub build_arg {
32 19     19 0 48 my ($self, $data) = @_;
33              
34             return {
35 19         74 package => $data,
36             };
37             }
38              
39             sub build_self {
40 157     157 0 439 my ($self, $data) = @_;
41              
42 157 100       614 $self->parent('Venus::Error') if !$self->parent;
43              
44 157         398 return $self;
45             }
46              
47             # METHODS
48              
49             sub as {
50 1     1 1 4 my ($self, $name) = @_;
51              
52 1         5 $self->name($name);
53              
54 1         10 return $self;
55             }
56              
57             sub assertion {
58 0     0 1 0 my ($self) = @_;
59              
60 0         0 my $assert = $self->SUPER::assertion;
61              
62 0         0 $assert->clear->expression('string');
63              
64 0         0 return $assert;
65             }
66              
67             sub capture {
68 7     7 0 19 my ($self, @args) = @_;
69              
70 7         22 my $frame = $self->frame;
71              
72 7   100     97 $self->stash(captured => {
73             callframe => [caller($frame // 1)],
74             arguments => [@args],
75             });
76              
77 7         44 return $self;
78             }
79              
80             sub error {
81 151     151 1 522 my ($self, $data) = @_;
82              
83 151         14617 require Venus::Error;
84              
85 151         601 my $frame = $self->frame;
86 151         587 my $name = $self->name;
87 151   66     676 my $context = $self->context || (caller($frame // 1))[3];
88 151   66     579 my $package = $self->package || join('::', map ucfirst, (caller(0))[0], 'error');
89 151         547 my $parent = $self->parent;
90 151         499 my $message = $self->message;
91              
92 151   100     935 $data //= {};
93 151   66     899 $data->{context} //= $context;
94 151 100 33     753 $data->{message} //= $message if $message;
95 151 100 33     839 $data->{name} //= $name if $name;
96              
97 151 100       235 if (%{$self->stash}) {
  151         470  
98 96   33     485 $data->{'$stash'} //= $self->stash;
99             }
100              
101 151         392 local $@;
102 23 100 100 23   229 if (!$package->can('new') and !eval "package $package; use base '$parent'; 1") {
  23         60  
  23         3136  
  151         4423  
103 1         8 my $throw = Venus::Throw->new(package => 'Venus::Throw::Error');
104 1         15 $throw->message($@);
105 1         6 $throw->stash(package => $package);
106 1         14 $throw->stash(parent => $parent);
107 1         12 $throw->error;
108             }
109 150 50       1241 if (!$parent->isa('Venus::Error')) {
110 0         0 my $throw = Venus::Throw->new(package => 'Venus::Throw::Error');
111 0         0 $throw->message(qq(Parent '$parent' doesn't derive from 'Venus::Error'));
112 0         0 $throw->stash(package => $package);
113 0         0 $throw->stash(parent => $parent);
114 0         0 $throw->error;
115             }
116 150 50       846 if (!$package->isa('Venus::Error')) {
117 0         0 my $throw = Venus::Throw->new(package => 'Venus::Throw::Error');
118 0         0 $throw->message(qq(Package '$package' doesn't derive from 'Venus::Error'));
119 0         0 $throw->stash(package => $package);
120 0         0 $throw->stash(parent => $parent);
121 0         0 $throw->error;
122             }
123              
124 150 50       772 @_ = ($package->new($data ? $data : ()));
125              
126 150         1597 goto $package->can('throw');
127             }
128              
129             sub on {
130 2     2 1 11 my ($self, $name) = @_;
131              
132 2         7 my $frame = $self->frame;
133              
134 2   50     30 my $routine = (split(/::/, (caller($frame // 1))[3]))[-1];
135              
136 2 100 66     17 undef $routine if $routine eq '__ANON__' || $routine eq '(eval)';
137              
138 2 50 66     34 $self->name(join('.', 'on', grep defined, $routine, $name)) if $routine || $name;
139              
140 2         65 return $self;
141             }
142              
143             1;
144              
145              
146              
147             =head1 NAME
148              
149             Venus::Throw - Throw Class
150              
151             =cut
152              
153             =head1 ABSTRACT
154              
155             Throw Class for Perl 5
156              
157             =cut
158              
159             =head1 SYNOPSIS
160              
161             package main;
162              
163             use Venus::Throw;
164              
165             my $throw = Venus::Throw->new;
166              
167             # $throw->error;
168              
169             =cut
170              
171             =head1 DESCRIPTION
172              
173             This package provides a mechanism for generating and raising errors (exception
174             objects).
175              
176             =cut
177              
178             =head1 ATTRIBUTES
179              
180             This package has the following attributes:
181              
182             =cut
183              
184             =head2 frame
185              
186             frame(Int)
187              
188             This attribute is read-write, accepts C<(Int)> values, and is optional.
189              
190             =cut
191              
192             =head2 name
193              
194             name(Str)
195              
196             This attribute is read-write, accepts C<(Str)> values, and is optional.
197              
198             =cut
199              
200             =head2 message
201              
202             message(Str)
203              
204             This attribute is read-write, accepts C<(Str)> values, and is optional.
205              
206             =cut
207              
208             =head2 package
209              
210             package(Str)
211              
212             This attribute is read-only, accepts C<(Str)> values, and is optional.
213              
214             =cut
215              
216             =head2 parent
217              
218             parent(Str)
219              
220             This attribute is read-only, accepts C<(Str)> values, is optional, and defaults to C<'Venus::Error'>.
221              
222             =cut
223              
224             =head2 context
225              
226             context(Str)
227              
228             This attribute is read-only, accepts C<(Str)> values, and is optional.
229              
230             =cut
231              
232             =head1 INHERITS
233              
234             This package inherits behaviors from:
235              
236             L
237              
238             =cut
239              
240             =head1 INTEGRATES
241              
242             This package integrates behaviors from:
243              
244             L
245              
246             =cut
247              
248             =head1 METHODS
249              
250             This package provides the following methods:
251              
252             =cut
253              
254             =head2 as
255              
256             as(Str $name) (Throw)
257              
258             The as method sets a L for the error and returns the invocant.
259              
260             I>
261              
262             =over 4
263              
264             =item as example 1
265              
266             # given: synopsis
267              
268             package main;
269              
270             $throw = $throw->as('on.handler');
271              
272             # bless({...}, 'Venus::Throw')
273              
274             =back
275              
276             =cut
277              
278             =head2 error
279              
280             error(HashRef $data) (Error)
281              
282             The error method throws the prepared error object.
283              
284             I>
285              
286             =over 4
287              
288             =item error example 1
289              
290             # given: synopsis;
291              
292             my $error = $throw->error;
293              
294             # bless({
295             # ...,
296             # "context" => "(eval)",
297             # "message" => "Exception!",
298             # }, "Main::Error")
299              
300             =back
301              
302             =over 4
303              
304             =item error example 2
305              
306             # given: synopsis;
307              
308             my $error = $throw->error({
309             message => 'Something failed!',
310             context => 'Test.error',
311             });
312              
313             # bless({
314             # ...,
315             # "context" => "Test.error",
316             # "message" => "Something failed!",
317             # }, "Main::Error")
318              
319             =back
320              
321             =over 4
322              
323             =item error example 3
324              
325             package main;
326              
327             use Venus::Throw;
328              
329             my $throw = Venus::Throw->new('Example::Error');
330              
331             my $error = $throw->error;
332              
333             # bless({
334             # ...,
335             # "context" => "(eval)",
336             # "message" => "Exception!",
337             # }, "Example::Error")
338              
339             =back
340              
341             =over 4
342              
343             =item error example 4
344              
345             package main;
346              
347             use Venus::Throw;
348              
349             my $throw = Venus::Throw->new(
350             package => 'Example::Error',
351             parent => 'Venus::Error',
352             );
353              
354             my $error = $throw->error({
355             message => 'Example error!',
356             });
357              
358             # bless({
359             # ...,
360             # "context" => "(eval)",
361             # "message" => "Example error!",
362             # }, "Example::Error")
363              
364             =back
365              
366             =over 4
367              
368             =item error example 5
369              
370             package Example::Error;
371              
372             use base 'Venus::Error';
373              
374             package main;
375              
376             use Venus::Throw;
377              
378             my $throw = Venus::Throw->new(
379             package => 'Example::Error::Unknown',
380             parent => 'Example::Error',
381             );
382              
383             my $error = $throw->error({
384             message => 'Example error (unknown)!',
385             });
386              
387             # bless({
388             # ...,
389             # "context" => "(eval)",
390             # "message" => "Example error (unknown)!",
391             # }, "Example::Error::Unknown")
392              
393             =back
394              
395             =over 4
396              
397             =item error example 6
398              
399             package main;
400              
401             use Venus::Throw;
402              
403             my $throw = Venus::Throw->new(
404             package => 'Example::Error::NoThing',
405             parent => 'No::Thing',
406             );
407              
408             my $error = $throw->error({
409             message => 'Example error (no thing)!',
410             });
411              
412             # No::Thing does not exist
413              
414             # Exception! Venus::Throw::Error (isa Venus::Error)
415              
416             =back
417              
418             =over 4
419              
420             =item error example 7
421              
422             # given: synopsis;
423              
424             my $error = $throw->error({
425             name => 'on.test.error',
426             context => 'Test.error',
427             message => 'Something failed!',
428             });
429              
430             # bless({
431             # ...,
432             # "context" => "Test.error",
433             # "message" => "Something failed!",
434             # "name" => "on_test_error",
435             # }, "Main::Error")
436              
437             =back
438              
439             =cut
440              
441             =head2 on
442              
443             on(Str $name) (Throw)
444              
445             The on method sets a L for the error in the form of
446             C<"on.$subroutine.$name"> or C<"on.$name"> (if outside of a subroutine) and
447             returns the invocant.
448              
449             I>
450              
451             =over 4
452              
453             =item on example 1
454              
455             # given: synopsis
456              
457             package main;
458              
459             $throw = $throw->on('handler');
460              
461             # bless({...}, 'Venus::Throw')
462              
463             # $throw->name;
464              
465             # "on.handler"
466              
467             =back
468              
469             =over 4
470              
471             =item on example 2
472              
473             # given: synopsis
474              
475             package main;
476              
477             sub execute {
478             $throw->on('handler');
479             }
480              
481             $throw = execute();
482              
483             # bless({...}, 'Venus::Throw')
484              
485             # $throw->name;
486              
487             # "on.execute.handler"
488              
489             =back
490              
491             =cut
492              
493             =head1 OPERATORS
494              
495             This package overloads the following operators:
496              
497             =cut
498              
499             =over 4
500              
501             =item operation: C<("")>
502              
503             This package overloads the C<""> operator.
504              
505             B
506              
507             # given: synopsis;
508              
509             my $result = "$throw";
510              
511             # "Exception!"
512              
513             =back
514              
515             =over 4
516              
517             =item operation: C<(~~)>
518              
519             This package overloads the C<~~> operator.
520              
521             B
522              
523             # given: synopsis;
524              
525             my $result = $throw ~~ 'Exception!';
526              
527             # 1
528              
529             =back
530              
531             =head1 AUTHORS
532              
533             Awncorp, C
534              
535             =cut
536              
537             =head1 LICENSE
538              
539             Copyright (C) 2000, Al Newkirk.
540              
541             This program is free software, you can redistribute it and/or modify it under
542             the terms of the Apache license version 2.0.
543              
544             =cut