1#!./perl 2 3print "1..56\n"; 4 5# Test glob operations. 6 7$bar = "ok 1\n"; 8$foo = "ok 2\n"; 9{ 10 local(*foo) = *bar; 11 print $foo; 12} 13print $foo; 14 15$baz = "ok 3\n"; 16$foo = "ok 4\n"; 17{ 18 local(*foo) = 'baz'; 19 print $foo; 20} 21print $foo; 22 23$foo = "ok 6\n"; 24{ 25 local(*foo); 26 print $foo; 27 $foo = "ok 5\n"; 28 print $foo; 29} 30print $foo; 31 32# Test fake references. 33 34$baz = "ok 7\n"; 35$bar = 'baz'; 36$foo = 'bar'; 37print $$$foo; 38 39# Test real references. 40 41$FOO = \$BAR; 42$BAR = \$BAZ; 43$BAZ = "ok 8\n"; 44print $$$FOO; 45 46# Test references to real arrays. 47 48@ary = (9,10,11,12); 49$ref[0] = \@a; 50$ref[1] = \@b; 51$ref[2] = \@c; 52$ref[3] = \@d; 53for $i (3,1,2,0) { 54 push(@{$ref[$i]}, "ok $ary[$i]\n"); 55} 56print @a; 57print ${$ref[1]}[0]; 58print @{$ref[2]}[0]; 59print @{'d'}; 60 61# Test references to references. 62 63$refref = \\$x; 64$x = "ok 13\n"; 65print $$$refref; 66 67# Test nested anonymous lists. 68 69$ref = [[],2,[3,4,5,]]; 70print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n"; 71print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n"; 72print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n"; 73print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n"; 74 75print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n"; 76print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n"; 77 78# Test references to hashes of references. 79 80$refref = \%whatever; 81$refref->{"key"} = $ref; 82print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n"; 83 84# Test to see if anonymous subarrays spring into existence. 85 86$spring[5]->[0] = 123; 87$spring[5]->[1] = 456; 88push(@{$spring[5]}, 789); 89print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n"; 90 91# Test to see if anonymous subhashes spring into existence. 92 93@{$spring2{"foo"}} = (1,2,3); 94$spring2{"foo"}->[3] = 4; 95print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n"; 96 97# Test references to subroutines. 98 99sub mysub { print "ok 23\n" } 100$subref = \&mysub; 101&$subref; 102 103$subrefref = \\&mysub2; 104$$subrefref->("ok 24\n"); 105sub mysub2 { print shift } 106 107# Test the ref operator. 108 109print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n"; 110print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n"; 111print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n"; 112 113# Test anonymous hash syntax. 114 115$anonhash = {}; 116print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n"; 117$anonhash2 = {FOO => BAR, ABC => XYZ,}; 118print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n"; 119 120# Test bless operator. 121 122package MYHASH; 123 124$object = bless $main'anonhash2; 125print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n"; 126print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n"; 127 128$object2 = bless {}; 129print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n"; 130 131# Test ordinary call on object method. 132 133&mymethod($object,33); 134 135sub mymethod { 136 local($THIS, @ARGS) = @_; 137 die 'Got a "' . ref($THIS). '" instead of a MYHASH' 138 unless ref $THIS eq MYHASH; 139 print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n"; 140} 141 142# Test automatic destructor call. 143 144$string = "not ok 34\n"; 145$object = "foo"; 146$string = "ok 34\n"; 147$main'anonhash2 = "foo"; 148$string = ""; 149 150DESTROY { 151 return unless $string; 152 print $string; 153 154 # Test that the object has not already been "cursed". 155 print ref shift ne HASH ? "ok 35\n" : "not ok 35\n"; 156} 157 158# Now test inheritance of methods. 159 160package OBJ; 161 162@ISA = (BASEOBJ); 163 164$main'object = bless {FOO => foo, BAR => bar}; 165 166package main; 167 168# Test arrow-style method invocation. 169 170print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n"; 171 172# Test indirect-object-style method invocation. 173 174$foo = doit $object "FOO"; 175print $foo eq foo ? "ok 37\n" : "not ok 37\n"; 176 177sub BASEOBJ'doit { 178 local $ref = shift; 179 die "Not an OBJ" unless ref $ref eq OBJ; 180 $ref->{shift()}; 181} 182 183package UNIVERSAL; 184@ISA = 'LASTCHANCE'; 185 186package LASTCHANCE; 187sub foo { print $_[1] } 188 189package WHATEVER; 190foo WHATEVER "ok 38\n"; 191 192# 193# test the \(@foo) construct 194# 195package main; 196@foo = (1,2,3); 197@bar = \(@foo); 198@baz = \(1,@foo,@bar); 199print @bar == 3 ? "ok 39\n" : "not ok 39\n"; 200print grep(ref($_), @bar) == 3 ? "ok 40\n" : "not ok 40\n"; 201print @baz == 3 ? "ok 41\n" : "not ok 41\n"; 202 203my(@fuu) = (1,2,3); 204my(@baa) = \(@fuu); 205my(@bzz) = \(1,@fuu,@baa); 206print @baa == 3 ? "ok 42\n" : "not ok 42\n"; 207print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n"; 208print @bzz == 3 ? "ok 44\n" : "not ok 44\n"; 209 210# test for proper destruction of lexical objects 211 212sub larry::DESTROY { print "# larry\nok 45\n"; } 213sub curly::DESTROY { print "# curly\nok 46\n"; } 214sub moe::DESTROY { print "# moe\nok 47\n"; } 215 216{ 217 my ($joe, @curly, %larry); 218 my $moe = bless \$joe, 'moe'; 219 my $curly = bless \@curly, 'curly'; 220 my $larry = bless \%larry, 'larry'; 221 print "# leaving block\n"; 222} 223 224print "# left block\n"; 225 226# another glob test 227 228$foo = "not ok 48"; 229{ local(*bar) = "foo" } 230$bar = "ok 48"; 231local(*bar) = *bar; 232print "$bar\n"; 233 234$var = "ok 49"; 235$_ = \$var; 236print $$_,"\n"; 237 238# test if reblessing during destruction results in more destruction 239 240{ 241 package A; 242 sub new { bless {}, shift } 243 DESTROY { print "# destroying 'A'\nok 51\n" } 244 package _B; 245 sub new { bless {}, shift } 246 DESTROY { print "# destroying '_B'\nok 50\n"; bless shift, 'A' } 247 package main; 248 my $b = _B->new; 249} 250 251# test if $_[0] is properly protected in DESTROY() 252 253{ 254 my $i = 0; 255 local $SIG{'__DIE__'} = sub { 256 my $m = shift; 257 if ($i++ > 4) { 258 print "# infinite recursion, bailing\nnot ok 52\n"; 259 exit 1; 260 } 261 print "# $m"; 262 if ($m =~ /^Modification of a read-only/) { print "ok 52\n" } 263 }; 264 package C; 265 sub new { bless {}, shift } 266 DESTROY { $_[0] = 'foo' } 267 { 268 print "# should generate an error...\n"; 269 my $c = C->new; 270 } 271 print "# good, didn't recurse\n"; 272} 273 274# test if refgen behaves with autoviv magic 275 276{ 277 my @a; 278 $a[1] = "ok 53\n"; 279 print ${\$_} for @a; 280} 281 282# test global destruction 283 284package FINALE; 285 286{ 287 $ref3 = bless ["ok 56\n"]; # package destruction 288 my $ref2 = bless ["ok 55\n"]; # lexical destruction 289 local $ref1 = bless ["ok 54\n"]; # dynamic destruction 290 1; # flush any temp values on stack 291} 292 293DESTROY { 294 print $_[0][0]; 295} 296