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