Move the tied hash FETCH count tests to t/op/tiehash.t

This file is a better fit for them than t/op/tie.t
Perl · Aug 27, 2021 · 19f584d · 19f584d
1 parent 013a76a
commit 19f584d
Show file tree

Hide file tree

Showing 2 changed files with 39 additions and 42 deletions.
diff --git a/t/op/tie.t b/t/op/tie.t
@@ -21,48 +21,6 @@ done_testing();
 
 __END__
 
-########
-# tied hash in list context
-use Tie::Hash;
-my %tied;
-tie %tied, "Tie::StdHash";
-%tied = qw(perl rules beer foamy);
-my @a = %tied;
-if ($a[0] eq 'beer') {
-    print "@a\n";
-} else {
-    # Must do this explicitly (not sort) to spot if keys and values are muddled
-    print "$a[2] $a[3] $a[0] $a[1]\n"
-}
-
-EXPECT
-beer foamy perl rules
-########
-# tied hash keys in list context
-use Tie::Hash;
-my %tied;
-tie %tied, "Tie::StdHash";
-%tied = qw(perl rules beer foamy);
-my @a = keys %tied;
-@a = sort @a;
-print "@a\n";
-
-EXPECT
-beer perl
-########
-# tied hash values in list context
-use Tie::Hash;
-my %tied;
-tie %tied, "Tie::StdHash";
-%tied = qw(perl rules beer foamy);
-my @a = values %tied;
-@a = sort @a;
-print "@a\n";
-
-EXPECT
-foamy rules
-########
-
 # standard behaviour, without any extra references
 use Tie::Hash ;
 tie %h, Tie::StdHash;

diff --git a/t/op/tiehash.t b/t/op/tiehash.t
@@ -150,4 +150,43 @@ package TestIterators {
     is("@have", "@want", "tie/untie resets the hash iterator");
 }
 
+{
+    require Tie::Hash;
+    my $count;
+
+    package Tie::Count {
+        use parent -norequire, 'Tie::StdHash';
+        sub FETCH {
+            ++$count;
+            return $_[0]->SUPER::FETCH($_[1]);
+        }
+    }
+
+    $count = 0;
+    my %tied;
+    tie %tied, "Tie::Count";
+    %tied = qw(perl rules beer foamy);
+    my @a = %tied;
+    if ($a[0] eq 'beer') {
+        is("@a", "beer foamy perl rules", "tied hash in list context");
+    } else {
+        is("@a", "perl rules beer foamy", "tied hash in list context");
+    }
+    is($count, 2, "two FETCHes for tied hash in list context");
+
+    $count = 0;
+
+    @a = keys %tied;
+    @a = sort @a;
+    is("@a", "beer perl", "tied hash keys in list context");
+    is($count, 0, "no FETCHes for tied hash keys in list context");
+
+    $count = 0;
+    @a = values %tied;
+    @a = sort @a;
+
+    is("@a", "foamy rules", "tied hash values in list context");
+    is($count, 2, "two FETCHes for tied hash values in list context");
+}
+
 done_testing();