t/op/avhv.t

   1 #!./perl
   2
   3 # This test was originally for pseudo-hashes.  It now exists to ensure
   4 # they were properly removed in 5.9.
   5
   6 BEGIN {
   7     chdir 't' if -d 't';
   8     @INC = '../lib';
   9 }
  10
  11 require Tie::Array;
  12
  13 package Tie::BasicArray;
  14 @ISA = 'Tie::Array';
  15 sub TIEARRAY  { bless [], $_[0] }
  16 sub STORE     { $_[0]->[$_[1]] = $_[2] }
  17 sub FETCH     { $_[0]->[$_[1]] }
  18 sub FETCHSIZE { scalar(@{$_[0]})}
  19 sub STORESIZE { $#{$_[0]} = $_[1]+1 }
  20
  21 package main;
  22
  23 require './test.pl';
  24 plan(tests => 40);
  25
  26 # Helper function to check the typical error message.
  27 sub not_hash {
  28     my($err) = shift;
  29     like( $err, qr/^Not a HASH reference / ) ||
  30       printf STDERR "# at %s line %d.\n", (caller)[1,2];
  31 }
  32
  33 # Something to place inside if blocks and while loops that won't get
  34 # compiled out.
  35 my $foo = 42;
  36 sub no_op { $foo++ }
  37
  38
  39 $sch = {
  40     'abc' => 1,
  41     'def' => 2,
  42     'jkl' => 3,
  43 };
  44
  45 # basic normal array
  46 $a = [];
  47 $a->[0] = $sch;
  48
  49 eval {
  50     $a->{'abc'} = 'ABC';
  51 };
  52 not_hash($@);
  53
  54 eval {
  55     $a->{'def'} = 'DEF';
  56 };
  57 not_hash($@);
  58
  59 eval {
  60     $a->{'jkl'} = 'JKL';
  61 };
  62 not_hash($@);
  63
  64 eval {
  65     @keys = keys %$a;
  66 };
  67 not_hash($@);
  68
  69 eval {
  70     @values = values %$a;
  71 };
  72 not_hash($@);
  73
  74 eval {
  75     while( my($k,$v) = each %$a ) {
  76         no_op;
  77     }
  78 };
  79 not_hash($@);
  80
  81
  82 # quick check with tied array
  83 tie @fake, 'Tie::StdArray';
  84 $a = \@fake;
  85 $a->[0] = $sch;
  86
  87 eval {
  88     $a->{'abc'} = 'ABC';
  89 };
  90 not_hash($@);
  91
  92 eval {
  93     if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
  94 };
  95 not_hash($@);
  96
  97 # quick check with tied array
  98 tie @fake, 'Tie::BasicArray';
  99 $a = \@fake;
 100 $a->[0] = $sch;
 101
 102 eval {
 103     $a->{'abc'} = 'ABC';
 104 };
 105 not_hash($@);
 106
 107 eval {
 108     if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
 109 };
 110 not_hash($@);
 111
 112 # quick check with tied array & tied hash
 113 require Tie::Hash;
 114 tie %fake, Tie::StdHash;
 115 %fake = %$sch;
 116 $a->[0] = \%fake;
 117
 118 eval {
 119     $a->{'abc'} = 'ABC';
 120 };
 121 not_hash($@);
 122
 123 eval {
 124     if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
 125 };
 126 not_hash($@);
 127
 128
 129 # hash slice
 130 eval {
 131     my $slice = join('', 'x',@$a{'abc','def'},'x');
 132 };
 133 not_hash($@);
 134
 135
 136 # evaluation in scalar context
 137 my $avhv = [{}];
 138
 139 eval {
 140     () = %$avhv;
 141 };
 142 not_hash($@);
 143
 144 push @$avhv, "a";
 145 eval {
 146     () = %$avhv;
 147 };
 148 not_hash($@);
 149
 150 $avhv = [];
 151 eval { $a = %$avhv };
 152 not_hash($@);
 153
 154 $avhv = [{foo=>1, bar=>2}];
 155 eval {
 156     %$avhv =~ m,^\d+/\d+,;
 157 };
 158 not_hash($@);
 159
 160 # check if defelem magic works
 161 sub f {
 162     print "not " unless $_[0] eq 'a';
 163     $_[0] = 'b';
 164     print "ok 11\n";
 165 }
 166 $a = [{key => 1}, 'a'];
 167 eval {
 168     f($a->{key});
 169 };
 170 not_hash($@);
 171
 172 # check if exists() is behaving properly
 173 $avhv = [{foo=>1,bar=>2,pants=>3}];
 174 eval {
 175     no_op if exists $avhv->{bar};
 176 };
 177 not_hash($@);
 178
 179 eval {
 180     $avhv->{pants} = undef;
 181 };
 182 not_hash($@);
 183
 184 eval {
 185     no_op if exists $avhv->{pants};
 186 };
 187 not_hash($@);
 188
 189 eval {
 190     no_op if exists $avhv->{bar};
 191 };
 192 not_hash($@);
 193
 194 eval {
 195     $avhv->{bar} = 10;
 196 };
 197 not_hash($@);
 198
 199 eval {
 200     no_op unless exists $avhv->{bar} and $avhv->{bar} == 10;
 201 };
 202 not_hash($@);
 203
 204 eval {
 205     $v = delete $avhv->{bar};
 206 };
 207 not_hash($@);
 208
 209 eval {
 210     no_op if exists $avhv->{bar};
 211 };
 212 not_hash($@);
 213
 214 eval {
 215     $avhv->{foo} = 'xxx';
 216 };
 217 not_hash($@);
 218 eval {
 219     $avhv->{bar} = 'yyy';
 220 };
 221 not_hash($@);
 222 eval {
 223     $avhv->{pants} = 'zzz';
 224 };
 225 not_hash($@);
 226 eval {
 227     @x = delete @{$avhv}{'foo','pants'};
 228 };
 229 not_hash($@);
 230 eval {
 231     no_op unless "$avhv->{bar}" eq "yyy";
 232 };
 233 not_hash($@);
 234
 235 # hash assignment
 236 eval {
 237     %$avhv = ();
 238 };
 239 not_hash($@);
 240
 241 eval {
 242     %hv = %$avhv;
 243 };
 244 not_hash($@);
 245
 246 eval {
 247     %$avhv = (foo => 29, pants => 2, bar => 0);
 248 };
 249 not_hash($@);
 250
 251 my $extra;
 252 my @extra;
 253 eval {
 254     ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
 255 };
 256 not_hash($@);
 257
 258 eval {
 259     %$avhv = ();
 260     (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
 261 };
 262 not_hash($@);
 263
 264 eval {
 265     @extra = qw(whatever and stuff);
 266     %$avhv = ();
 267 };
 268 not_hash($@);
 269 eval {
 270     (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
 271 };
 272 not_hash($@);
 273
 274 eval {
 275     (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
 276 };
 277 not_hash($@);
 278
 279 # Check hash slices (BUG ID 20010423.002)
 280 $avhv = [{foo=>1, bar=>2}];
 281 eval {
 282     @$avhv{"foo", "bar"} = (42, 53);
 283 };
 284 not_hash($@);