File Coverage

lib/Types/Standard/Map.pm
Criterion Covered Total %
statement 110 111 100.0
branch 43 56 76.7
condition 28 40 70.0
subroutine 21 21 100.0
pod n/a
total 202 228 89.0


line stmt bran cond sub pod time code
1             # INTERNAL MODULE: guts for Map type from Types::Standard.
2              
3             package Types::Standard::Map;
4              
5 7     7   265 use 5.008001;
  7         30  
6 7     7   48 use strict;
  7         16  
  7         192  
7 7     7   40 use warnings;
  7         18  
  7         372  
8              
9             BEGIN {
10 7     7   25 $Types::Standard::Map::AUTHORITY = 'cpan:TOBYINK';
11 7         258 $Types::Standard::Map::VERSION = '2.004000';
12             }
13              
14             $Types::Standard::Map::VERSION =~ tr/_//d;
15              
16 7     7   55 use Type::Tiny ();
  7         14  
  7         154  
17 7     7   43 use Types::Standard ();
  7         20  
  7         129  
18 7     7   34 use Types::TypeTiny ();
  7         19  
  7         559  
19              
20 3     3   53 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  3         19  
21              
22             my $meta = Types::Standard->meta;
23              
24 7     7   48 no warnings;
  7         205  
  7         10769  
25              
26             sub __constraint_generator {
27 27 50   27   116 return $meta->get_type( 'Map' ) unless @_;
28            
29 27         77 my ( $keys, $values ) = @_;
30 27 100       501 Types::TypeTiny::is_TypeTiny( $keys )
31             or _croak(
32             "First parameter to Map[`k,`v] expected to be a type constraint; got $keys" );
33 25 100       404 Types::TypeTiny::is_TypeTiny( $values )
34             or _croak(
35             "Second parameter to Map[`k,`v] expected to be a type constraint; got $values"
36             );
37            
38 24         76 my @xsub;
39 24         42 if ( Type::Tiny::_USE_XS ) {
40             my @known = map {
41 24         54 my $known = Type::Tiny::XS::is_known( $_->compiled_check );
  48         120  
42 48 100       383 defined( $known ) ? $known : ();
43             } ( $keys, $values );
44            
45 24 100       77 if ( @known == 2 ) {
46 17         100 my $xsub = Type::Tiny::XS::get_coderef_for( sprintf "Map[%s,%s]", @known );
47 17 50       847 push @xsub, $xsub if $xsub;
48             }
49             } #/ if ( Type::Tiny::_USE_XS)
50            
51             sub {
52 25     25   52 my $hash = shift;
53 25   100     103 $keys->check( $_ ) || return for keys %$hash;
54 21   100     74 $values->check( $_ ) || return for values %$hash;
55 15         55 return !!1;
56 24         183 }, @xsub;
57             } #/ sub __constraint_generator
58              
59             sub __inline_generator {
60 24     24   65 my ( $k, $v ) = @_;
61 24 50 33     82 return unless $k->can_be_inlined && $v->can_be_inlined;
62            
63 24         52 my $xsubname;
64 24         37 if ( Type::Tiny::_USE_XS ) {
65             my @known = map {
66 24         57 my $known = Type::Tiny::XS::is_known( $_->compiled_check );
  48         98  
67 48 100       325 defined( $known ) ? $known : ();
68             } ( $k, $v );
69            
70 24 100       100 if ( @known == 2 ) {
71 17         83 $xsubname = Type::Tiny::XS::get_subname_for( sprintf "Map[%s,%s]", @known );
72             }
73             } #/ if ( Type::Tiny::_USE_XS)
74            
75             return sub {
76 326     326   550 my $h = $_[1];
77 326 100 100     1607 return "$xsubname\($h\)" if $xsubname && !$Type::Tiny::AvoidCallbacks;
78 69         188 my $p = Types::Standard::HashRef->inline_check( $h );
79 69         194 my $k_check = $k->inline_check( '$k' );
80 69         206 my $v_check = $v->inline_check( '$v' );
81 69         473 "$p and do { "
82             . "my \$ok = 1; "
83             . "for my \$v (values \%{$h}) { "
84             . "(\$ok = 0, last) unless $v_check " . "}; "
85             . "for my \$k (keys \%{$h}) { "
86             . "(\$ok = 0, last) unless $k_check " . "}; " . "\$ok " . "}";
87 24         316 };
88             } #/ sub __inline_generator
89              
90             sub __deep_explanation {
91 2     2   11 require B;
92 2         4 my ( $type, $value, $varname ) = @_;
93 2         3 my ( $kparam, $vparam ) = @{ $type->parameters };
  2         7  
94            
95 2         9 for my $k ( sort keys %$value ) {
96 3 100       12 unless ( $kparam->check( $k ) ) {
97             return [
98             sprintf( '"%s" constrains each key in the hash with "%s"', $type, $kparam ),
99             @{
100 1         4 $kparam->validate_explain(
  1         7  
101             $k, sprintf( 'key %s->{%s}', $varname, B::perlstring( $k ) )
102             )
103             },
104             ];
105             } #/ unless ( $kparam->check( $k...))
106            
107 2 100       6 unless ( $vparam->check( $value->{$k} ) ) {
108             return [
109             sprintf( '"%s" constrains each value in the hash with "%s"', $type, $vparam ),
110             @{
111 1         5 $vparam->validate_explain(
112 1         8 $value->{$k}, sprintf( '%s->{%s}', $varname, B::perlstring( $k ) )
113             )
114             },
115             ];
116             } #/ unless ( $vparam->check( $value...))
117             } #/ for my $k ( sort keys %$value)
118            
119             # This should never happen...
120 0         0 return; # uncoverable statement
121             } #/ sub __deep_explanation
122              
123             sub __coercion_generator {
124 15     15   62 my ( $parent, $child, $kparam, $vparam ) = @_;
125 15 100 100     72 return unless $kparam->has_coercion || $vparam->has_coercion;
126            
127 6 100       27 my $kcoercable_item =
128             $kparam->has_coercion
129             ? $kparam->coercion->_source_type_union
130             : $kparam;
131 6 50       30 my $vcoercable_item =
132             $vparam->has_coercion
133             ? $vparam->coercion->_source_type_union
134             : $vparam;
135 6         31 my $C = "Type::Coercion"->new( type_constraint => $child );
136            
137 6 100 100     23 if ( ( !$kparam->has_coercion or $kparam->coercion->can_be_inlined )
      66        
      100        
      66        
      66        
138             and ( !$vparam->has_coercion or $vparam->coercion->can_be_inlined )
139             and $kcoercable_item->can_be_inlined
140             and $vcoercable_item->can_be_inlined )
141             {
142             $C->add_type_coercions(
143             $parent => Types::Standard::Stringable {
144 3     3   5 my @code;
145 3         10 push @code, 'do { my ($orig, $return_orig, %new) = ($_, 0);';
146 3         6 push @code, 'for (keys %$orig) {';
147 3         14 push @code,
148             sprintf(
149             '++$return_orig && last unless (%s);',
150             $kcoercable_item->inline_check( '$_' )
151             );
152 3         21 push @code,
153             sprintf(
154             '++$return_orig && last unless (%s);',
155             $vcoercable_item->inline_check( '$orig->{$_}' )
156             );
157 3 50       25 push @code, sprintf(
    50          
158             '$new{(%s)} = (%s);',
159             $kparam->has_coercion ? $kparam->coercion->inline_coercion( '$_' ) : '$_',
160             $vparam->has_coercion
161             ? $vparam->coercion->inline_coercion( '$orig->{$_}' )
162             : '$orig->{$_}',
163             );
164 3         17 push @code, '}';
165 3         13 push @code, '$return_orig ? $orig : \\%new';
166 3         7 push @code, '}';
167 3         50 "@code";
168             }
169 4         49 );
170             } #/ if ( ( !$kparam->has_coercion...))
171             else {
172             $C->add_type_coercions(
173             $parent => sub {
174 3 50   3   46 my $value = @_ ? $_[0] : $_;
175 3         7 my %new;
176 3         10 for my $k ( keys %$value ) {
177             return $value
178             unless $kcoercable_item->check( $k )
179 6 100 66     81 && $vcoercable_item->check( $value->{$k} );
180             $new{ $kparam->has_coercion ? $kparam->coerce( $k ) : $k } =
181             $vparam->has_coercion
182             ? $vparam->coerce( $value->{$k} )
183 5 50       46 : $value->{$k};
    50          
184             }
185 2         52 return \%new;
186             },
187 2         23 );
188             } #/ else [ if ( ( !$kparam->has_coercion...))]
189            
190 6         21 return $C;
191             } #/ sub __coercion_generator
192              
193             sub __hashref_allows_key {
194 45     45   85 my $self = shift;
195 45         101 my ( $key ) = @_;
196            
197 45 100       124 return Types::Standard::is_Str( $key ) if $self == Types::Standard::Map();
198            
199             my $map = $self->find_parent(
200 39 50   43   256 sub { $_->has_parent && $_->parent == Types::Standard::Map() } );
  43         137  
201 39         2023 my ( $kcheck, $vcheck ) = @{ $map->parameters };
  39         127  
202            
203 39   33     125 ( $kcheck or Types::Standard::Any() )->check( $key );
204             } #/ sub __hashref_allows_key
205              
206             sub __hashref_allows_value {
207 10     10   20 my $self = shift;
208 10         27 my ( $key, $value ) = @_;
209            
210 10 100       56 return !!0 unless $self->my_hashref_allows_key( $key );
211 7 50       37 return !!1 if $self == Types::Standard::Map();
212            
213             my $map = $self->find_parent(
214 7 50   7   54 sub { $_->has_parent && $_->parent == Types::Standard::Map() } );
  7         28  
215 7         37 my ( $kcheck, $vcheck ) = @{ $map->parameters };
  7         22  
216            
217 7 50 33     25 ( $kcheck or Types::Standard::Any() )->check( $key )
      33        
218             and ( $vcheck or Types::Standard::Any() )->check( $value );
219             } #/ sub __hashref_allows_value
220              
221             1;