1package Types::Standard::Map; 2 3use 5.006001; 4use strict; 5use warnings; 6 7BEGIN { 8 $Types::Standard::Map::AUTHORITY = 'cpan:TOBYINK'; 9 $Types::Standard::Map::VERSION = '1.012004'; 10} 11 12$Types::Standard::Map::VERSION =~ tr/_//d; 13 14use Type::Tiny (); 15use Types::Standard (); 16use Types::TypeTiny (); 17 18sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } 19 20my $meta = Types::Standard->meta; 21 22no warnings; 23 24sub __constraint_generator { 25 return $meta->get_type( 'Map' ) unless @_; 26 27 my ( $keys, $values ) = @_; 28 Types::TypeTiny::is_TypeTiny( $keys ) 29 or _croak( 30 "First parameter to Map[`k,`v] expected to be a type constraint; got $keys" ); 31 Types::TypeTiny::is_TypeTiny( $values ) 32 or _croak( 33 "Second parameter to Map[`k,`v] expected to be a type constraint; got $values" 34 ); 35 36 my @xsub; 37 if ( Type::Tiny::_USE_XS ) { 38 my @known = map { 39 my $known = Type::Tiny::XS::is_known( $_->compiled_check ); 40 defined( $known ) ? $known : (); 41 } ( $keys, $values ); 42 43 if ( @known == 2 ) { 44 my $xsub = Type::Tiny::XS::get_coderef_for( sprintf "Map[%s,%s]", @known ); 45 push @xsub, $xsub if $xsub; 46 } 47 } #/ if ( Type::Tiny::_USE_XS) 48 49 sub { 50 my $hash = shift; 51 $keys->check( $_ ) || return for keys %$hash; 52 $values->check( $_ ) || return for values %$hash; 53 return !!1; 54 }, @xsub; 55} #/ sub __constraint_generator 56 57sub __inline_generator { 58 my ( $k, $v ) = @_; 59 return unless $k->can_be_inlined && $v->can_be_inlined; 60 61 my $xsubname; 62 if ( Type::Tiny::_USE_XS ) { 63 my @known = map { 64 my $known = Type::Tiny::XS::is_known( $_->compiled_check ); 65 defined( $known ) ? $known : (); 66 } ( $k, $v ); 67 68 if ( @known == 2 ) { 69 $xsubname = Type::Tiny::XS::get_subname_for( sprintf "Map[%s,%s]", @known ); 70 } 71 } #/ if ( Type::Tiny::_USE_XS) 72 73 return sub { 74 my $h = $_[1]; 75 return "$xsubname\($h\)" if $xsubname && !$Type::Tiny::AvoidCallbacks; 76 my $p = Types::Standard::HashRef->inline_check( $h ); 77 my $k_check = $k->inline_check( '$k' ); 78 my $v_check = $v->inline_check( '$v' ); 79 "$p and do { " 80 . "my \$ok = 1; " 81 . "for my \$v (values \%{$h}) { " 82 . "(\$ok = 0, last) unless $v_check " . "}; " 83 . "for my \$k (keys \%{$h}) { " 84 . "(\$ok = 0, last) unless $k_check " . "}; " . "\$ok " . "}"; 85 }; 86} #/ sub __inline_generator 87 88sub __deep_explanation { 89 require B; 90 my ( $type, $value, $varname ) = @_; 91 my ( $kparam, $vparam ) = @{ $type->parameters }; 92 93 for my $k ( sort keys %$value ) { 94 unless ( $kparam->check( $k ) ) { 95 return [ 96 sprintf( '"%s" constrains each key in the hash with "%s"', $type, $kparam ), 97 @{ 98 $kparam->validate_explain( 99 $k, sprintf( 'key %s->{%s}', $varname, B::perlstring( $k ) ) 100 ) 101 }, 102 ]; 103 } #/ unless ( $kparam->check( $k...)) 104 105 unless ( $vparam->check( $value->{$k} ) ) { 106 return [ 107 sprintf( '"%s" constrains each value in the hash with "%s"', $type, $vparam ), 108 @{ 109 $vparam->validate_explain( 110 $value->{$k}, sprintf( '%s->{%s}', $varname, B::perlstring( $k ) ) 111 ) 112 }, 113 ]; 114 } #/ unless ( $vparam->check( $value...)) 115 } #/ for my $k ( sort keys %$value) 116 117 # This should never happen... 118 return; # uncoverable statement 119} #/ sub __deep_explanation 120 121sub __coercion_generator { 122 my ( $parent, $child, $kparam, $vparam ) = @_; 123 return unless $kparam->has_coercion || $vparam->has_coercion; 124 125 my $kcoercable_item = 126 $kparam->has_coercion 127 ? $kparam->coercion->_source_type_union 128 : $kparam; 129 my $vcoercable_item = 130 $vparam->has_coercion 131 ? $vparam->coercion->_source_type_union 132 : $vparam; 133 my $C = "Type::Coercion"->new( type_constraint => $child ); 134 135 if ( ( !$kparam->has_coercion or $kparam->coercion->can_be_inlined ) 136 and ( !$vparam->has_coercion or $vparam->coercion->can_be_inlined ) 137 and $kcoercable_item->can_be_inlined 138 and $vcoercable_item->can_be_inlined ) 139 { 140 $C->add_type_coercions( 141 $parent => Types::Standard::Stringable { 142 my @code; 143 push @code, 'do { my ($orig, $return_orig, %new) = ($_, 0);'; 144 push @code, 'for (keys %$orig) {'; 145 push @code, 146 sprintf( 147 '++$return_orig && last unless (%s);', 148 $kcoercable_item->inline_check( '$_' ) 149 ); 150 push @code, 151 sprintf( 152 '++$return_orig && last unless (%s);', 153 $vcoercable_item->inline_check( '$orig->{$_}' ) 154 ); 155 push @code, sprintf( 156 '$new{(%s)} = (%s);', 157 $kparam->has_coercion ? $kparam->coercion->inline_coercion( '$_' ) : '$_', 158 $vparam->has_coercion 159 ? $vparam->coercion->inline_coercion( '$orig->{$_}' ) 160 : '$orig->{$_}', 161 ); 162 push @code, '}'; 163 push @code, '$return_orig ? $orig : \\%new'; 164 push @code, '}'; 165 "@code"; 166 } 167 ); 168 } #/ if ( ( !$kparam->has_coercion...)) 169 else { 170 $C->add_type_coercions( 171 $parent => sub { 172 my $value = @_ ? $_[0] : $_; 173 my %new; 174 for my $k ( keys %$value ) { 175 return $value 176 unless $kcoercable_item->check( $k ) 177 && $vcoercable_item->check( $value->{$k} ); 178 $new{ $kparam->has_coercion ? $kparam->coerce( $k ) : $k } = 179 $vparam->has_coercion 180 ? $vparam->coerce( $value->{$k} ) 181 : $value->{$k}; 182 } 183 return \%new; 184 }, 185 ); 186 } #/ else [ if ( ( !$kparam->has_coercion...))] 187 188 return $C; 189} #/ sub __coercion_generator 190 191sub __hashref_allows_key { 192 my $self = shift; 193 my ( $key ) = @_; 194 195 return Types::Standard::is_Str( $key ) if $self == Types::Standard::Map(); 196 197 my $map = $self->find_parent( 198 sub { $_->has_parent && $_->parent == Types::Standard::Map() } ); 199 my ( $kcheck, $vcheck ) = @{ $map->parameters }; 200 201 ( $kcheck or Types::Standard::Any() )->check( $key ); 202} #/ sub __hashref_allows_key 203 204sub __hashref_allows_value { 205 my $self = shift; 206 my ( $key, $value ) = @_; 207 208 return !!0 unless $self->my_hashref_allows_key( $key ); 209 return !!1 if $self == Types::Standard::Map(); 210 211 my $map = $self->find_parent( 212 sub { $_->has_parent && $_->parent == Types::Standard::Map() } ); 213 my ( $kcheck, $vcheck ) = @{ $map->parameters }; 214 215 ( $kcheck or Types::Standard::Any() )->check( $key ) 216 and ( $vcheck or Types::Standard::Any() )->check( $value ); 217} #/ sub __hashref_allows_value 218 2191; 220 221__END__ 222 223=pod 224 225=encoding utf-8 226 227=head1 NAME 228 229Types::Standard::Map - internals for the Types::Standard Map type constraint 230 231=head1 STATUS 232 233This module is considered part of Type-Tiny's internals. It is not 234covered by the 235L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">. 236 237=head1 DESCRIPTION 238 239This file contains some of the guts for L<Types::Standard>. 240It will be loaded on demand. You may ignore its presence. 241 242=head1 BUGS 243 244Please report any bugs to 245L<https://github.com/tobyink/p5-type-tiny/issues>. 246 247=head1 SEE ALSO 248 249L<Types::Standard>. 250 251=head1 AUTHOR 252 253Toby Inkster E<lt>tobyink@cpan.orgE<gt>. 254 255=head1 COPYRIGHT AND LICENCE 256 257This software is copyright (c) 2013-2014, 2017-2021 by Toby Inkster. 258 259This is free software; you can redistribute it and/or modify it under 260the same terms as the Perl 5 programming language system itself. 261 262=head1 DISCLAIMER OF WARRANTIES 263 264THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 265WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 266MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 267