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 => 160 );
  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 my $result;
 381 # Check that assignment to an existing typeglob works
 382 {
 383   my $w = '';
 384   local $SIG{__WARN__} = sub { $w = $_[0] };
 385   $result = *{"plunk"} = \&{"oonk"};
 386   is($w, '', "Should be no warning");
 387 }
 388
 389 is (ref \$result, 'GLOB',
 390     "Non void assignment should still return a typeglob");
 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   $result = *{$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 {
 410     use vars qw($glook $smek $foof);
 411     # Check reference assignment isn't affected by the SV type (bug #38439)
 412     $glook = 3;
 413     $smek = 4;
 414     $foof = "halt and cool down";
 415
 416     my $rv = \*smek;
 417     is($glook, 3);
 418     *glook = $rv;
 419     is($glook, 4);
 420
 421     my $pv = "";
 422     $pv = \*smek;
 423     is($foof, "halt and cool down");
 424     *foof = $pv;
 425     is($foof, 4);
 426 }
 427
 428 format =
 429 .
 430
 431 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
 432     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
 433     # IO::Handle, which isn't what we want.
 434     my $type = $value;
 435     $type =~ s/.*=//;
 436     $type =~ s/\(.*//;
 437     delete $::{oonk};
 438     $::{oonk} = $value;
 439     $proto = eval 'prototype \&oonk';
 440     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
 441           "Cannot upgrade ref-to-$type to typeglob");
 442 }
 443
 444 {
 445     no warnings qw(once uninitialized);
 446     my $g = \*clatter;
 447     my $r = eval {no strict; ${*{$g}{SCALAR}}};
 448     is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
 449
 450     $g = \*vowm;
 451     $r = eval {use strict; ${*{$g}{SCALAR}}};
 452     is ($@, '',
 453         "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
 454 }
 455
 456 {
 457     # Bug reported by broquaint on IRC
 458     *slosh::{HASH}->{ISA}=[];
 459     slosh->import;
 460     pass("gv_fetchmeth coped with the unexpected");
 461
 462     # An audit found these:
 463     {
 464         package slosh;
 465         sub rip {
 466             my $s = shift;
 467             $s->SUPER::rip;
 468         }
 469     }
 470     eval {slosh->rip;};
 471     like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
 472
 473     is(slosh->isa('swoosh'), '');
 474
 475     $CORE::GLOBAL::{"lock"}=[];
 476     eval "no warnings; lock";
 477     like($@, qr/^Not enough arguments for lock/,
 478        "Can't trip up general keyword overloading");
 479
 480     $CORE::GLOBAL::{"readline"}=[];
 481     eval "<STDOUT> if 0";
 482     is($@, '', "Can't trip up readline overloading");
 483
 484     $CORE::GLOBAL::{"readpipe"}=[];
 485     eval "`` if 0";
 486     is($@, '', "Can't trip up readpipe overloading");
 487 }
 488 __END__
 489 Perl
 490 Rules
 491 perl
 492 rocks