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 (89);
  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 references to real arrays.
  58
  59 my $test = curr_test();
  60 @ary = ($test,$test+1,$test+2,$test+3);
  61 $ref[0] = \@a;
  62 $ref[1] = \@b;
  63 $ref[2] = \@c;
  64 $ref[3] = \@d;
  65 for $i (3,1,2,0) {
  66     push(@{$ref[$i]}, "ok $ary[$i]\n");
  67 }
  68 print @a;
  69 print ${$ref[1]}[0];
  70 print @{$ref[2]}[0];
  71 {
  72     no strict 'refs';
  73     print @{'d'};
  74 }
  75 curr_test($test+4);
  76
  77 # Test references to references.
  78
  79 $refref = \\$x;
  80 $x = "Good";
  81 is ($$$refref, 'Good');
  82
  83 # Test nested anonymous lists.
  84
  85 $ref = [[],2,[3,4,5,]];
  86 is (scalar @$ref, 3);
  87 is ($$ref[1], 2);
  88 is (${$$ref[2]}[2], 5);
  89 is (scalar @{$$ref[0]}, 0);
  90
  91 is ($ref->[1], 2);
  92 is ($ref->[2]->[0], 3);
  93
  94 # Test references to hashes of references.
  95
  96 $refref = \%whatever;
  97 $refref->{"key"} = $ref;
  98 is ($refref->{"key"}->[2]->[0], 3);
  99
 100 # Test to see if anonymous subarrays spring into existence.
 101
 102 $spring[5]->[0] = 123;
 103 $spring[5]->[1] = 456;
 104 push(@{$spring[5]}, 789);
 105 is (join(':',@{$spring[5]}), "123:456:789");
 106
 107 # Test to see if anonymous subhashes spring into existence.
 108
 109 @{$spring2{"foo"}} = (1,2,3);
 110 $spring2{"foo"}->[3] = 4;
 111 is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
 112
 113 # Test references to subroutines.
 114
 115 {
 116     my $called;
 117     sub mysub { $called++; }
 118     $subref = \&mysub;
 119     &$subref;
 120     is ($called, 1);
 121 }
 122
 123 $subrefref = \\&mysub2;
 124 is ($$subrefref->("GOOD"), "good");
 125 sub mysub2 { lc shift }
 126
 127 # Test the ref operator.
 128
 129 is (ref $subref, 'CODE');
 130 is (ref $ref, 'ARRAY');
 131 is (ref $refref, 'HASH');
 132
 133 # Test anonymous hash syntax.
 134
 135 $anonhash = {};
 136 is (ref $anonhash, 'HASH');
 137 $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
 138 is (join('', sort values %$anonhash2), 'BARXYZ');
 139
 140 # Test bless operator.
 141
 142 package MYHASH;
 143
 144 $object = bless $main'anonhash2;
 145 main::is (ref $object, 'MYHASH');
 146 main::is ($object->{ABC}, 'XYZ');
 147
 148 $object2 = bless {};
 149 main::is (ref $object2, 'MYHASH');
 150
 151 # Test ordinary call on object method.
 152
 153 &mymethod($object,"argument");
 154
 155 sub mymethod {
 156     local($THIS, @ARGS) = @_;
 157     die 'Got a "' . ref($THIS). '" instead of a MYHASH'
 158         unless ref $THIS eq 'MYHASH';
 159     main::is ($ARGS[0], "argument");
 160     main::is ($THIS->{FOO}, 'BAR');
 161 }
 162
 163 # Test automatic destructor call.
 164
 165 $string = "bad";
 166 $object = "foo";
 167 $string = "good";
 168 $main'anonhash2 = "foo";
 169 $string = "";
 170
 171 DESTROY {
 172     return unless $string;
 173     main::is ($string, 'good');
 174
 175     # Test that the object has not already been "cursed".
 176     main::isnt (ref shift, 'HASH');
 177 }
 178
 179 # Now test inheritance of methods.
 180
 181 package OBJ;
 182
 183 @ISA = ('BASEOBJ');
 184
 185 $main'object = bless {FOO => 'foo', BAR => 'bar'};
 186
 187 package main;
 188
 189 # Test arrow-style method invocation.
 190
 191 is ($object->doit("BAR"), 'bar');
 192
 193 # Test indirect-object-style method invocation.
 194
 195 $foo = doit $object "FOO";
 196 main::is ($foo, 'foo');
 197
 198 sub BASEOBJ'doit {
 199     local $ref = shift;
 200     die "Not an OBJ" unless ref $ref eq 'OBJ';
 201     $ref->{shift()};
 202 }
 203
 204 package UNIVERSAL;
 205 @ISA = 'LASTCHANCE';
 206
 207 package LASTCHANCE;
 208 sub foo { main::is ($_[1], 'works') }
 209
 210 package WHATEVER;
 211 foo WHATEVER "works";
 212
 213 #
 214 # test the \(@foo) construct
 215 #
 216 package main;
 217 @foo = \(1..3);
 218 @bar = \(@foo);
 219 @baz = \(1,@foo,@bar);
 220 is (scalar (@bar), 3);
 221 is (scalar grep(ref($_), @bar), 3);
 222 is (scalar (@baz), 3);
 223
 224 my(@fuu) = \(1..2,3);
 225 my(@baa) = \(@fuu);
 226 my(@bzz) = \(1,@fuu,@baa);
 227 is (scalar (@baa), 3);
 228 is (scalar grep(ref($_), @baa), 3);
 229 is (scalar (@bzz), 3);
 230
 231 # also, it can't be an lvalue
 232 eval '\\($x, $y) = (1, 2);';
 233 like ($@, qr/Can\'t modify.*ref.*in.*assignment/);
 234
 235 # test for proper destruction of lexical objects
 236 $test = curr_test();
 237 sub larry::DESTROY { print "# larry\nok $test\n"; }
 238 sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; }
 239 sub moe::DESTROY   { print "# moe\nok ", $test + 2, "\n"; }
 240
 241 {
 242     my ($joe, @curly, %larry);
 243     my $moe = bless \$joe, 'moe';
 244     my $curly = bless \@curly, 'curly';
 245     my $larry = bless \%larry, 'larry';
 246     print "# leaving block\n";
 247 }
 248
 249 print "# left block\n";
 250 curr_test($test + 3);
 251
 252 # another glob test
 253
 254
 255 $foo = "garbage";
 256 { local(*bar) = "foo" }
 257 $bar = "glob 3";
 258 local(*bar) = *bar;
 259 is ($bar, "glob 3");
 260
 261 $var = "glob 4";
 262 $_   = \$var;
 263 is ($$_, 'glob 4');
 264
 265
 266 # test if reblessing during destruction results in more destruction
 267 $test = curr_test();
 268 {
 269     package A;
 270     sub new { bless {}, shift }
 271     DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" }
 272     package _B;
 273     sub new { bless {}, shift }
 274     DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' }
 275     package main;
 276     my $b = _B->new;
 277 }
 278 curr_test($test + 2);
 279
 280 # test if $_[0] is properly protected in DESTROY()
 281
 282 {
 283     my $test = curr_test();
 284     my $i = 0;
 285     local $SIG{'__DIE__'} = sub {
 286         my $m = shift;
 287         if ($i++ > 4) {
 288             print "# infinite recursion, bailing\nnot ok $test\n";
 289             exit 1;
 290         }
 291         like ($m, qr/^Modification of a read-only/);
 292     };
 293     package C;
 294     sub new { bless {}, shift }
 295     DESTROY { $_[0] = 'foo' }
 296     {
 297         print "# should generate an error...\n";
 298         my $c = C->new;
 299     }
 300     print "# good, didn't recurse\n";
 301 }
 302
 303 # test if refgen behaves with autoviv magic
 304 {
 305     my @a;
 306     $a[1] = "good";
 307     my $got;
 308     for (@a) {
 309         $got .= ${\$_};
 310         $got .= ';';
 311     }
 312     is ($got, ";good;");
 313 }
 314
 315 # This test is the reason for postponed destruction in sv_unref
 316 $a = [1,2,3];
 317 $a = $a->[1];
 318 is ($a, 2);
 319
 320 # This test used to coredump. The BEGIN block is important as it causes the
 321 # op that created the constant reference to be freed. Hence the only
 322 # reference to the constant string "pass" is in $a. The hack that made
 323 # sure $a = $a->[1] would work didn't work with references to constants.
 324
 325
 326 foreach my $lexical ('', 'my $a; ') {
 327   my $expect = "pass\n";
 328   my $result = runperl (switches => ['-wl'], stderr => 1,
 329     prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
 330
 331   is ($?, 0);
 332   is ($result, $expect);
 333 }
 334
 335 $test = curr_test();
 336 sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
 337 { my $a1 = bless [3],"x";
 338   my $a2 = bless [2],"x";
 339   { my $a3 = bless [1],"x";
 340     my $a4 = bless [0],"x";
 341     567;
 342   }
 343 }
 344 curr_test($test+4);
 345
 346 is (runperl (switches=>['-l'],
 347              prog=> 'print 1; print qq-*$\*-;print 1;'),
 348     "1\n*\n*\n1\n");
 349
 350 # bug #21347
 351
 352 runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
 353 is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
 354
 355 runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
 356 is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
 357
 358
 359 # bug #22719
 360
 361 runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
 362 is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
 363
 364 # bug #27268: freeing self-referential typeglobs could trigger
 365 # "Attempt to free unreferenced scalar" warnings
 366
 367 is (runperl(
 368     prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x',
 369     stderr => 1
 370 ), '', 'freeing self-referential typeglob');
 371
 372 # using a regex in the destructor for STDOUT segfaulted because the
 373 # REGEX pad had already been freed (ithreads build only). The
 374 # object is required to trigger the early freeing of GV refs to to STDOUT
 375
 376 like (runperl(
 377     prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}',
 378     stderr => 1
 379       ), qr/^(ok)+$/, 'STDOUT destructor');
 380
 381 TODO: {
 382     no strict 'refs';
 383     $name8 = chr 163;
 384     $name_utf8 = $name8 . chr 256;
 385     chop $name_utf8;
 386
 387     is ($$name8, undef, 'Nothing before we start');
 388     is ($$name_utf8, undef, 'Nothing before we start');
 389     $$name8 = "Pound";
 390     is ($$name8, "Pound", 'Accessing via 8 bit symref works');
 391     local $TODO = "UTF8 mangled in symrefs";
 392     is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
 393 }
 394
 395 TODO: {
 396     no strict 'refs';
 397     $name_utf8 = $name = chr 9787;
 398     utf8::encode $name_utf8;
 399
 400     is (length $name, 1, "Name is 1 char");
 401     is (length $name_utf8, 3, "UTF8 representation is 3 chars");
 402
 403     is ($$name, undef, 'Nothing before we start');
 404     is ($$name_utf8, undef, 'Nothing before we start');
 405     $$name = "Face";
 406     is ($$name, "Face", 'Accessing via Unicode symref works');
 407     local $TODO = "UTF8 mangled in symrefs";
 408     is ($$name_utf8, undef,
 409         'Accessing via the UTF8 byte sequence gives nothing');
 410 }
 411
 412 TODO: {
 413     no strict 'refs';
 414     $name1 = "\0Chalk";
 415     $name2 = "\0Cheese";
 416
 417     isnt ($name1, $name2, "They differ");
 418
 419     is ($$name1, undef, 'Nothing before we start');
 420     is ($$name2, undef, 'Nothing before we start');
 421     $$name2 = "Yummy";
 422     is ($$name1, "Yummy", 'Accessing via the correct name works');
 423     local $TODO = "NUL bytes truncate in symrefs";
 424     is ($$name2, undef,
 425         'Accessing via a different NUL-containing name gives nothing');
 426 }
 427
 428 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
 429 $test = curr_test();
 430 curr_test($test + 3);
 431 # test global destruction
 432
 433 my $test1 = $test + 1;
 434 my $test2 = $test + 2;
 435
 436 package FINALE;
 437
 438 {
 439     $ref3 = bless ["ok $test2\n"];      # package destruction
 440     my $ref2 = bless ["ok $test1\n"];   # lexical destruction
 441     local $ref1 = bless ["ok $test\n"]; # dynamic destruction
 442     1;                                  # flush any temp values on stack
 443 }
 444
 445 DESTROY {
 446     print $_[0][0];
 447 }
 448