t/op/ref.t

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