t/op/ref.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = qw(. ../lib);
   6 }
   7
   8 require 'test.pl';
   9 use strict qw(refs subs);
  10
  11 plan(138);
  12
  13 # Test glob operations.
  14
  15 $bar = "one";
  16 $foo = "two";
  17 {
  18     local(*foo) = *bar;
  19     is($foo, 'one');
  20 }
  21 is ($foo, 'two');
  22
  23 $baz = "three";
  24 $foo = "four";
  25 {
  26     local(*foo) = 'baz';
  27     is ($foo, 'three');
  28 }
  29 is ($foo, 'four');
  30
  31 $foo = "global";
  32 {
  33     local(*foo);
  34     is ($foo, undef);
  35     $foo = "local";
  36     is ($foo, 'local');
  37 }
  38 is ($foo, 'global');
  39
  40 {
  41     no strict 'refs';
  42 # Test fake references.
  43
  44     $baz = "valid";
  45     $bar = 'baz';
  46     $foo = 'bar';
  47     is ($$$foo, 'valid');
  48 }
  49
  50 # Test real references.
  51
  52 $FOO = \$BAR;
  53 $BAR = \$BAZ;
  54 $BAZ = "hit";
  55 is ($$$FOO, 'hit');
  56
  57 # test that ref(vstring) makes sense
  58 my $vstref = \v1;
  59 is (ref($vstref), "VSTRING", "ref(vstr) eq VSTRING");
  60 like ( $vstref, qr/VSTRING\(0x[0-9a-f]+\)/, '\vstr is also VSTRING');
  61
  62 # Test references to real arrays.
  63
  64 my $test = curr_test();
  65 @ary = ($test,$test+1,$test+2,$test+3);
  66 $ref[0] = \@a;
  67 $ref[1] = \@b;
  68 $ref[2] = \@c;
  69 $ref[3] = \@d;
  70 for $i (3,1,2,0) {
  71     push(@{$ref[$i]}, "ok $ary[$i]\n");
  72 }
  73 print @a;
  74 print ${$ref[1]}[0];
  75 print @{$ref[2]}[0];
  76 {
  77     no strict 'refs';
  78     print @{'d'};
  79 }
  80 curr_test($test+4);
  81
  82 # Test references to references.
  83
  84 $refref = \\$x;
  85 $x = "Good";
  86 is ($$$refref, 'Good');
  87
  88 # Test nested anonymous lists.
  89
  90 $ref = [[],2,[3,4,5,]];
  91 is (scalar @$ref, 3);
  92 is ($$ref[1], 2);
  93 is (${$$ref[2]}[2], 5);
  94 is (scalar @{$$ref[0]}, 0);
  95
  96 is ($ref->[1], 2);
  97 is ($ref->[2]->[0], 3);
  98
  99 # Test references to hashes of references.
 100
 101 $refref = \%whatever;
 102 $refref->{"key"} = $ref;
 103 is ($refref->{"key"}->[2]->[0], 3);
 104
 105 # Test to see if anonymous subarrays spring into existence.
 106
 107 $spring[5]->[0] = 123;
 108 $spring[5]->[1] = 456;
 109 push(@{$spring[5]}, 789);
 110 is (join(':',@{$spring[5]}), "123:456:789");
 111
 112 # Test to see if anonymous subhashes spring into existence.
 113
 114 @{$spring2{"foo"}} = (1,2,3);
 115 $spring2{"foo"}->[3] = 4;
 116 is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
 117
 118 # Test references to subroutines.
 119
 120 {
 121     my $called;
 122     sub mysub { $called++; }
 123     $subref = \&mysub;
 124     &$subref;
 125     is ($called, 1);
 126 }
 127
 128 $subrefref = \\&mysub2;
 129 is ($$subrefref->("GOOD"), "good");
 130 sub mysub2 { lc shift }
 131
 132 # Test the ref operator.
 133
 134 is (ref $subref, 'CODE');
 135 is (ref $ref, 'ARRAY');
 136 is (ref $refref, 'HASH');
 137
 138 # Test anonymous hash syntax.
 139
 140 $anonhash = {};
 141 is (ref $anonhash, 'HASH');
 142 $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
 143 is (join('', sort values %$anonhash2), 'BARXYZ');
 144
 145 # Test bless operator.
 146
 147 package MYHASH;
 148
 149 $object = bless $main'anonhash2;
 150 main::is (ref $object, 'MYHASH');
 151 main::is ($object->{ABC}, 'XYZ');
 152
 153 $object2 = bless {};
 154 main::is (ref $object2, 'MYHASH');
 155
 156 # Test ordinary call on object method.
 157
 158 &mymethod($object,"argument");
 159
 160 sub mymethod {
 161     local($THIS, @ARGS) = @_;
 162     die 'Got a "' . ref($THIS). '" instead of a MYHASH'
 163         unless ref $THIS eq 'MYHASH';
 164     main::is ($ARGS[0], "argument");
 165     main::is ($THIS->{FOO}, 'BAR');
 166 }
 167
 168 # Test automatic destructor call.
 169
 170 $string = "bad";
 171 $object = "foo";
 172 $string = "good";
 173 $main'anonhash2 = "foo";
 174 $string = "";
 175
 176 DESTROY {
 177     return unless $string;
 178     main::is ($string, 'good');
 179
 180     # Test that the object has not already been "cursed".
 181     main::isnt (ref shift, 'HASH');
 182 }
 183
 184 # Now test inheritance of methods.
 185
 186 package OBJ;
 187
 188 @ISA = ('BASEOBJ');
 189
 190 $main'object = bless {FOO => 'foo', BAR => 'bar'};
 191
 192 package main;
 193
 194 # Test arrow-style method invocation.
 195
 196 is ($object->doit("BAR"), 'bar');
 197
 198 # Test indirect-object-style method invocation.
 199
 200 $foo = doit $object "FOO";
 201 main::is ($foo, 'foo');
 202
 203 sub BASEOBJ'doit {
 204     local $ref = shift;
 205     die "Not an OBJ" unless ref $ref eq 'OBJ';
 206     $ref->{shift()};
 207 }
 208
 209 package UNIVERSAL;
 210 @ISA = 'LASTCHANCE';
 211
 212 package LASTCHANCE;
 213 sub foo { main::is ($_[1], 'works') }
 214
 215 package WHATEVER;
 216 foo WHATEVER "works";
 217
 218 #
 219 # test the \(@foo) construct
 220 #
 221 package main;
 222 @foo = \(1..3);
 223 @bar = \(@foo);
 224 @baz = \(1,@foo,@bar);
 225 is (scalar (@bar), 3);
 226 is (scalar grep(ref($_), @bar), 3);
 227 is (scalar (@baz), 3);
 228
 229 my(@fuu) = \(1..2,3);
 230 my(@baa) = \(@fuu);
 231 my(@bzz) = \(1,@fuu,@baa);
 232 is (scalar (@baa), 3);
 233 is (scalar grep(ref($_), @baa), 3);
 234 is (scalar (@bzz), 3);
 235
 236 # also, it can't be an lvalue
 237 eval '\\($x, $y) = (1, 2);';
 238 like ($@, qr/Can\'t modify.*ref.*in.*assignment/);
 239
 240 # test for proper destruction of lexical objects
 241 $test = curr_test();
 242 sub larry::DESTROY { print "# larry\nok $test\n"; }
 243 sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; }
 244 sub moe::DESTROY   { print "# moe\nok ", $test + 2, "\n"; }
 245
 246 {
 247     my ($joe, @curly, %larry);
 248     my $moe = bless \$joe, 'moe';
 249     my $curly = bless \@curly, 'curly';
 250     my $larry = bless \%larry, 'larry';
 251     print "# leaving block\n";
 252 }
 253
 254 print "# left block\n";
 255 curr_test($test + 3);
 256
 257 # another glob test
 258
 259
 260 $foo = "garbage";
 261 { local(*bar) = "foo" }
 262 $bar = "glob 3";
 263 local(*bar) = *bar;
 264 is ($bar, "glob 3");
 265
 266 $var = "glob 4";
 267 $_   = \$var;
 268 is ($$_, 'glob 4');
 269
 270
 271 # test if reblessing during destruction results in more destruction
 272 $test = curr_test();
 273 {
 274     package A;
 275     sub new { bless {}, shift }
 276     DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" }
 277     package _B;
 278     sub new { bless {}, shift }
 279     DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' }
 280     package main;
 281     my $b = _B->new;
 282 }
 283 curr_test($test + 2);
 284
 285 # test if $_[0] is properly protected in DESTROY()
 286
 287 {
 288     my $test = curr_test();
 289     my $i = 0;
 290     local $SIG{'__DIE__'} = sub {
 291         my $m = shift;
 292         if ($i++ > 4) {
 293             print "# infinite recursion, bailing\nnot ok $test\n";
 294             exit 1;
 295         }
 296         like ($m, qr/^Modification of a read-only/);
 297     };
 298     package C;
 299     sub new { bless {}, shift }
 300     DESTROY { $_[0] = 'foo' }
 301     {
 302         print "# should generate an error...\n";
 303         my $c = C->new;
 304     }
 305     print "# good, didn't recurse\n";
 306 }
 307
 308 # test if refgen behaves with autoviv magic
 309 {
 310     my @a;
 311     $a[1] = "good";
 312     my $got;
 313     for (@a) {
 314         $got .= ${\$_};
 315         $got .= ';';
 316     }
 317     is ($got, ";good;");
 318 }
 319
 320 # This test is the reason for postponed destruction in sv_unref
 321 $a = [1,2,3];
 322 $a = $a->[1];
 323 is ($a, 2);
 324
 325 # This test used to coredump. The BEGIN block is important as it causes the
 326 # op that created the constant reference to be freed. Hence the only
 327 # reference to the constant string "pass" is in $a. The hack that made
 328 # sure $a = $a->[1] would work didn't work with references to constants.
 329
 330
 331 foreach my $lexical ('', 'my $a; ') {
 332   my $expect = "pass\n";
 333   my $result = runperl (switches => ['-wl'], stderr => 1,
 334     prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
 335
 336   is ($?, 0);
 337   is ($result, $expect);
 338 }
 339
 340 $test = curr_test();
 341 sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
 342 { my $a1 = bless [3],"x";
 343   my $a2 = bless [2],"x";
 344   { my $a3 = bless [1],"x";
 345     my $a4 = bless [0],"x";
 346     567;
 347   }
 348 }
 349 curr_test($test+4);
 350
 351 is (runperl (switches=>['-l'],
 352              prog=> 'print 1; print qq-*$\*-;print 1;'),
 353     "1\n*\n*\n1\n");
 354
 355 # bug #21347
 356
 357 runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
 358 is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
 359
 360 runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
 361 is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
 362
 363
 364 # bug #22719
 365
 366 runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
 367 is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
 368
 369 # bug #27268: freeing self-referential typeglobs could trigger
 370 # "Attempt to free unreferenced scalar" warnings
 371
 372 is (runperl(
 373     prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x',
 374     stderr => 1
 375 ), '', 'freeing self-referential typeglob');
 376
 377 # using a regex in the destructor for STDOUT segfaulted because the
 378 # REGEX pad had already been freed (ithreads build only). The
 379 # object is required to trigger the early freeing of GV refs to to STDOUT
 380
 381 like (runperl(
 382     prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}',
 383     stderr => 1
 384       ), qr/^(ok)+$/, 'STDOUT destructor');
 385
 386 TODO: {
 387     no strict 'refs';
 388     $name8 = chr 163;
 389     $name_utf8 = $name8 . chr 256;
 390     chop $name_utf8;
 391
 392     is ($$name8, undef, 'Nothing before we start');
 393     is ($$name_utf8, undef, 'Nothing before we start');
 394     $$name8 = "Pound";
 395     is ($$name8, "Pound", 'Accessing via 8 bit symref works');
 396     local $TODO = "UTF8 mangled in symrefs";
 397     is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
 398 }
 399
 400 TODO: {
 401     no strict 'refs';
 402     $name_utf8 = $name = chr 9787;
 403     utf8::encode $name_utf8;
 404
 405     is (length $name, 1, "Name is 1 char");
 406     is (length $name_utf8, 3, "UTF8 representation is 3 chars");
 407
 408     is ($$name, undef, 'Nothing before we start');
 409     is ($$name_utf8, undef, 'Nothing before we start');
 410     $$name = "Face";
 411     is ($$name, "Face", 'Accessing via Unicode symref works');
 412     local $TODO = "UTF8 mangled in symrefs";
 413     is ($$name_utf8, undef,
 414         'Accessing via the UTF8 byte sequence gives nothing');
 415 }
 416
 417 {
 418     no strict 'refs';
 419     $name1 = "\0Chalk";
 420     $name2 = "\0Cheese";
 421
 422     isnt ($name1, $name2, "They differ");
 423
 424     is ($$name1, undef, 'Nothing before we start (scalars)');
 425     is ($$name2, undef, 'Nothing before we start');
 426     $$name1 = "Yummy";
 427     is ($$name1, "Yummy", 'Accessing via the correct name works');
 428     is ($$name2, undef,
 429         'Accessing via a different NUL-containing name gives nothing');
 430     # defined uses a different code path
 431     ok (defined $$name1, 'defined via the correct name works');
 432     ok (!defined $$name2,
 433         'defined via a different NUL-containing name gives nothing');
 434
 435     is ($name1->[0], undef, 'Nothing before we start (arrays)');
 436     is ($name2->[0], undef, 'Nothing before we start');
 437     $name1->[0] = "Yummy";
 438     is ($name1->[0], "Yummy", 'Accessing via the correct name works');
 439     is ($name2->[0], undef,
 440         'Accessing via a different NUL-containing name gives nothing');
 441     ok (defined $name1->[0], 'defined via the correct name works');
 442     ok (!defined$name2->[0],
 443         'defined via a different NUL-containing name gives nothing');
 444
 445     my (undef, $one) = @{$name1}[2,3];
 446     my (undef, $two) = @{$name2}[2,3];
 447     is ($one, undef, 'Nothing before we start (array slices)');
 448     is ($two, undef, 'Nothing before we start');
 449     @{$name1}[2,3] = ("Very", "Yummy");
 450     (undef, $one) = @{$name1}[2,3];
 451     (undef, $two) = @{$name2}[2,3];
 452     is ($one, "Yummy", 'Accessing via the correct name works');
 453     is ($two, undef,
 454         'Accessing via a different NUL-containing name gives nothing');
 455     ok (defined $one, 'defined via the correct name works');
 456     ok (!defined $two,
 457         'defined via a different NUL-containing name gives nothing');
 458
 459     is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)');
 460     is ($name2->{PWOF}, undef, 'Nothing before we start');
 461     $name1->{PWOF} = "Yummy";
 462     is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works');
 463     is ($name2->{PWOF}, undef,
 464         'Accessing via a different NUL-containing name gives nothing');
 465     ok (defined $name1->{PWOF}, 'defined via the correct name works');
 466     ok (!defined $name2->{PWOF},
 467         'defined via a different NUL-containing name gives nothing');
 468
 469     my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
 470     my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
 471     is ($one, undef, 'Nothing before we start (hash slices)');
 472     is ($two, undef, 'Nothing before we start');
 473     @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy");
 474     (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
 475     (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
 476     is ($one, "Yummy", 'Accessing via the correct name works');
 477     is ($two, undef,
 478         'Accessing via a different NUL-containing name gives nothing');
 479     ok (defined $one, 'defined via the correct name works');
 480     ok (!defined $two,
 481         'defined via a different NUL-containing name gives nothing');
 482
 483     $name1 = "Left"; $name2 = "Left\0Right";
 484     my $glob2 = *{$name2};
 485
 486     is ($glob1, undef, "We get different typeglobs. In fact, undef");
 487
 488     *{$name1} = sub {"One"};
 489     *{$name2} = sub {"Two"};
 490
 491     is (&{$name1}, "One");
 492     is (&{$name2}, "Two");
 493 }
 494
 495 # test derefs after list slice
 496
 497 is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' );
 498 is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' );
 499 is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' );
 500 is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' );
 501 is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' );
 502 is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' );
 503
 504 # deref on empty list shouldn't autovivify
 505 {
 506     local $@;
 507     eval { ()[0]{foo} };
 508     like ( "$@", "Can't use an undefined value as a HASH reference",
 509            "deref of undef from list slice fails" );
 510 }
 511
 512 # test dereferencing errors
 513 {
 514     format STDERR =
 515 .
 516     my $ref;
 517     foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) {
 518         eval q/ $$ref /;
 519         like($@, qr/Not a SCALAR reference/, "Scalar dereference");
 520         eval q/ @$ref /;
 521         like($@, qr/Not an ARRAY reference/, "Array dereference");
 522         eval q/ %$ref /;
 523         like($@, qr/Not a HASH reference/, "Hash dereference");
 524         eval q/ &$ref /;
 525         like($@, qr/Not a CODE reference/, "Code dereference");
 526     }
 527
 528     $ref = *STDERR{FORMAT};
 529     eval q/ *$ref /;
 530     like($@, qr/Not a GLOB reference/, "Glob dereference");
 531
 532     $ref = *STDOUT{IO};
 533     eval q/ *$ref /;
 534     is($@, '', "Glob dereference of PVIO is acceptable");
 535
 536     is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly");
 537 }
 538
 539 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
 540 $test = curr_test();
 541 curr_test($test + 3);
 542 # test global destruction
 543
 544 my $test1 = $test + 1;
 545 my $test2 = $test + 2;
 546
 547 package FINALE;
 548
 549 {
 550     $ref3 = bless ["ok $test2\n"];      # package destruction
 551     my $ref2 = bless ["ok $test1\n"];   # lexical destruction
 552     local $ref1 = bless ["ok $test\n"]; # dynamic destruction
 553     1;                                  # flush any temp values on stack
 554 }
 555
 556 DESTROY {
 557     print $_[0][0];
 558 }
 559