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     ok(!defined %{$a});
 171     ok(!defined *{$a});
 172
 173     ok(!defined ${$a});
 174     ok(!defined *{$a});
 175
 176     ok(!defined &{$a});
 177     ok(!defined *{$a});
 178
 179     my $state = "not";
 180     *{$a} = sub { $state = "ok" };
 181     ok(defined &{$a});
 182     ok(defined *{$a});
 183     &{$a};
 184     is ($state, 'ok');
 185 }
 186
 187 {
 188     # although it *should* if you're talking about magicals
 189
 190     my $a = "]";
 191     ok(defined ${$a});
 192     ok(defined *{$a});
 193
 194     $a = "1";
 195     "o" =~ /(o)/;
 196     ok(${$a});
 197     ok(defined *{$a});
 198     $a = "2";
 199     ok(!${$a});
 200     ok(defined *{$a});
 201     $a = "1x";
 202     ok(!defined ${$a});
 203     ok(!defined *{$a});
 204     $a = "11";
 205     "o" =~ /(((((((((((o)))))))))))/;
 206     ok(${$a});
 207     ok(defined *{$a});
 208 }
 209
 210 # [ID 20010526.001] localized glob loses value when assigned to
 211
 212 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
 213
 214 is($j, 1);
 215 is($j{a}, 1);
 216 is($j[0], 1);
 217
 218 {
 219     # does pp_readline() handle glob-ness correctly?
 220     my $g = *foo;
 221     $g = <DATA>;
 222     is ($g, "Perl\n");
 223 }
 224
 225 {
 226     my $w = '';
 227     local $SIG{__WARN__} = sub { $w = $_[0] };
 228     sub abc1 ();
 229     local *abc1 = sub { };
 230     is ($w, '');
 231     sub abc2 ();
 232     local *abc2;
 233     *abc2 = sub { };
 234     is ($w, '');
 235     sub abc3 ();
 236     *abc3 = sub { };
 237     like ($w, qr/Prototype mismatch/);
 238 }
 239
 240 {
 241     # [17375] rcatline to formerly-defined undef was broken. Fixed in
 242     # do_readline by checking SvOK. AMS, 20020918
 243     my $x = "not ";
 244     $x  = undef;
 245     $x .= <DATA>;
 246     is ($x, "Rules\n");
 247 }
 248
 249 {
 250     # test the assignment of a GLOB to an LVALUE
 251     my $e = '';
 252     local $SIG{__DIE__} = sub { $e = $_[0] };
 253     my $v;
 254     sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
 255     f($v);
 256     is ($v, '*main::DATA');
 257     my $x = <$v>;
 258     is ($x, "perl\n");
 259 }
 260
 261 {
 262     $e = '';
 263     # GLOB assignment to tied element
 264     local $SIG{__DIE__} = sub { $e = $_[0] };
 265     sub T::TIEARRAY  { bless [] => "T" }
 266     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
 267     sub T::FETCH     { $_[0]->[ $_[1] ] }
 268     sub T::FETCHSIZE { @{$_[0]} }
 269     tie my @ary => "T";
 270     $ary[0] = *DATA;
 271     is ($ary[0], '*main::DATA');
 272     is ($e, '');
 273     my $x = readline $ary[0];
 274     is($x, "rocks\n");
 275 }
 276
 277 {
 278     # Need some sort of die or warn to get the global destruction text if the
 279     # bug is still present
 280     my $output = runperl(prog => <<'EOPROG');
 281 package M;
 282 $| = 1;
 283 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
 284 package main;
 285
 286 bless \$A::B, 'M';
 287 *A:: = \*B::;
 288 EOPROG
 289     like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
 290     unlike($output, qr/global destruction/,
 291            "unreferenced symbol tables should be cleaned up immediately");
 292 }
 293
 294 # Possibly not the correct test file for these tests.
 295 # There are certain space optimisations implemented via promotion rules to
 296 # GVs
 297
 298 foreach (qw (oonk ga_shloip)) {
 299     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
 300 }
 301
 302 # A string in place of the typeglob is promoted to the function prototype
 303 $::{oonk} = "pie";
 304 my $proto = eval 'prototype \&oonk';
 305 die if $@;
 306 is ($proto, "pie", "String is promoted to prototype");
 307
 308
 309 # A reference to a value is used to generate a constant subroutine
 310 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
 311                    \*STDIN, \&ok, \undef, *STDOUT) {
 312     delete $::{oonk};
 313     $::{oonk} = \$value;
 314     $proto = eval 'prototype \&oonk';
 315     die if $@;
 316     is ($proto, '', "Prototype for a constant subroutine is empty");
 317
 318     my $got = eval 'oonk';
 319     die if $@;
 320     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
 321     is ($got, $value, "Value is correctly set");
 322 }
 323
 324 delete $::{oonk};
 325 $::{oonk} = \"Value";
 326
 327 *{"ga_shloip"} = \&{"oonk"};
 328
 329 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
 330 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 331 is (eval 'ga_shloip', "Value", "Constant has correct value");
 332 is (ref $::{ga_shloip}, 'SCALAR',
 333     "Inlining of constant doesn't change represenatation");
 334
 335 delete $::{ga_shloip};
 336
 337 eval 'sub ga_shloip (); 1' or die $@;
 338 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
 339
 340 # Check that a prototype expands.
 341 *{"ga_shloip"} = \&{"oonk"};
 342
 343 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 344 is (eval 'ga_shloip', "Value", "Constant has correct value");
 345 is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
 346
 347
 348 @::zwot = ('Zwot!');
 349
 350 # Check that assignment to an existing typeglob works
 351 {
 352   my $w = '';
 353   local $SIG{__WARN__} = sub { $w = $_[0] };
 354   *{"zwot"} = \&{"oonk"};
 355   is($w, '', "Should be no warning");
 356 }
 357
 358 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 359 is (eval 'zwot', "Value", "Constant has correct value");
 360 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
 361 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
 362
 363 sub spritsits () {
 364     "Traditional";
 365 }
 366
 367 # Check that assignment to an existing subroutine works
 368 {
 369   my $w = '';
 370   local $SIG{__WARN__} = sub { $w = $_[0] };
 371   *{"spritsits"} = \&{"oonk"};
 372   like($w, qr/^Constant subroutine main::spritsits redefined/,
 373        "Redefining a constant sub should warn");
 374 }
 375
 376 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 377 is (eval 'spritsits', "Value", "Constant has correct value");
 378 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
 379
 380 # Check that assignment to an existing typeglob works
 381 {
 382   my $w = '';
 383   local $SIG{__WARN__} = sub { $w = $_[0] };
 384   *{"plunk"} = [];
 385   *{"plunk"} = \&{"oonk"};
 386   is($w, '', "Should be no warning");
 387 }
 388
 389 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 390 is (eval 'plunk', "Value", "Constant has correct value");
 391 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 392
 393 my $gr = eval '\*plunk' or die;
 394
 395 {
 396   my $w = '';
 397   local $SIG{__WARN__} = sub { $w = $_[0] };
 398   *{$gr} = \&{"oonk"};
 399   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)");
 400 }
 401
 402 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 403 is (eval 'plunk', "Value", "Constant has correct value");
 404 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 405
 406 # Non-void context should defeat the optimisation, and will cause the original
 407 # to be promoted (what change 26482 intended)
 408 my $result;
 409 {
 410   my $w = '';
 411   local $SIG{__WARN__} = sub { $w = $_[0] };
 412   $result = *{"awkkkkkk"} = \&{"oonk"};
 413   is($w, '', "Should be no warning");
 414 }
 415
 416 is (ref \$result, 'GLOB',
 417     "Non void assignment should still return a typeglob");
 418
 419 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
 420 is (eval 'plunk', "Value", "Constant has correct value");
 421 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 422
 423 delete $::{oonk};
 424 $::{oonk} = \"Value";
 425
 426 sub non_dangling {
 427   my $w = '';
 428   local $SIG{__WARN__} = sub { $w = $_[0] };
 429   *{"zap"} = \&{"oonk"};
 430   is($w, '', "Should be no warning");
 431 }
 432
 433 non_dangling();
 434 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 435 is (eval 'zap', "Value", "Constant has correct value");
 436 is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
 437
 438 sub dangling {
 439   local $SIG{__WARN__} = sub { die $_[0] };
 440   *{"biff"} = \&{"oonk"};
 441 }
 442
 443 dangling();
 444 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
 445 is (eval 'biff', "Value", "Constant has correct value");
 446 is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
 447
 448 {
 449     use vars qw($glook $smek $foof);
 450     # Check reference assignment isn't affected by the SV type (bug #38439)
 451     $glook = 3;
 452     $smek = 4;
 453     $foof = "halt and cool down";
 454
 455     my $rv = \*smek;
 456     is($glook, 3);
 457     *glook = $rv;
 458     is($glook, 4);
 459
 460     my $pv = "";
 461     $pv = \*smek;
 462     is($foof, "halt and cool down");
 463     *foof = $pv;
 464     is($foof, 4);
 465 }
 466
 467 format =
 468 .
 469
 470 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
 471     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
 472     # IO::Handle, which isn't what we want.
 473     my $type = $value;
 474     $type =~ s/.*=//;
 475     $type =~ s/\(.*//;
 476     delete $::{oonk};
 477     $::{oonk} = $value;
 478     $proto = eval 'prototype \&oonk';
 479     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
 480           "Cannot upgrade ref-to-$type to typeglob");
 481 }
 482
 483 {
 484     no warnings qw(once uninitialized);
 485     my $g = \*clatter;
 486     my $r = eval {no strict; ${*{$g}{SCALAR}}};
 487     is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
 488
 489     $g = \*vowm;
 490     $r = eval {use strict; ${*{$g}{SCALAR}}};
 491     is ($@, '',
 492         "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
 493 }
 494
 495 {
 496     # Bug reported by broquaint on IRC
 497     *slosh::{HASH}->{ISA}=[];
 498     slosh->import;
 499     pass("gv_fetchmeth coped with the unexpected");
 500
 501     # An audit found these:
 502     {
 503         package slosh;
 504         sub rip {
 505             my $s = shift;
 506             $s->SUPER::rip;
 507         }
 508     }
 509     eval {slosh->rip;};
 510     like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
 511
 512     is(slosh->isa('swoosh'), '');
 513
 514     $CORE::GLOBAL::{"lock"}=[];
 515     eval "no warnings; lock";
 516     like($@, qr/^Not enough arguments for lock/,
 517        "Can't trip up general keyword overloading");
 518
 519     $CORE::GLOBAL::{"readline"}=[];
 520     eval "<STDOUT> if 0";
 521     is($@, '', "Can't trip up readline overloading");
 522
 523     $CORE::GLOBAL::{"readpipe"}=[];
 524     eval "`` if 0";
 525     is($@, '', "Can't trip up readpipe overloading");
 526 }
 527
 528 {
 529     die if exists $::{BONK};
 530     $::{BONK} = \"powie";
 531     *{"BONK"} = \&{"BONK"};
 532     eval 'is(BONK(), "powie",
 533              "Assigment works when glob created midway (bug 45607)"); 1'
 534         or die $@;
 535 }
 536
 537 # For now these tests are here, but they would probably be better in a file for
 538 # tests for croaks. (And in turn, that probably deserves to be in a different
 539 # directory. Gerard Goossen has a point about the layout being unclear
 540
 541 sub coerce_integer {
 542     no warnings 'numeric';
 543     $_[0] |= 0;
 544 }
 545 sub coerce_number {
 546     no warnings 'numeric';
 547     $_[0] += 0;
 548 }
 549 sub coerce_string {
 550     $_[0] .= '';
 551 }
 552
 553 foreach my $type (qw(integer number string)) {
 554     my $prog = "coerce_$type(*STDERR)";
 555     is (scalar eval "$prog; 1", undef, "$prog failed...");
 556     like ($@, qr/Can't coerce GLOB to $type in/,
 557           "with the correct error message");
 558 }
 559
 560 __END__
 561 Perl
 562 Rules
 563 perl
 564 rocks