| 1 | #!./perl -w |
| 2 | |
| 3 | my $w; |
| 4 | |
| 5 | BEGIN { |
| 6 | chdir 't' if -d 't'; |
| 7 | @INC = '../lib'; |
| 8 | $SIG{__WARN__} = sub { |
| 9 | if ($_[0] =~ /^Hides field 'b1' in base class/) { |
| 10 | $w++; |
| 11 | return; |
| 12 | } |
| 13 | print $_[0]; |
| 14 | }; |
| 15 | } |
| 16 | |
| 17 | use strict; |
| 18 | use warnings; |
| 19 | use vars qw($DEBUG); |
| 20 | |
| 21 | package B1; |
| 22 | use fields qw(b1 b2 b3); |
| 23 | |
| 24 | package B2; |
| 25 | use fields '_b1'; |
| 26 | use fields qw(b1 _b2 b2); |
| 27 | |
| 28 | sub new { bless [], shift } |
| 29 | |
| 30 | package D1; |
| 31 | use base 'B1'; |
| 32 | use fields qw(d1 d2 d3); |
| 33 | |
| 34 | package D2; |
| 35 | use base 'B1'; |
| 36 | use fields qw(_d1 _d2); |
| 37 | use fields qw(d1 d2); |
| 38 | |
| 39 | package D3; |
| 40 | use base 'B2'; |
| 41 | use fields qw(b1 d1 _b1 _d1); # hide b1 |
| 42 | |
| 43 | package D4; |
| 44 | use base 'D3'; |
| 45 | use fields qw(_d3 d3); |
| 46 | |
| 47 | package M; |
| 48 | sub m {} |
| 49 | |
| 50 | package D5; |
| 51 | use base qw(M B2); |
| 52 | |
| 53 | package Foo::Bar; |
| 54 | use base 'B1'; |
| 55 | |
| 56 | package Foo::Bar::Baz; |
| 57 | use base 'Foo::Bar'; |
| 58 | use fields qw(foo bar baz); |
| 59 | |
| 60 | # Test repeatability for when modules get reloaded. |
| 61 | package B1; |
| 62 | use fields qw(b1 b2 b3); |
| 63 | |
| 64 | package D3; |
| 65 | use base 'B2'; |
| 66 | use fields qw(b1 d1 _b1 _d1); # hide b1 |
| 67 | |
| 68 | package main; |
| 69 | |
| 70 | sub fstr { |
| 71 | my $h = shift; |
| 72 | my @tmp; |
| 73 | for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { |
| 74 | my $v = $h->{$k}; |
| 75 | push(@tmp, "$k:$v"); |
| 76 | } |
| 77 | my $str = join(",", @tmp); |
| 78 | print "$h => $str\n" if $DEBUG; |
| 79 | $str; |
| 80 | } |
| 81 | |
| 82 | my %expect = ( |
| 83 | B1 => "b1:1,b2:2,b3:3", |
| 84 | B2 => "_b1:1,b1:2,_b2:3,b2:4", |
| 85 | D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", |
| 86 | D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", |
| 87 | D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", |
| 88 | D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", |
| 89 | D5 => "b1:2,b2:4", |
| 90 | 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', |
| 91 | ); |
| 92 | |
| 93 | print "1..", int(keys %expect)+15, "\n"; |
| 94 | my $testno = 0; |
| 95 | while (my($class, $exp) = each %expect) { |
| 96 | no strict 'refs'; |
| 97 | my $fstr = fstr(\%{$class."::FIELDS"}); |
| 98 | print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; |
| 99 | print "ok ", ++$testno, "\n"; |
| 100 | } |
| 101 | |
| 102 | # Did we get the appropriate amount of warnings? |
| 103 | print "not " unless $w == 1; |
| 104 | print "ok ", ++$testno, "\n"; |
| 105 | |
| 106 | # A simple object creation and AVHV attribute access test |
| 107 | my B2 $obj1 = D3->new; |
| 108 | $obj1->{b1} = "B2"; |
| 109 | my D3 $obj2 = $obj1; |
| 110 | $obj2->{b1} = "D3"; |
| 111 | |
| 112 | print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; |
| 113 | print "ok ", ++$testno, "\n"; |
| 114 | |
| 115 | # We should get compile time failures field name typos |
| 116 | eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); |
| 117 | print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; |
| 118 | print "ok ", ++$testno, "\n"; |
| 119 | |
| 120 | # Slices |
| 121 | @$obj1{"_b1", "b1"} = (17, 29); |
| 122 | print "not " unless "@$obj1[1,2]" eq "17 29"; |
| 123 | print "ok ", ++$testno, "\n"; |
| 124 | @$obj1[1,2] = (44,28); |
| 125 | print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; |
| 126 | print "ok ", ++$testno, "\n"; |
| 127 | |
| 128 | my $ph = fields::phash(a => 1, b => 2, c => 3); |
| 129 | print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; |
| 130 | print "ok ", ++$testno, "\n"; |
| 131 | |
| 132 | $ph = fields::phash([qw/a b c/], [1, 2, 3]); |
| 133 | print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; |
| 134 | print "ok ", ++$testno, "\n"; |
| 135 | |
| 136 | $ph = fields::phash([qw/a b c/], [1]); |
| 137 | print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; |
| 138 | print "ok ", ++$testno, "\n"; |
| 139 | |
| 140 | eval '$ph = fields::phash("odd")'; |
| 141 | print "not " unless $@ && $@ =~ /^Odd number of/; |
| 142 | print "ok ", ++$testno, "\n"; |
| 143 | |
| 144 | #fields::_dump(); |
| 145 | |
| 146 | # check if fields autovivify |
| 147 | { |
| 148 | package Foo; |
| 149 | use fields qw(foo bar); |
| 150 | sub new { bless [], $_[0]; } |
| 151 | |
| 152 | package main; |
| 153 | my Foo $a = Foo->new(); |
| 154 | $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; |
| 155 | $a->{bar} = { A => 'ok ' . ++$testno }; |
| 156 | print $a->{foo}[1], "\n"; |
| 157 | print $a->{bar}->{A}, "\n"; |
| 158 | } |
| 159 | |
| 160 | # check if fields autovivify |
| 161 | { |
| 162 | package Bar; |
| 163 | use fields qw(foo bar); |
| 164 | sub new { return fields::new($_[0]) } |
| 165 | |
| 166 | package main; |
| 167 | my Bar $a = Bar::->new(); |
| 168 | $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; |
| 169 | $a->{bar} = { A => 'ok ' . ++$testno }; |
| 170 | print $a->{foo}[1], "\n"; |
| 171 | print $a->{bar}->{A}, "\n"; |
| 172 | } |
| 173 | |
| 174 | |
| 175 | # Test $VERSION bug |
| 176 | package No::Version; |
| 177 | |
| 178 | use vars qw($Foo); |
| 179 | sub VERSION { 42 } |
| 180 | |
| 181 | package Test::Version; |
| 182 | |
| 183 | use base qw(No::Version); |
| 184 | print "not " unless $No::Version::VERSION =~ /set by base\.pm/; |
| 185 | print "ok ", ++$testno ,"\n"; |
| 186 | |
| 187 | # Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION |
| 188 | package Has::Version; |
| 189 | |
| 190 | BEGIN { $Has::Version::VERSION = '42' }; |
| 191 | |
| 192 | package Test::Version2; |
| 193 | |
| 194 | use base qw(Has::Version); |
| 195 | print "#$Has::Version::VERSION\nnot " unless $Has::Version::VERSION eq '42'; |
| 196 | print "ok ", ++$testno ,"\n"; |
| 197 | |