t/op/avhv.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 require Tie::Array;
   9
  10 package Tie::BasicArray;
  11 @ISA = 'Tie::Array';
  12 sub TIEARRAY  { bless [], $_[0] }
  13 sub STORE     { $_[0]->[$_[1]] = $_[2] }
  14 sub FETCH     { $_[0]->[$_[1]] }
  15 sub FETCHSIZE { scalar(@{$_[0]})}
  16 sub STORESIZE { $#{$_[0]} = $_[1]+1 }
  17
  18 package main;
  19
  20 print "1..28\n";
  21
  22 $sch = {
  23     'abc' => 1,
  24     'def' => 2,
  25     'jkl' => 3,
  26 };
  27
  28 # basic normal array
  29 $a = [];
  30 $a->[0] = $sch;
  31
  32 $a->{'abc'} = 'ABC';
  33 $a->{'def'} = 'DEF';
  34 $a->{'jkl'} = 'JKL';
  35
  36 @keys = keys %$a;
  37 @values = values %$a;
  38
  39 if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";}
  40
  41 $i = 0;         # stop -w complaints
  42
  43 while (($key,$value) = each %$a) {
  44     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
  45         $key =~ y/a-z/A-Z/;
  46         $i++ if $key eq $value;
  47     }
  48 }
  49
  50 if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";}
  51
  52 # quick check with tied array
  53 tie @fake, 'Tie::StdArray';
  54 $a = \@fake;
  55 $a->[0] = $sch;
  56
  57 $a->{'abc'} = 'ABC';
  58 if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
  59
  60 # quick check with tied array
  61 tie @fake, 'Tie::BasicArray';
  62 $a = \@fake;
  63 $a->[0] = $sch;
  64
  65 $a->{'abc'} = 'ABC';
  66 if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
  67
  68 # quick check with tied array & tied hash
  69 require Tie::Hash;
  70 tie %fake, Tie::StdHash;
  71 %fake = %$sch;
  72 $a->[0] = \%fake;
  73
  74 $a->{'abc'} = 'ABC';
  75 if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
  76
  77 # hash slice
  78 my $slice = join('', 'x',@$a{'abc','def'},'x');
  79 print "not " if $slice ne 'xABCx';
  80 print "ok 6\n";
  81
  82 # evaluation in scalar context
  83 my $avhv = [{}];
  84 print "not " if %$avhv;
  85 print "ok 7\n";
  86
  87 push @$avhv, "a";
  88 print "not " if %$avhv;
  89 print "ok 8\n";
  90
  91 $avhv = [];
  92 eval { $a = %$avhv };
  93 print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;
  94 print "ok 9\n";
  95
  96 $avhv = [{foo=>1, bar=>2}];
  97 print "not " unless %$avhv =~ m,^\d+/\d+,;
  98 print "ok 10\n";
  99
 100 # check if defelem magic works
 101 sub f {
 102     print "not " unless $_[0] eq 'a';
 103     $_[0] = 'b';
 104     print "ok 11\n";
 105 }
 106 $a = [{key => 1}, 'a'];
 107 f($a->{key});
 108 print "not " unless $a->[1] eq 'b';
 109 print "ok 12\n";
 110
 111 # check if exists() is behaving properly
 112 $avhv = [{foo=>1,bar=>2,pants=>3}];
 113 print "not " if exists $avhv->{bar};
 114 print "ok 13\n";
 115
 116 $avhv->{pants} = undef;
 117 print "not " unless exists $avhv->{pants};
 118 print "ok 14\n";
 119 print "not " if exists $avhv->{bar};
 120 print "ok 15\n";
 121
 122 $avhv->{bar} = 10;
 123 print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10;
 124 print "ok 16\n";
 125
 126 $v = delete $avhv->{bar};
 127 print "not " unless $v == 10;
 128 print "ok 17\n";
 129
 130 print "not " if exists $avhv->{bar};
 131 print "ok 18\n";
 132
 133 $avhv->{foo} = 'xxx';
 134 $avhv->{bar} = 'yyy';
 135 $avhv->{pants} = 'zzz';
 136 @x = delete @{$avhv}{'foo','pants'};
 137 print "# @x\nnot " unless "@x" eq "xxx zzz";
 138 print "ok 19\n";
 139
 140 print "not " unless "$avhv->{bar}" eq "yyy";
 141 print "ok 20\n";
 142
 143 # hash assignment
 144 %$avhv = ();
 145 print "not " unless ref($avhv->[0]) eq 'HASH';
 146 print "ok 21\n";
 147
 148 %hv = %$avhv;
 149 print "not " if grep defined, values %hv;
 150 print "ok 22\n";
 151 print "not " if grep ref, keys %hv;
 152 print "ok 23\n";
 153
 154 %$avhv = (foo => 29, pants => 2, bar => 0);
 155 print "not " unless "@$avhv[1..3]" eq '29 0 2';
 156 print "ok 24\n";
 157
 158 my $extra;
 159 my @extra;
 160 ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
 161 print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo';
 162 print "ok 25\n";
 163
 164 %$avhv = ();
 165 (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
 166 print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra;
 167 print "ok 26\n";
 168
 169 @extra = qw(whatever and stuff);
 170 %$avhv = ();
 171 (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
 172 print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0;
 173 print "ok 27\n";
 174
 175 %$avhv = ();
 176 (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
 177 print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6;
 178 print "ok 28\n";