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 => 68 );
  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     $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 __END__
 266 Perl
 267 Rules
 268 perl
 269 rocks