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 => 132 );
  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
  94 my $test = curr_test();
  95 # test *glob{THING} syntax
  96 $x = "ok $test\n";
  97 ++$test;
  98 @x = ("ok $test\n");
  99 ++$test;
 100 %x = ("ok $test" => "\n");
 101 ++$test;
 102 sub x { "ok $test\n" }
 103 print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
 104 # This needs to go here, after the print, as sub x will return the current
 105 # value of test
 106 ++$test;
 107 format x =
 108 XXX This text isn't used. Should it be?
 109 .
 110 curr_test($test);
 111
 112 is (ref *x{FORMAT}, "FORMAT");
 113 *x = *STDOUT;
 114 is (*{*x{GLOB}}, "*main::STDOUT");
 115
 116 {
 117     my $test = curr_test();
 118
 119     print {*x{IO}} "ok $test\n";
 120     ++$test;
 121
 122     my $warn;
 123     local $SIG{__WARN__} = sub {
 124         $warn .= $_[0];
 125     };
 126     my $val = *x{FILEHANDLE};
 127     print {*x{IO}} ($warn =~ /is deprecated/
 128                     ? "ok $test\n" : "not ok $test\n");
 129     curr_test(++$test);
 130 }
 131
 132
 133 {
 134     # test if defined() doesn't create any new symbols
 135
 136     my $a = "SYM000";
 137     ok(!defined *{$a});
 138
 139     ok(!defined @{$a});
 140     ok(!defined *{$a});
 141
 142     ok(!defined %{$a});
 143     ok(!defined *{$a});
 144
 145     ok(!defined ${$a});
 146     ok(!defined *{$a});
 147
 148     ok(!defined &{$a});
 149     ok(!defined *{$a});
 150
 151     my $state = "not";
 152     *{$a} = sub { $state = "ok" };
 153     ok(defined &{$a});
 154     ok(defined *{$a});
 155     &{$a};
 156     is ($state, 'ok');
 157 }
 158
 159 {
 160     # although it *should* if you're talking about magicals
 161
 162     my $a = "]";
 163     ok(defined ${$a});
 164     ok(defined *{$a});
 165
 166     $a = "1";
 167     "o" =~ /(o)/;
 168     ok(${$a});
 169     ok(defined *{$a});
 170     $a = "2";
 171     ok(!${$a});
 172     ok(defined *{$a});
 173     $a = "1x";
 174     ok(!defined ${$a});
 175     ok(!defined *{$a});
 176     $a = "11";
 177     "o" =~ /(((((((((((o)))))))))))/;
 178     ok(${$a});
 179     ok(defined *{$a});
 180 }
 181
 182 # [ID 20010526.001] localized glob loses value when assigned to
 183
 184 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
 185
 186 is($j, 1);
 187 is($j{a}, 1);
 188 is($j[0], 1);
 189
 190 {
 191     # does pp_readline() handle glob-ness correctly?
 192     my $g = *foo;
 193     $g = <DATA>;
 194     is ($g, "Perl\n");
 195 }
 196
 197 {
 198     my $w = '';
 199     local $SIG{__WARN__} = sub { $w = $_[0] };
 200     sub abc1 ();
 201     local *abc1 = sub { };
 202     is ($w, '');
 203     sub abc2 ();
 204     local *abc2;
 205     *abc2 = sub { };
 206     is ($w, '');
 207     sub abc3 ();
 208     *abc3 = sub { };
 209     like ($w, qr/Prototype mismatch/);
 210 }
 211
 212 {
 213     # [17375] rcatline to formerly-defined undef was broken. Fixed in
 214     # do_readline by checking SvOK. AMS, 20020918
 215     my $x = "not ";
 216     $x  = undef;
 217     $x .= <DATA>;
 218     is ($x, "Rules\n");
 219 }
 220
 221 {
 222     # test the assignment of a GLOB to an LVALUE
 223     my $e = '';
 224     local $SIG{__DIE__} = sub { $e = $_[0] };
 225     my $v;
 226     sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
 227     f($v);
 228     is ($v, '*main::DATA');
 229     my $x = <$v>;
 230     is ($x, "perl\n");
 231 }
 232
 233 {
 234     $e = '';
 235     # GLOB assignment to tied element
 236     local $SIG{__DIE__} = sub { $e = $_[0] };
 237     sub T::TIEARRAY  { bless [] => "T" }
 238     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
 239     sub T::FETCH     { $_[0]->[ $_[1] ] }
 240     sub T::FETCHSIZE { @{$_[0]} }
 241     tie my @ary => "T";
 242     $ary[0] = *DATA;
 243     is ($ary[0], '*main::DATA');
 244     is ($e, '');
 245     my $x = readline $ary[0];
 246     is($x, "rocks\n");
 247 }
 248
 249 {
 250     # Need some sort of die or warn to get the global destruction text if the
 251     # bug is still present
 252     my $output = runperl(prog => <<'EOPROG');
 253 package M;
 254 $| = 1;
 255 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
 256 package main;
 257
 258 bless \$A::B, 'M';
 259 *A:: = \*B::;
 260 EOPROG
 261     like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
 262     unlike($output, qr/global destruction/,
 263            "unreferenced symbol tables should be cleaned up immediately");
 264 }
 265
 266 # Possibly not the correct test file for these tests.
 267 # There are certain space optimisations implemented via promotion rules to
 268 # GVs
 269
 270 foreach (qw (oonk ga_shloip)) {
 271     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
 272 }
 273
 274 # A string in place of the typeglob is promoted to the function prototype
 275 $::{oonk} = "pie";
 276 my $proto = eval 'prototype \&oonk';
 277 die if $@;
 278 is ($proto, "pie", "String is promoted to prototype");
 279
 280
 281 # A reference to a value is used to generate a constant subroutine
 282 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
 283                    \*STDIN, \&ok, \undef, *STDOUT) {
 284     delete $::{oonk};
 285     $::{oonk} = \$value;
 286     $proto = eval 'prototype \&oonk';
 287     die if $@;
 288     is ($proto, '', "Prototype for a constant subroutine is empty");
 289
 290     my $got = eval 'oonk';
 291     die if $@;
 292     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
 293     is ($got, $value, "Value is correctly set");
 294 }
 295
 296 delete $::{oonk};
 297 $::{oonk} = \"Value";
 298
 299 *{"ga_shloip"} = \&{"oonk"};
 300
 301 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
 302 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 303 is (eval 'ga_shloip', "Value", "Constant has correct value");
 304 is (ref $::{ga_shloip}, 'SCALAR',
 305     "Inlining of constant doesn't change represenatation");
 306
 307 delete $::{ga_shloip};
 308
 309 eval 'sub ga_shloip (); 1' or die $@;
 310 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
 311
 312 # Check that a prototype expands.
 313 *{"ga_shloip"} = \&{"oonk"};
 314
 315 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 316 is (eval 'ga_shloip', "Value", "Constant has correct value");
 317 is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
 318
 319
 320 @::zwot = ('Zwot!');
 321
 322 # Check that assignment to an existing typeglob works
 323 {
 324   my $w = '';
 325   local $SIG{__WARN__} = sub { $w = $_[0] };
 326   *{"zwot"} = \&{"oonk"};
 327   is($w, '', "Should be no warning");
 328 }
 329
 330 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 331 is (eval 'zwot', "Value", "Constant has correct value");
 332 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
 333 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
 334
 335 sub spritsits () {
 336     "Traditional";
 337 }
 338
 339 # Check that assignment to an existing subroutine works
 340 {
 341   my $w = '';
 342   local $SIG{__WARN__} = sub { $w = $_[0] };
 343   *{"spritsits"} = \&{"oonk"};
 344   like($w, qr/^Constant subroutine main::spritsits redefined/,
 345        "Redefining a constant sub should warn");
 346 }
 347
 348 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 349 is (eval 'spritsits', "Value", "Constant has correct value");
 350 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
 351
 352 my $result;
 353 # Check that assignment to an existing typeglob works
 354 {
 355   my $w = '';
 356   local $SIG{__WARN__} = sub { $w = $_[0] };
 357   $result = *{"plunk"} = \&{"oonk"};
 358   is($w, '', "Should be no warning");
 359 }
 360
 361 is (ref \$result, 'GLOB',
 362     "Non void assignment should still return a typeglob");
 363
 364 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 365 is (eval 'plunk', "Value", "Constant has correct value");
 366 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 367
 368 my $gr = eval '\*plunk' or die;
 369
 370 {
 371   my $w = '';
 372   local $SIG{__WARN__} = sub { $w = $_[0] };
 373   $result = *{$gr} = \&{"oonk"};
 374   like($w, qr/^Constant subroutine main::plunk redefined/,
 375        "Redefining a constant sub should warn");
 376 }
 377
 378 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
 379 is (eval 'plunk', "Value", "Constant has correct value");
 380 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
 381
 382 format =
 383 .
 384
 385 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
 386     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
 387     # IO::Handle, which isn't what we want.
 388     my $type = $value;
 389     $type =~ s/.*=//;
 390     $type =~ s/\(.*//;
 391     delete $::{oonk};
 392     $::{oonk} = $value;
 393     $proto = eval 'prototype \&oonk';
 394     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
 395           "Cannot upgrade ref-to-$type to typeglob");
 396 }
 397 __END__
 398 Perl
 399 Rules
 400 perl
 401 rocks