File Coverage

blib/lib/Gentoo/PerlMod/Version/Error.pm
Criterion Covered Total %
statement 53 62 85.4
branch 9 12 75.0
condition 3 6 50.0
subroutine 14 14 100.0
pod 5 5 100.0
total 84 99 84.8


line stmt bran cond sub pod time code
1 4     4   18899 use 5.006;
  4         13  
2 4     4   18 use strict;
  4         6  
  4         220  
3 4     4   17 use warnings;
  4         5  
  4         487  
4              
5             package Gentoo::PerlMod::Version::Error;
6              
7             our $VERSION = 'v0.8.1';
8              
9             # ABSTRACT: Various error message and diagnostic bits.
10              
11             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
12              
13             BEGIN {
14              
15 4     4   8 for my $env (qw( opts hasopt getopt )) {
16             my $code = sub {
17 18     18   469 require Gentoo::PerlMod::Version::Env;
18 18         69 my $sub = Gentoo::PerlMod::Version::Env->can($env);
19 18         36 goto $sub;
20 12         29 };
21             ## no critic ( ProhibitNoStrict )
22              
23 4     4   19 no strict 'refs';
  4         4  
  4         179  
24 12         13 *{ __PACKAGE__ . '::_env_' . $env } = $code;
  12         2156  
25             }
26              
27             }
28              
29              
30              
31              
32              
33              
34              
35              
36              
37             sub perlver_undefined {
38 2     2 1 798 my ($config) = @_;
39             ## no critic ( RequireInterpolationOfMetachars )
40 2         12 return _fatal(
41             {
42             code => 'perlver_undefined',
43             config => $config,
44             message => 'Argument \'$perlver\' to gentooize_version was undefined',
45             },
46             );
47             }
48              
49              
50              
51              
52              
53              
54              
55             sub matches_trial_regex_nonlax {
56 3     3 1 2222 my ( $perlver, $config, ) = @_;
57 3         24 return _fatal(
58             {
59             code => 'matches_trial_regex_nonlax',
60             config => $config,
61             want_lax => 1,
62             message => 'Invalid version format (non-numeric data, either _ or -TRIAL ).',
63             message_extra_tainted => qq{ Version: >$perlver< },
64             version => $perlver,
65             },
66             );
67             }
68              
69              
70              
71              
72              
73              
74              
75             sub not_decimal_or_trial {
76 3     3 1 2216 my ( $perlver, $config ) = @_;
77 3         16 return _fatal(
78             {
79             code => 'not_decimal_or_trial',
80             config => $config,
81             want_lax => 2,
82             message => 'Invalid version format (non-numeric/ASCII data).',
83             message_extra_tainted => qq{ Version: >$perlver< },
84             version => $perlver,
85             },
86             );
87             }
88              
89              
90              
91              
92              
93              
94              
95             sub bad_char {
96 2     2 1 2443 my ( $char, $char_ord ) = @_;
97 2         16 return _fatal(
98             {
99             code => 'bad_char',
100             message => 'A Character in the version is not in the ascii-to-int translation table.',
101             message_extra_tainted => qq{ Missing character: $char ( $char_ord )},
102             },
103             );
104             }
105              
106              
107              
108              
109              
110              
111              
112             sub lax_multi_underscore {
113 2     2 1 1419 my ($version) = @_;
114 2         11 return _fatal(
115             {
116             code => 'lax_multi_underscore',
117             message => q{More than one _ in a version is not permitted},
118             message_extra_tainted => qq{ Version: >$version< },
119             version => $version,
120             },
121             );
122             }
123             #
124             # _format_error({
125             # code => "some_string",
126             # message => "Some message"
127             # message_extra_tainted => "And $tainted " # extra data for non-taint-safe envs.
128             # want_lax => n # optional
129             # })
130             #
131              
132             sub _format_error {
133 9     9   2127 my ($conf) = @_;
134 9         11 my $message = $conf->{message};
135 9 100       19 if ( exists $conf->{want_lax} ) {
136 4         3 my $lax = $conf->{want_lax};
137 4         10 $message .= qq{\n Set { lax => $lax } for more permissive behaviour. };
138             }
139 9 50       14 if ( _env_hasopt('taint_safe') ) {
140 0         0 return $message;
141             }
142 9 50       12 if ( _env_hasopt('carp_debug') ) {
143 0         0 $conf->{env_config} = _env_opts;
144 0         0 require Data::Dumper;
145 0         0 local $Data::Dumper::Indent = 2;
146 0         0 local $Data::Dumper::Purity = 0;
147 0         0 local $Data::Dumper::Useqq = 1;
148 0         0 local $Data::Dumper::Terse = 1;
149 0         0 local $Data::Dumper::Quotekeys = 0;
150 0         0 return Data::Dumper::Dumper($conf);
151             }
152 9 100       36 if ( exists $conf->{'message_extra_tainted'} ) {
153 7         12 $message .= $conf->{'message_extra_tainted'};
154             }
155 9 50       12 if ( exists $conf->{'stack'} ) {
156 9         8 for ( @{ $conf->{stack} } ) {
  9         17  
157 28 100       75 if ( $_->[0] !~ /\AGentoo::PerlMod::Version(?:|::Error|::Env)\z/msx ) {
158 9   50     53 $message .= sprintf qq[\n - From %s in %s at line %s\n], $_->[0] || q[], $_->[1] || q[], $_->[2] || q[];
      50        
      50        
159 9         8 last;
160             }
161             }
162             }
163 9         49 return $message;
164             }
165              
166 4     4   1828 use overload q[""] => \&_format_error;
  4         2395  
  4         27  
167              
168             sub _fatal {
169 7     7   8 my ($conf) = @_;
170 7         16 require Carp;
171             $conf->{stack} = [
172 77         118 map { [ $_->[0], $_->[1], $_->[2], ] }
173 7         11 map { [ caller $_, ] } 0 .. 10,
  77         239  
174             ];
175 7         166 return Carp::croak( bless $conf, __PACKAGE__ );
176             }
177              
178             1;
179              
180             __END__