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 |