Commit | Line | Data |
5d5aaa5e |
1 | #!./perl |
a60c0954 |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | require Tie::Array; |
5d5aaa5e |
9 | |
a60c0954 |
10 | package Tie::BasicArray; |
11 | @ISA = 'Tie::Array'; |
5d5aaa5e |
12 | sub TIEARRAY { bless [], $_[0] } |
a60c0954 |
13 | sub STORE { $_[0]->[$_[1]] = $_[2] } |
14 | sub FETCH { $_[0]->[$_[1]] } |
15 | sub FETCHSIZE { scalar(@{$_[0]})} |
16 | sub STORESIZE { $#{$_[0]} = $_[1]+1 } |
5d5aaa5e |
17 | |
18 | package main; |
19 | |
a60c0954 |
20 | print "1..5\n"; |
5d5aaa5e |
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 | $a->{'a'} = 'A'; #should extend schema |
36 | |
37 | @keys = keys %$a; |
38 | @values = values %$a; |
39 | |
40 | if ($#keys == 3 && $#values == 3) {print "ok 1\n";} else {print "not ok 1\n";} |
41 | |
42 | $i = 0; # stop -w complaints |
43 | |
44 | while (($key,$value) = each %$a) { |
45 | if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { |
46 | $key =~ y/a-z/A-Z/; |
47 | $i++ if $key eq $value; |
48 | } |
49 | } |
50 | |
51 | if ($i == 4) {print "ok 2\n";} else {print "not ok 2\n";} |
52 | |
53 | # quick check with tied array |
54 | tie @fake, 'Tie::StdArray'; |
55 | $a = \@fake; |
56 | $a->[0] = $sch; |
57 | |
58 | $a->{'abc'} = 'ABC'; |
59 | if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";} |
60 | |
a60c0954 |
61 | # quick check with tied array |
62 | tie @fake, 'Tie::BasicArray'; |
63 | $a = \@fake; |
64 | $a->[0] = $sch; |
65 | |
66 | $a->{'abc'} = 'ABC'; |
67 | if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";} |
68 | |
5d5aaa5e |
69 | # quick check with tied array & tied hash |
5d5aaa5e |
70 | require Tie::Hash; |
71 | tie %fake, Tie::StdHash; |
72 | %fake = %$sch; |
73 | $a->[0] = \%fake; |
74 | |
75 | $a->{'abc'} = 'ABC'; |
a60c0954 |
76 | if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";} |