t/op/gv.t

   1 #!./perl
   2
   3 #
   4 # various typeglob tests
   5 #
   6
   7 BEGIN {
   8     chdir 't' if -d 't';
   9     @INC = '../lib';
  10 }
  11
  12 use warnings;
  13
  14 require './test.pl';
  15 plan( tests => 178 );
  16
  17 # type coersion on assignment
  18 $foo = 'foo';
  19 $bar = *main::foo;
  20 $bar = $foo;
  21 is(ref(\$bar), 'SCALAR');
  22 $foo = *main::bar;
  23
  24 # type coersion (not) on misc ops
  25
  26 ok($foo);
  27 is(ref(\$foo), 'GLOB');
  28
  29 unlike ($foo, qr/abcd/);
  30 is(ref(\$foo), 'GLOB');
  31
  32 is($foo, '*main::bar');
  33 is(ref(\$foo), 'GLOB');
  34
  35 # type coersion on substitutions that match
  36 $a = *main::foo;
  37 $b = $a;
  38 $a =~ s/^X//;
  39 is(ref(\$a), 'GLOB');
  40 $a =~ s/^\*//;
  41 is($a, 'main::foo');
  42 is(ref(\$b), 'GLOB');
  43
  44 # typeglobs as lvalues
  45 substr($foo, 0, 1) = "XXX";
  46 is(ref(\$foo), 'SCALAR');
  47 is($foo, 'XXXmain::bar');
  48
  49 # returning glob values
  50 sub foo {
  51   local($bar) = *main::foo;
  52   $foo = *main::bar;
  53   return ($foo, $bar);
  54 }
  55
  56 ($fuu, $baa) = foo();
  57 ok(defined $fuu);
  58 is(ref(\$fuu), 'GLOB');
  59
  60
  61 ok(defined $baa);
  62 is(ref(\$baa), 'GLOB');
  63
  64 # nested package globs
  65 # NOTE:  It's probably OK if these semantics change, because the
  66 #        fact that %X::Y:: is stored in %X:: isn't documented.
  67 #        (I hope.)
  68
  69 { package Foo::Bar; no warnings 'once'; $test=1; }
  70 ok(exists $Foo::{'Bar::'});
  71 is($Foo::{'Bar::'}, '*Foo::Bar::');
  72
  73
  74 # test undef operator clearing out entire glob
  75 $foo = 'stuff';
  76 @foo = qw(more stuff);
  77 %foo = qw(even more random stuff);
  78 undef *foo;
  79 is ($foo, undef);
  80 is (scalar @foo, 0);
  81 is (scalar %foo, 0);
  82
  83 {
  84     # test warnings from assignment of undef to glob
  85     my $msg = '';
  86     local $SIG{__WARN__} = sub { $msg = $_[0] };
  87     use warnings;
  88     *foo = 'bar';
  89     is($msg, '');
  90     *foo = undef;
  91     like($msg, qr/Undefined value assigned to typeglob/);
  92
  93     no warnings 'once';
  94     # test warnings for converting globs to other forms
  95     my $copy = *PWOMPF;
  96     foreach ($copy, *SKREEE) {
  97         $msg = '';
  98         my $victim = sprintf "%d", $_;
  99         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
 100              "Warning on conversion to IV");
 101         is($victim, 0);
 102
 103         $msg = '';
 104         $victim = sprintf "%u", $_;
 105         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
 106              "Warning on conversion to UV");
 107         is($victim, 0);
 108
 109         $msg = '';
 110         $victim = sprintf "%e", $_;
 111         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
 112              "Warning on conversion to NV");
 113         like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero");
 114
 115         $msg = '';
 116         $victim = sprintf "%s", $_;
 117         is($msg, '', "No warning on stringification");
 118         is($victim, '' . $_);
 119     }
 120 }
 121
 122 my $test = curr_test();
 123 # test *glob{THING} syntax
 124 $x = "ok $test\n";
 125 ++$test;
 126 @x = ("ok $test\n");
 127 ++$test;
 128 %x = ("ok $test" => "\n");
 129 ++$test;
 130 sub x { "ok $test\n" }
 131 print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
 132 # This needs to go here, after the print, as sub x will return the current
 133 # value of test
 134 ++$test;
 135 format x =
 136 XXX This text isn't used. Should it be?
 137 .
 138 curr_test($test);
 139
 140 is (ref *x{FORMAT}, "FORMAT");
 141 *x = *STDOUT;
 142 is (*{*x{GLOB}}, "*main::STDOUT");
 143
 144 {
 145     my $test = curr_test();
 146
 147     print {*x{IO}} "ok $test\n";
 148     ++$test;
 149
 150     my $warn;
 151     local $SIG{__WARN__} = sub {
 152         $warn .= $_[0];
 153     };
 154     my $val = *x{FILEHANDLE};
 155     print {*x{IO}} ($warn =~ /is deprecated/
 156                     ? "ok $test\n" : "not ok $test\n");
 157     curr_test(++$test);
 158 }
 159
 160
 161 {
 162     # test if defined() doesn't create any new symbols
 163
 164     my $a = "SYM000";
 165     ok(!defined *{$a});
 166
 167     ok(!defined @{$a});
 168     ok(!defined *{$a});
 169
 170     {
 171         no warnings 'deprecated';
 172         ok(!defined %{$a});
 173     }
 174     ok(!defined *{$a});
 175
 176     ok(!defined ${$a});
 177     ok(!defined *{$a});
 178
 179     ok(!defined &{$a});
 180     ok(!defined *{$a});
 181
 182     my $state = "not";
 183     *{$a} = sub { $state = "ok" };
 184     ok(defined &{$a});
 185     ok(defined *{$a});
 186     &{$a};
 187     is ($state, 'ok');
 188 }
 189
 190 {
 191     # although it *should* if you're talking about magicals
 192
 193     my $a = "]";
 194     ok(defined ${$a});
 195     ok(defined *{$a});
 196
 197     $a = "1";
 198     "o" =~ /(o)/;
 199     ok(${$a});
 200     ok(defined *{$a});
 201     $a = "2";
 202     ok(!${$a});
 203     ok(defined *{$a});
 204     $a = "1x";
 205     ok(!defined ${$a});
 206     ok(!defined *{$a});
 207     $a = "11";
 208     "o" =~ /(((((((((((o)))))))))))/;
 209     ok(${$a});
 210     ok(defined *{$a});
 211 }
 212
 213 # [ID 20010526.001] localized glob loses value when assigned to
 214
 215 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
 216
 217 is($j, 1);
 218 is($j{a}, 1);
 219 is($j[0], 1);
 220
 221 {
 222     # does pp_readline() handle glob-ness correctly?
 223     my $g = *foo;
 224     $g = <DATA>;
 225     is ($g, "Perl\n");
 226 }
 227
 228 {
 229     my $w = '';
 230     local $SIG{__WARN__} = sub { $w = $_[0] };
 231     sub abc1 ();
 232     local *abc1 = sub { };
 233     is ($w, '');
 234     sub abc2 ();
 235     local *abc2;
 236     *abc2 = sub { };
 237     is ($w, '');
 238     sub abc3 ();
 239     *abc3 = sub { };
 240     like ($w, qr/Prototype mismatch/);
 241 }
 242
 243 {
 244     # [17375] rcatline to formerly-defined undef was broken. Fixed in
 245     # do_readline by checking SvOK. AMS, 20020918
 246     my $x = "not ";
 247     $x  = undef;
 248     $x .= <DATA>;
 249     is ($x, "Rules\n");
 250 }
 251
 252 {
 253     # test the assignment of a GLOB to an LVALUE
 254     my $e = '';
 255     local $SIG{__DIE__} = sub { $e = $_[0] };
 256     my $v;
 257     sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
 258     f($v);
 259     is ($v, '*main::DATA');
 260     my $x = <$v>;
 261     is ($x, "perl\n");
 262 }
 263
 264 {
 265     $e = '';
 266     # GLOB assignment to tied element
 267     local $SIG{__DIE__} = sub { $e = $_[0] };
 268     sub T::TIEARRAY  { bless [] => "T" }
 269     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
 270     sub T::FETCH     { $_[0]->[ $_[1] ] }
 271     sub T::FETCHSIZE { @{$_[0]} }
 272     tie my @ary => "T";
 273     $ary[0] = *DATA;
 274     is ($ary[0], '*main::DATA');
 275     is ($e, '');
 276     my $x = readline $ary[0];
 277     is($x, "rocks\n");
 278 }
 279
 280 {
 281     # Need some sort of die or warn to get the global destruction text if the
 282     # bug is still present
 283     my $output = runperl(prog => <<'EOPROG');
 284 package M;
 285 $| = 1;
 286 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
 287 package main;
 288
 289 bless \$A::B, 'M';
 290 *A:: = \*B::;
 291 EOPROG
 292     like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
 293     unlike($output, qr/global destruction/,
 294            "unreferenced symbol tables should be cleaned up immediately");
 295 }
 296
 297 # Possibly not the correct test file for these tests.
 298 # There are certain space optimisations implemented via promotion rules to
 299 # GVs
 300
 301 foreach (qw (oonk ga_shloip)) {
 302     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
 303 }
 304
 305 # A string in place of the typeglob is promoted to the function prototype
 306 $::{oonk} = "pie";
 307 my $proto = eval 'prototype \&oonk';
 308 die if $@;
 309 is ($proto, "pie", "String is promoted to prototype");
 310
 311
 312 # A reference to a value is used to generate a constant subroutine
 313 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
 314                    \*STDIN, \&ok, \undef, *STDOUT) {
 315     delete $::{oonk};
 316     $::{oonk} = \$value;
 317     $proto = eval 'prototype \&oonk';
 318     die if $@;
 319     is ($proto, '', "Prototype for a constant subroutine is empty");
 320
 321     my $got = eval 'oonk';
 322     die if $@;
 323     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
 324     is ($got, $value, "Value is correctly set");
 325 }
 326
 327 delete $::{oonk};
 328 $::{oonk} = \"Value";
 329
 330 *{"ga_shloip"} = \&{"oonk"};
 331
 332 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
 333 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 334 is (eval 'ga_shloip', "Value", "Constant has correct value");
 335 is (ref $::{ga_shloip}, 'SCALAR',
 336     "Inlining of constant doesn't change represenatation");
 337
 338 delete $::{ga_shloip};
 339
 340 eval 'sub ga_shloip (); 1' or die $@;
 341 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
 342
 343 # Check that a prototype expands.
 344 *{"ga_shloip"} = \&{"oonk"};
 345
 346 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 347 is (eval 'ga_shloip', "Value", "Constant has correct value");
 348 is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
 349
 350
 351 @::zwot = ('Zwot!');
 352
 353 # Check that assignment to an existing typeglob works
 354 {
 355   my $w = '';
 356   local $SIG{__WARN__} = sub { $w = $_[0] };
 357   *{"zwot"} = \&{"oonk"};
 358   is($w, '', "Should be no warning");
 359 }
 360
 361 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 362 is (eval 'zwot', "Value", "Constant has correct value");
 363 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
 364 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
 365
 366 sub spritsits () {
 367     "Traditional";
 368 }
 369
 370 # Check that assignment to an existing subroutine works
 371 {
 372   my $w = '';
 373   local $SIG{__WARN__} = sub { $w = $_[0] };
 374   *{"spritsits"} = \&{"oonk"};
 375   like($w, qr/^Constant subroutine main::spritsits redefined/,
 376        "Redefining a constant sub should warn");
 377 }
 378
 379 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 380 is (eval 'spritsits', "Value", "Constant has correct value");
 381 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
 382
 383 # Check that assignment to an existing typeglob works
 384 {
 385   my $w = '';
 386   local $SIG{__WARN__} = sub { $w = $_[0] };
 387   *{"plunk"} = [];
 388   *{"plunk"} = \&{"oonk"};
 389   is($w, '', "Should be no warning");
 390 }
 391
 392 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 393 is (eval 'plunk', "Value", "Constant has correct value");
 394 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 395
 396 my $gr = eval '\*plunk' or die;
 397
 398 {
 399   my $w = '';
 400   local $SIG{__WARN__} = sub { $w = $_[0] };
 401   *{$gr} = \&{"oonk"};
 402   is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)");
 403 }
 404
 405 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 406 is (eval 'plunk', "Value", "Constant has correct value");
 407 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 408
 409 # Non-void context should defeat the optimisation, and will cause the original
 410 # to be promoted (what change 26482 intended)
 411 my $result;
 412 {
 413   my $w = '';
 414   local $SIG{__WARN__} = sub { $w = $_[0] };
 415   $result = *{"awkkkkkk"} = \&{"oonk"};
 416   is($w, '', "Should be no warning");
 417 }
 418
 419 is (ref \$result, 'GLOB',
 420     "Non void assignment should still return a typeglob");
 421
 422 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
 423 is (eval 'plunk', "Value", "Constant has correct value");
 424 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 425
 426 delete $::{oonk};
 427 $::{oonk} = \"Value";
 428
 429 sub non_dangling {
 430   my $w = '';
 431   local $SIG{__WARN__} = sub { $w = $_[0] };
 432   *{"zap"} = \&{"oonk"};
 433   is($w, '', "Should be no warning");
 434 }
 435
 436 non_dangling();
 437 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 438 is (eval 'zap', "Value", "Constant has correct value");
 439 is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
 440
 441 sub dangling {
 442   local $SIG{__WARN__} = sub { die $_[0] };
 443   *{"biff"} = \&{"oonk"};
 444 }
 445
 446 dangling();
 447 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
 448 is (eval 'biff', "Value", "Constant has correct value");
 449 is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
 450
 451 {
 452     use vars qw($glook $smek $foof);
 453     # Check reference assignment isn't affected by the SV type (bug #38439)
 454     $glook = 3;
 455     $smek = 4;
 456     $foof = "halt and cool down";
 457
 458     my $rv = \*smek;
 459     is($glook, 3);
 460     *glook = $rv;
 461     is($glook, 4);
 462
 463     my $pv = "";
 464     $pv = \*smek;
 465     is($foof, "halt and cool down");
 466     *foof = $pv;
 467     is($foof, 4);
 468 }
 469
 470 format =
 471 .
 472
 473 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
 474     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
 475     # IO::Handle, which isn't what we want.
 476     my $type = $value;
 477     $type =~ s/.*=//;
 478     $type =~ s/\(.*//;
 479     delete $::{oonk};
 480     $::{oonk} = $value;
 481     $proto = eval 'prototype \&oonk';
 482     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
 483           "Cannot upgrade ref-to-$type to typeglob");
 484 }
 485
 486 {
 487     no warnings qw(once uninitialized);
 488     my $g = \*clatter;
 489     my $r = eval {no strict; ${*{$g}{SCALAR}}};
 490     is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
 491
 492     $g = \*vowm;
 493     $r = eval {use strict; ${*{$g}{SCALAR}}};
 494     is ($@, '',
 495         "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
 496 }
 497
 498 {
 499     # Bug reported by broquaint on IRC
 500     *slosh::{HASH}->{ISA}=[];
 501     slosh->import;
 502     pass("gv_fetchmeth coped with the unexpected");
 503
 504     # An audit found these:
 505     {
 506         package slosh;
 507         sub rip {
 508             my $s = shift;
 509             $s->SUPER::rip;
 510         }
 511     }
 512     eval {slosh->rip;};
 513     like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
 514
 515     is(slosh->isa('swoosh'), '');
 516
 517     $CORE::GLOBAL::{"lock"}=[];
 518     eval "no warnings; lock";
 519     like($@, qr/^Not enough arguments for lock/,
 520        "Can't trip up general keyword overloading");
 521
 522     $CORE::GLOBAL::{"readline"}=[];
 523     eval "<STDOUT> if 0";
 524     is($@, '', "Can't trip up readline overloading");
 525
 526     $CORE::GLOBAL::{"readpipe"}=[];
 527     eval "`` if 0";
 528     is($@, '', "Can't trip up readpipe overloading");
 529 }
 530
 531 {
 532     die if exists $::{BONK};
 533     $::{BONK} = \"powie";
 534     *{"BONK"} = \&{"BONK"};
 535     eval 'is(BONK(), "powie",
 536              "Assigment works when glob created midway (bug 45607)"); 1'
 537         or die $@;
 538 }
 539
 540 # For now these tests are here, but they would probably be better in a file for
 541 # tests for croaks. (And in turn, that probably deserves to be in a different
 542 # directory. Gerard Goossen has a point about the layout being unclear
 543
 544 sub coerce_integer {
 545     no warnings 'numeric';
 546     $_[0] |= 0;
 547 }
 548 sub coerce_number {
 549     no warnings 'numeric';
 550     $_[0] += 0;
 551 }
 552 sub coerce_string {
 553     $_[0] .= '';
 554 }
 555
 556 foreach my $type (qw(integer number string)) {
 557     my $prog = "coerce_$type(*STDERR)";
 558     is (scalar eval "$prog; 1", undef, "$prog failed...");
 559     like ($@, qr/Can't coerce GLOB to $type in/,
 560           "with the correct error message");
 561 }
 562
 563 __END__
 564 Perl
 565 Rules
 566 perl
 567 rocks