File Coverage

blib/lib/Types/Const.pm
Criterion Covered Total %
statement 59 70 84.2
branch 12 20 60.0
condition 6 9 66.6
subroutine 20 21 95.2
pod n/a
total 97 120 80.8


line stmt bran cond sub pod time code
1             package Types::Const;
2              
3 3     3   355804 use v5.10;
  3         22  
4              
5 3     3   13 use strict;
  3         4  
  3         51  
6 3     3   12 use warnings;
  3         4  
  3         133  
7              
8             # ABSTRACT: Types that coerce references to read-only
9              
10             use Type::Library
11 3         32 -base,
12 3     3   1301 -declare => qw/ Const /;
  3         57786  
13              
14 3     3   3856 use Const::Fast ();
  3         983  
  3         58  
15 3     3   14 use List::Util 1.33 ();
  3         39  
  3         52  
16 3     3   1474 use Storable 3.06 (); # Regexp support
  3         10204  
  3         96  
17 3     3   1424 use Type::Coercion;
  3         11018  
  3         112  
18 3     3   27 use Type::Tiny 1.002001;
  3         56  
  3         71  
19 3     3   1468 use Type::Utils -all;
  3         13052  
  3         34  
20 3     3   10225 use Types::Standard qw/ -types is_ArrayRef is_HashRef is_ScalarRef /;
  3         109464  
  3         34  
21 3     3   12895 use Types::TypeTiny ();
  3         7  
  3         79  
22              
23             # RECOMMEND PREREQ: Ref::Util::XS 0.100
24             # RECOMMEND PREREQ: Type::Tiny::XS
25              
26 3     3   1413 use namespace::autoclean 0.28;
  3         42017  
  3         14  
27              
28             our $VERSION = 'v0.4.2';
29              
30              
31             declare Const,
32             as Ref,
33             where \&__is_readonly,
34             message {
35             return "$_ is not readonly";
36             },
37             constraint_generator => \&__constraint_generator,
38             coercion_generator => \&__coercion_generator;
39              
40             coerce Const,
41             from Ref,
42             via \&__coerce_constant;
43              
44             sub __coerce_constant {
45 8 50   8   74 my $value = @_ ? $_[0] : $_;
46 8         38 Const::Fast::_make_readonly( $value => 0 );
47 8         1034 return $value;
48             }
49              
50             sub __is_readonly {
51 297 100   297   101641 if ( is_ArrayRef( $_[0] ) ) {
    100          
    100          
52             return Internals::SvREADONLY( @{ $_[0] } )
53 57   66 104   78 && List::Util::all { __is_readonly($_) } @{ $_[0] };
  104         162  
54             }
55             elsif ( is_HashRef( $_[0] ) ) {
56 45         96 &Internals::hv_clear_placeholders( $_[0] );
57             return Internals::SvREADONLY( %{ $_[0] } )
58 45   66 82   53 && List::Util::all { __is_readonly($_) } values %{ $_[0] };
  82         122  
59             }
60             elsif ( is_ScalarRef( $_[0] ) ) {
61 6         9 return Internals::SvREADONLY( ${ $_[0] } );
  6         21  
62             }
63              
64 189         543 return Internals::SvREADONLY( $_[0] );
65             }
66              
67             sub __constraint_generator {
68 6 100   6   50120 return Const unless @_;
69              
70 5         12 my $param = shift;
71 5 50       13 Types::TypeTiny::TypeTiny->check($param)
72             or _croak("Parameter to Const[`a] expected to be a type constraint; got $param");
73              
74 5 50       95 _croak("Only one parameter to Const[`a] expected; got @{[ 1 + @_ ]}.")
  0         0  
75             if @_;
76              
77 5         16 my $psub = $param->constraint;
78              
79             return sub {
80 37   66 37   241 return $psub->($_) && __is_readonly($_);
81 5         40 };
82             }
83              
84             sub __coercion_generator {
85 5     5   877 my ( $parent, $child, $param ) = @_;
86              
87 5 50       14 return $parent->coercion unless $param->has_coercion;
88              
89 0           my $coercion = Type::Coercion->new( type_constraint => $child );
90              
91 0           my $coercable_item = $param->coercion->_source_type_union;
92              
93             $coercion->add_type_coercions(
94             $parent => sub {
95 0 0   0     my $value = @_ ? $_[0] : $_;
96 0           my @new;
97 0           for my $item (@$value) {
98 0 0         return $value unless $coercable_item->check($item);
99 0           push @new, $param->coerce($item);
100             }
101 0           return __coerce_constant(\@new);
102             },
103 0           );
104              
105 0           return $coercion;
106             }
107              
108             __PACKAGE__->meta->make_immutable;
109              
110             __END__