diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 9b3b3ae3e2..2e7ce29e2a 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,9 @@ priorities and future plans. ## Work in progress +- Export `fieldhash` from `Hash::Util` for compatibility with core Perl. +- Normalize tied-hash `exists` results to Perl's boolean values. + - Preserve reference lifetime when overloaded `++` and `--` fall back to arithmetic (#1901). - Parse forward-declared qualified classes as indirect constructors inside `new` methods (#1899). diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/TieHash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/TieHash.java index 77cdbfb644..606b040e05 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/TieHash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/TieHash.java @@ -146,7 +146,9 @@ public static RuntimeScalar tiedDelete(RuntimeHash hash, RuntimeScalar key) { * Checks if a key exists in a tied hash (delegates to EXISTS). */ public static RuntimeScalar tiedExists(RuntimeHash hash, RuntimeScalar key) { - return tieCall(hash, "EXISTS", key); + return tieCall(hash, "EXISTS", key).getBoolean() + ? RuntimeScalarCache.scalarOne + : RuntimeScalarCache.scalarEmptyString; } /** diff --git a/src/main/perl/lib/Hash/Util.pm b/src/main/perl/lib/Hash/Util.pm index 2c41080e13..996a6365b5 100644 --- a/src/main/perl/lib/Hash/Util.pm +++ b/src/main/perl/lib/Hash/Util.pm @@ -3,6 +3,7 @@ package Hash::Util; use strict; use warnings; require Exporter; +use Hash::Util::FieldHash qw(fieldhash); our @ISA = qw(Exporter); our @EXPORT_OK = qw( @@ -16,6 +17,7 @@ our @EXPORT_OK = qw( legal_keys all_keys hidden_keys legal_ref_keys hash_unlocked + fieldhash ); our $VERSION = '0.28'; diff --git a/src/main/perl/lib/Hash/Util/FieldHash.pm b/src/main/perl/lib/Hash/Util/FieldHash.pm index 409f851fbe..1afccc5c30 100644 --- a/src/main/perl/lib/Hash/Util/FieldHash.pm +++ b/src/main/perl/lib/Hash/Util/FieldHash.pm @@ -89,6 +89,7 @@ sub TIEHASH { my $self = bless { values => {}, refs => {}, + plain => {}, order => [], iter => [], }, $class; @@ -102,18 +103,27 @@ sub TIEHASH { sub CLONE { my @live; for my $tie (grep { defined } @TIES) { - my (%values, %refs); - for my $old_id (keys %{ $tie->{refs} }) { + my (%values, %refs, %plain); + my @order; + for my $old_id (@{ $tie->{order} }) { + next unless exists $tie->{values}{$old_id}; + if (exists $tie->{plain}{$old_id}) { + $values{$old_id} = $tie->{values}{$old_id}; + $plain{$old_id} = $tie->{plain}{$old_id}; + push @order, $old_id; + next; + } my $key = $tie->{refs}{$old_id}; next unless defined $key; - my $new_id = Scalar::Util::refaddr($key); + my $new_id = _id_for_key($key); $refs{$new_id} = $key; - $values{$new_id} = $tie->{values}{$old_id} - if exists $tie->{values}{$old_id}; + $values{$new_id} = $tie->{values}{$old_id}; + push @order, $new_id; } $tie->{refs} = \%refs; + $tie->{plain} = \%plain; $tie->{values} = \%values; - @{ $tie->{order} } = keys %refs; + @{ $tie->{order} } = @order; @{ $tie->{iter} } = (); push @live, $tie; } @@ -123,22 +133,26 @@ sub CLONE { sub _id_for_key { my ($key) = @_; - die "Hash::Util::FieldHash keys must be references\n" unless ref $key; - - my $id = Scalar::Util::refaddr($key); - die "Hash::Util::FieldHash keys must be references\n" unless defined $id; - - return $id; + if (ref $key) { + my $id = Scalar::Util::refaddr($key); + return 'R:' . $id if defined $id; + } + my $string_key = defined($key) ? "$key" : ''; + return 'S:' . length($string_key) . ':' . $string_key; } sub _remember_key { my ($self, $id, $key) = @_; - if (!exists $self->{refs}{$id}) { + if (!exists $self->{values}{$id}) { push @{ $self->{order} }, $id; } - $self->{refs}{$id} = $key; - eval { Scalar::Util::weaken($self->{refs}{$id}) }; + if (ref $key) { + $self->{refs}{$id} = $key; + eval { Scalar::Util::weaken($self->{refs}{$id}) }; + } else { + $self->{plain}{$id} = defined($key) ? "$key" : ''; + } return; } @@ -151,7 +165,7 @@ sub _prune { delete $self->{values}{$id}; } - @{ $self->{order} } = grep { exists $self->{refs}{$_} } @{ $self->{order} }; + @{ $self->{order} } = grep { exists $self->{values}{$_} } @{ $self->{order} }; return; } @@ -160,7 +174,13 @@ sub STORE { my $id = _id_for_key($key); $self->_prune; - $self->_remember_key($id, $key); + $self->_remember_key($id, $key) unless exists $self->{values}{$id}; + if (!ref $key) { + $self->{plain}{$id} = defined($key) ? "$key" : ''; + } elsif (!exists $self->{refs}{$id}) { + $self->{refs}{$id} = $key; + eval { Scalar::Util::weaken($self->{refs}{$id}) }; + } $self->{values}{$id} = $value; return $value; } @@ -187,6 +207,7 @@ sub DELETE { $self->_prune; delete $self->{refs}{$id}; + delete $self->{plain}{$id}; return delete $self->{values}{$id}; } @@ -195,6 +216,7 @@ sub CLEAR { %{ $self->{values} } = (); %{ $self->{refs} } = (); + %{ $self->{plain} } = (); @{ $self->{order} } = (); @{ $self->{iter} } = (); return; @@ -204,7 +226,7 @@ sub FIRSTKEY { my ($self) = @_; $self->_prune; - @{ $self->{iter} } = grep { exists $self->{refs}{$_} } @{ $self->{order} }; + @{ $self->{iter} } = grep { exists $self->{values}{$_} } @{ $self->{order} }; return $self->NEXTKEY; } @@ -214,8 +236,9 @@ sub NEXTKEY { $self->_prune; while (@{ $self->{iter} }) { my $id = shift @{ $self->{iter} }; - next unless exists $self->{refs}{$id}; - return $self->{refs}{$id}; + next unless exists $self->{values}{$id}; + return $self->{refs}{$id} if exists $self->{refs}{$id}; + return $self->{plain}{$id} if exists $self->{plain}{$id}; } return undef; } diff --git a/src/test/resources/unit/hash_util_fieldhash_export.t b/src/test/resources/unit/hash_util_fieldhash_export.t new file mode 100644 index 0000000000..8a88d035f0 --- /dev/null +++ b/src/test/resources/unit/hash_util_fieldhash_export.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More tests => 6; + +use Hash::Util qw(fieldhash); + +fieldhash my %object_fields; + +my $object = {}; +$object_fields{$object} = 'value'; + +is $object_fields{$object}, 'value', + 'Hash::Util exports fieldhash and stores values for reference keys'; + +my $other_object = {}; +ok !exists $object_fields{$other_object}, + 'fieldhash entries are associated with reference identity'; + +fieldhash my %mixed_fields; +$mixed_fields{plain_key} = 'plain value'; +$mixed_fields{$object} = 'reference value'; + +is $mixed_fields{plain_key}, 'plain value', + 'fieldhash retains ordinary scalar-key behavior'; +ok scalar(grep { $_ eq 'plain_key' } keys %mixed_fields), + 'fieldhash iteration includes ordinary scalar keys'; +is $mixed_fields{$object}, 'reference value', + 'reference-key fieldhash values remain independent from scalar keys'; + +ok defined(&fieldhash), 'fieldhash is imported into the caller'; diff --git a/src/test/resources/unit/tied_hash_exists_boolean.t b/src/test/resources/unit/tied_hash_exists_boolean.t new file mode 100644 index 0000000000..a75e28fd64 --- /dev/null +++ b/src/test/resources/unit/tied_hash_exists_boolean.t @@ -0,0 +1,29 @@ +use strict; +use warnings; +use Test::More tests => 6; + +{ + package Local::ExistsResult; + + our $RESULT; + + sub TIEHASH { bless {}, shift } + sub EXISTS { return $RESULT } +} + +tie my %hash, 'Local::ExistsResult'; + +$Local::ExistsResult::RESULT = undef; +my $missing_undef = exists $hash{missing_undef}; +ok defined($missing_undef), 'undef from tied EXISTS becomes a defined result'; +is $missing_undef, '', 'undef from tied EXISTS becomes the empty-string false value'; + +$Local::ExistsResult::RESULT = 0; +my $missing_zero = exists $hash{missing_zero}; +ok defined($missing_zero), 'zero from tied EXISTS becomes a defined result'; +is $missing_zero, '', 'zero from tied EXISTS becomes the empty-string false value'; + +$Local::ExistsResult::RESULT = 'present'; +my $present = exists $hash{present}; +ok defined($present) && $present, 'truthy tied EXISTS result remains true'; +is $present, 1, 'truthy tied EXISTS result is normalized to one';