diff options
Diffstat (limited to 't/21-types/HashLike.t')
| -rw-r--r-- | t/21-types/HashLike.t | 78 |
1 files changed, 76 insertions, 2 deletions
diff --git a/t/21-types/HashLike.t b/t/21-types/HashLike.t index 29985d92..363859d6 100644 --- a/t/21-types/HashLike.t +++ b/t/21-types/HashLike.t @@ -12,7 +12,7 @@ Toby Inkster E<lt>tobyink@cpan.orgE<gt>. =head1 COPYRIGHT AND LICENCE -This software is copyright (c) 2019-2022 by Toby Inkster. +This software is copyright (c) 2019-2023 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. @@ -178,5 +178,79 @@ ok( Scalar::Util::blessed( $HashOfRounded->coerce(bless([{ foo => undef, bar => 2.1 }], 'Local::OL::Hash')) ), ); -done_testing; +# +# Tied hashes, and combining them with hash-overloaded objects +# + +{ + package MaiTai::Hash; + use Tie::Hash; + our @ISA = 'Tie::Hash'; + sub TIEHASH { bless [ {} ], $_[0]; } + sub FETCH { $_[0][0]{$_[1]}; } + sub STORE { $_[0][0]{$_[1]} = $_[2]; } + sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } + sub NEXTKEY { each %{$_[0][0]} } + sub EXISTS { exists $_[0][0]{$_[1]}; } + sub DELETE { delete $_[0][0]{$_[1]}; } + sub CLEAR { %{$_[0][0]} = () } + sub SCALAR { scalar %{$_[0][0]} } + ## + package MaiObj::Hash; + use overload '%{}' => sub { + my $obj = shift; + my %h; + tie( %h, 'MaiTai::Hash' ) if $obj->[0]; + my @keys = @{ $obj->[1] }; + my @values = @{ $obj->[2] }; + @h{ @keys } = @values; + return \%h; + }; + sub new { + my ( $class, $do_tie ) = ( shift, shift ); + my ( @keys, @values ); + while ( @_ ) { + push @keys, shift; + push @values, shift; + } + bless [ $do_tie, \@keys, \@values ], $class; + } +} + +{ + my %h; + tie( %h, 'MaiTai::Hash' ); + $h{foo} = 12; + $h{bar} = 34; + should_pass( \%h, $HashOfInt, 'tied hash that should pass' ); +} + +{ + my %h; + tie( %h, 'MaiTai::Hash' ); + $h{foo} = 12; + $h{bar} = 'xxx'; + should_fail( \%h, $HashOfInt, 'tied hash that should fail' ); +} +{ + my $obj = 'MaiObj::Hash'->new( !!0, foo => 12, bar => 34 ); + should_pass( $obj, $HashOfInt, 'overloaded object yielding regular hash that should pass' ); +} + +{ + my $obj = 'MaiObj::Hash'->new( !!0, foo => 12, bar => 'xyz' ); + should_fail( $obj, $HashOfInt, 'overloaded object yielding regular hash that should fail' ); +} + +{ + my $obj = 'MaiObj::Hash'->new( !!1, foo => 12, bar => 34 ); + should_pass( $obj, $HashOfInt, 'overloaded object yielding tied hash that should pass' ); +} + +{ + my $obj = 'MaiObj::Hash'->new( !!1, foo => 12, bar => 'xyz' ); + should_fail( $obj, $HashOfInt, 'overloaded object yielding tied hash that should fail' ); +} + +done_testing; |