t/op/tiehash.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 # This is purposefully simple - hence the O(n) linear searches.
  10 package TestIterators {
  11     sub TIEHASH {
  12         bless [], $_[0];
  13     }
  14
  15     sub STORE {
  16         my ($self, $key, $value) = @_;
  17         push @{$self->[0]}, $key;
  18         push @{$self->[1]}, $value;
  19         return $value;
  20     }
  21
  22     sub FETCH {
  23         my ($self, $key) = @_;
  24         my $i = 0;
  25         while ($i < @{$self->[0]}) {
  26             return $self->[1][$i]
  27                 if $self->[0][$i] eq $key;
  28             ++$i;
  29         }
  30         die "$key not found in FETCH";
  31     }
  32
  33     sub FIRSTKEY {
  34         my $self = shift;
  35         $self->[0][0];
  36     }
  37
  38     # As best I can tell, none of our other tie tests actually use the first
  39     # parameter to nextkey. It's actually (a copy of) the previously returned
  40     # key. We're not *so* thorough here as to actually hide some state and
  41     # cross-check that, but the longhand tests below should effectively validate
  42     # it.
  43     sub NEXTKEY {
  44         my ($self, $key) = @_;
  45         my $i = 0;
  46         while ($i < @{$self->[0]}) {
  47             return $self->[0][$i + 1]
  48                 if $self->[0][$i] eq $key;
  49             ++$i;
  50         }
  51         die "$key not found in NEXTKEY";
  52     }
  53 };
  54
  55 {
  56     my %h;
  57     tie %h, 'TestIterators';
  58
  59     $h{beer} = "foamy";
  60     $h{perl} = "rules";
  61
  62     is($h{beer}, "foamy", "found first key");
  63     is($h{perl}, "rules", "found second key");
  64     is(eval {
  65         my $k = $h{decaf};
  66         1;
  67     }, undef, "missing key was not found");
  68     like($@, qr/\Adecaf not found in FETCH/, "with the correct error");
  69
  70     is(each %h, 'beer', "first iterator");
  71     is(each %h, 'perl', "second iterator");
  72     is(each %h, undef, "third iterator is undef");
  73 }
  74
  75 {
  76     require Tie::Hash;
  77
  78     my %h = (
  79         lolcat => "OH HAI!",
  80         lolrus => "I HAS A BUCKET",
  81     );
  82
  83     my @want = sort keys %h;
  84
  85     my @have;
  86     while (1) {
  87         my $k = each %h;
  88         last
  89             unless defined $k;
  90         push @have, $k;
  91     }
  92     @have = sort @have;
  93
  94     # This is a sanity test:
  95     is("@have", "@want", "get all keys from a loop");
  96
  97     @have = ();
  98     keys %h;
  99
 100     my $k1 = each %h;
 101
 102     ok(defined $k1, "Got a key");
 103
 104     # no tie/untie here
 105
 106     while(1) {
 107         my $k = each %h;
 108         last
 109             unless defined $k;
 110         push @have, $k;
 111     }
 112
 113     # As are these:
 114     is(scalar @have, 1, "just 1 key from the loop this time");
 115     isnt($k1, $have[0], "two different keys");
 116
 117     @have = sort @have, $k1;
 118     is("@have", "@want", "get all keys just once");
 119
 120     # And this is the real test.
 121     #
 122     # Previously pp_tie would mangle the hash iterator state - it would reset
 123     # EITER but not RITER, meaning that if the iterator happened to be partway
 124     # down a chain of entries, the rest of that chain would be skipped, but if
 125     # the iterator's next position was the start of a (new) chain, nothing would
 126     # be skipped.
 127     # We don't have space to store the complete older iterator state (and really
 128     # nothing should be relying on it), so it seems better to correctly reset
 129     # the iterator (every time), than leave it in a mess just occasionally.
 130
 131     @have = ();
 132     keys %h;
 133
 134     my $k1 = each %h;
 135
 136     ok(defined $k1, "Got a key");
 137
 138     tie %h, 'Tie::StdHash';
 139     untie %h;
 140
 141     while(1) {
 142         my $k = each %h;
 143         last
 144             unless defined $k;
 145         push @have, $k;
 146     }
 147
 148     @have = sort @have;
 149     is(scalar @have, 2, "2 keys from the loop this time");
 150     is("@have", "@want", "tie/untie resets the hash iterator");
 151 }
 152
 153 {
 154     require Tie::Hash;
 155     my $count;
 156
 157     package Tie::Count {
 158         use parent -norequire, 'Tie::StdHash';
 159         sub FETCH {
 160             ++$count;
 161             return $_[0]->SUPER::FETCH($_[1]);
 162         }
 163     }
 164
 165     $count = 0;
 166     my %tied;
 167     tie %tied, "Tie::Count";
 168     %tied = qw(perl rules beer foamy);
 169     my @a = %tied;
 170     if ($a[0] eq 'beer') {
 171         is("@a", "beer foamy perl rules", "tied hash in list context");
 172     } else {
 173         is("@a", "perl rules beer foamy", "tied hash in list context");
 174     }
 175     is($count, 2, "two FETCHes for tied hash in list context");
 176
 177     $count = 0;
 178
 179     @a = keys %tied;
 180     @a = sort @a;
 181     is("@a", "beer perl", "tied hash keys in list context");
 182     is($count, 0, "no FETCHes for tied hash keys in list context");
 183
 184     $count = 0;
 185     @a = values %tied;
 186     @a = sort @a;
 187
 188     is("@a", "foamy rules", "tied hash values in list context");
 189     is($count, 2, "two FETCHes for tied hash values in list context");
 190 }
 191
 192 {
 193     # tie/untie on a hash resets the iterator
 194
 195     # This is not intended as a test of *correctness*. This behaviour is
 196     # observable by code on CPAN, so potentially some of it will inadvertently
 197     # be relying on it (and likely not in any regression test). Hence this
 198     # "test" here is intended as a way to alert us if any core code change has
 199     # the side effect of alerting this observable behaviour.
 200
 201     my @keys = qw(bactrianus dromedarius ferus);
 202     my %Camelus;
 203     ++$Camelus{$_}
 204         for @keys;
 205
 206     my @got;
 207     push @got, scalar each %Camelus;
 208     push @got, scalar each %Camelus;
 209     push @got, scalar each %Camelus;
 210     is(scalar each %Camelus, undef, 'Fourth each returned undef');
 211     is(join(' ', sort @got), "@keys", 'The correct three keys');
 212
 213     @got = ();
 214     keys %Camelus;
 215
 216     push @got, scalar each %Camelus;
 217
 218     # This resets the hash iterator:
 219     tie %Camelus, 'Tie::StdHash';
 220     my @all = keys %Camelus;
 221     is(scalar @all, 0, 'Zero keys when tied');
 222     untie %Camelus;
 223
 224     push @got, scalar each %Camelus;
 225     push @got, scalar each %Camelus;
 226     my $fourth = scalar each %Camelus;
 227     isnt($fourth, undef, 'Fourth each did not return undef');
 228     push @got, $fourth;
 229     is(scalar each %Camelus, undef, 'Fifth each returned undef');
 230     my %have;
 231     @have{@got} = ();
 232     is(join(' ', sort keys %have), "@keys", 'Still the correct three keys');
 233 }
 234 done_testing();