File Coverage

blib/lib/Gentoo/Overlay/Exceptions.pm
Criterion Covered Total %
statement 52 64 81.2
branch 4 10 40.0
condition 0 2 0.0
subroutine 19 22 86.3
pod 0 7 0.0
total 75 105 71.4


line stmt bran cond sub pod time code
1 7     7   618 use 5.006;
  7         18  
  7         220  
2 7     7   27 use strict;
  7         6  
  7         181  
3 7     7   25 use warnings;
  7         7  
  7         368  
4              
5             package Gentoo::Overlay::Exceptions;
6              
7             our $VERSION = '2.001001';
8              
9             # ABSTRACT: A custom Exception class for Gentoo which also has warning-style semantics instead of failure
10              
11             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
12              
13 7     7   499 use Moo qw( has with );
  7         11300  
  7         39  
14 7     7   5424 use Try::Tiny qw( try catch );
  7         5430  
  7         387  
15 7     7   518 use Types::Standard qw( HashRef Str ArrayRef );
  7         48922  
  7         43  
16 7     7   5145 use Type::Utils qw( declare where as );
  7         3393  
  7         39  
17 7     7   2980 use Sub::Exporter::Progressive -setup => { exports => [ 'exception', 'warning', ] };
  7         9  
  7         63  
18 7     7   3499 use String::Errf qw( errf );
  7         170601  
  7         44  
19 7     7   4963 use Const::Fast qw( const );
  7         5558  
  7         66  
20 7     7   3802 use namespace::clean -except => [ 'meta', 'import' ];
  7         52676  
  7         47  
21              
22             const our $W_SILENT => 'silent';
23             const our $W_WARNING => 'warning';
24             const our $W_FATAL => 'fatal';
25              
26             our $WARNINGS_ARE = $W_WARNING;
27              
28             has ident => (
29             is => 'ro',
30             isa => ( declare as Str, where { length && /\A\S/msx && /\S\z/msx } ),
31             required => 1,
32             );
33              
34             sub has_tag {
35 0     0 0 0 my ( $self, $tag ) = @_;
36              
37 0   0     0 $_ eq $tag && return 1 for $self->tags;
38              
39 0         0 return;
40             }
41              
42             sub tags {
43 0     0 0 0 my ($self) = @_;
44              
45             # Poor man's uniq:
46 0         0 my %tags = map { ; $_ => 1 } ( @{ $self->_instance_tags } );
  0         0  
  0         0  
47              
48 0 0       0 return wantarray ? keys %tags : ( keys %tags )[0];
49             }
50              
51             my $tag = declare Str, where { length };
52              
53             has instance_tags => (
54             is => 'ro',
55             isa => ArrayRef [$tag],
56             reader => '_instance_tags',
57             init_arg => 'tags',
58             default => sub { [] },
59             );
60              
61             has 'payload' => (
62             is => 'ro',
63             isa => HashRef,
64             required => 1,
65             default => sub { {} },
66             );
67              
68             sub as_string {
69 7     7 0 12243 my ($self) = @_;
70             ## no critic (RegularExpressions)
71 7         23 return join q{}, $self->message, qq{\n\n }, ( join qq{\n* }, ( split /\n/, $self->stack_trace ) ), qq{\n};
72             }
73              
74 7     7   4354 use overload ( q{""} => 'as_string' );
  7         14  
  7         56  
75              
76             ## no critic (Subroutines::RequireArgUnpacking)
77             sub exception {
78 4     4 0 63 return __PACKAGE__->throw(@_);
79             }
80              
81             sub warning {
82              
83             # This code is because warnings::register sucks.
84             # You can't do long-distance warning-changes that behave
85             # similar to exceptions.
86             #
87             # warnings::register can only be toggled in the direcltly
88             # preceeding scope.
89              
90 2 50   2 0 68 return if ( $WARNINGS_ARE eq $W_SILENT );
91 2 100       5 if ( $WARNINGS_ARE eq $W_WARNING ) {
92             ## no critic ( ErrorHandling::RequireCarping )
93 1         23 return warn __PACKAGE__->new(@_);
94             }
95 1         7 return __PACKAGE__->throw(@_);
96             }
97              
98              
99              
100              
101              
102             sub BUILDARGS {
103 6     6 0 4004 my ( undef, @args ) = @_;
104 6 50       20 if ( 1 == scalar @args ) {
105 0 0       0 if ( not ref $args[0] ) {
106 0         0 return { ident => $args[0] };
107             }
108 0         0 return $args[0];
109             }
110 6         101 return {@args};
111             }
112             has 'message_fmt' => (
113             is => 'ro',
114             isa => Str,
115             lazy => 1,
116             required => 1,
117             init_arg => 'message',
118             default => sub { shift->ident },
119             );
120             with( 'Throwable', 'StackTrace::Auto', );
121              
122             sub message {
123 7     7 0 9 my ($self) = @_;
124             return try {
125 7     7   318 errf( $self->message_fmt, $self->payload )
126             }
127             catch {
128 0     0     sprintf '%s (error during formatting)', $self->message_fmt;
129 7         49 },;
130             }
131              
132 7     7   2101 no Moo;
  7         13  
  7         55  
133              
134             1;
135              
136             __END__
137              
138             =pod
139              
140             =encoding UTF-8
141              
142             =head1 NAME
143              
144             Gentoo::Overlay::Exceptions - A custom Exception class for Gentoo which also has warning-style semantics instead of failure
145              
146             =head1 VERSION
147              
148             version 2.001001
149              
150             =for Pod::Coverage BUILDARGS
151              
152             =for Pod::Coverage ident message payload as_string exception warning has_tag tags
153              
154             =head1 AUTHOR
155              
156             Kent Fredric <kentnl@cpan.org>
157              
158             =head1 COPYRIGHT AND LICENSE
159              
160             This software is copyright (c) 2014 by Kent Fredric <kentnl@cpan.org>.
161              
162             This is free software; you can redistribute it and/or modify it under
163             the same terms as the Perl 5 programming language system itself.
164              
165             =cut