File Coverage

blib/lib/MooX/Value.pm
Criterion Covered Total %
statement 29 30 96.6
branch 4 6 66.6
condition n/a
subroutine 10 10 100.0
pod 2 2 100.0
total 45 48 93.7


line stmt bran cond sub pod time code
1             package MooX::Value;
2              
3 9     9   55517 use warnings;
  9         14  
  9         260  
4 9     9   37 use strict;
  9         9  
  9         211  
5              
6 9     9   1466 use Moo;
  9         32025  
  9         40  
7 9     9   6173 use namespace::clean;
  9         25979  
  9         39  
8              
9             our $VERSION = '0.04';
10              
11             has value => ( is => 'ro' );
12              
13             sub BUILDARGS
14             {
15 57     57 1 46767 my ($class, $value) = @_;
16 57         987 return { 'value' => $value };
17             }
18              
19             sub BUILD
20             {
21 57     57 1 507 my ($self) = @_;
22 57         166 my ($why, $long, $data) = $self->_why_invalid( $self->{value} );
23 57 100       175 $self->_throw_exception( $why, $long, $data ) if defined $why;
24 40         172 $self->{value} = $self->_untaint( $self->value );
25 40         651 return $self;
26             }
27              
28             # A subclass must override this method or _is_invalid to be able to create value objects.
29             sub _why_invalid
30             {
31 1     1   2 my ($self, $value) = @_;
32 1 50       5 return ( ref($self) . ": Invalid parameter when creating value object.", "", undef )
33             unless $self->_is_valid( $value );
34 0         0 return;
35             }
36              
37             # A subclass must override this method or _why_invalid to be able to create value objects.
38             sub _is_valid
39             {
40 1     1   1 my ($self, $value) = @_;
41 1         7 return;
42             }
43              
44             # Default exception support just uses die to throw an exception.
45             sub _throw_exception
46             {
47 17     17   25 my ($self, $why, $longmsg, $data) = @_;
48 17         233 die $why;
49             }
50              
51             # Brute force untaint.
52             sub _untaint
53             {
54 40     40   45 my ($self, $value) = @_;
55              
56             # Can only untaint scalars
57 40 50       67 return $value if ref $value;
58              
59             # This is usually a very bad idea. It should be safe here because the class
60             # has, by definition, validated the input before we get to this function.
61             # If there is a problem, the validation code should be corrected.
62 40         82 $value =~ m/\A(.*)\z/;
63 40         103 return $1;
64             }
65              
66             1;
67             __END__