4 # various typeglob tests
17 # type coersion on assignment
21 is(ref(\$bar), 'SCALAR');
24 # type coersion (not) on misc ops
27 is(ref(\$foo), 'GLOB');
29 unlike ($foo, qr/abcd/);
30 is(ref(\$foo), 'GLOB');
32 is($foo, '*main::bar');
33 is(ref(\$foo), 'GLOB');
35 # type coersion on substitutions that match
44 # typeglobs as lvalues
45 substr($foo, 0, 1) = "XXX";
46 is(ref(\$foo), 'SCALAR');
47 is($foo, 'XXXmain::bar');
49 # returning glob values
51 local($bar) = *main::foo;
58 is(ref(\$fuu), 'GLOB');
62 is(ref(\$baa), 'GLOB');
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.
69 { package Foo::Bar; no warnings 'once'; $test=1; }
70 ok(exists $Foo::{'Bar::'});
71 is($Foo::{'Bar::'}, '*Foo::Bar::');
74 # test undef operator clearing out entire glob
76 @foo = qw(more stuff);
77 %foo = qw(even more random stuff);
84 # test warnings from assignment of undef to glob
86 local $SIG{__WARN__} = sub { $msg = $_[0] };
91 like($msg, qr/Undefined value assigned to typeglob/);
94 my $test = curr_test();
95 # test *glob{THING} syntax
100 %x = ("ok $test" => "\n");
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
108 XXX This text isn't used. Should it be?
112 is (ref *x{FORMAT}, "FORMAT");
114 is (*{*x{GLOB}}, "*main::STDOUT");
117 my $test = curr_test();
119 print {*x{IO}} "ok $test\n";
123 local $SIG{__WARN__} = sub {
126 my $val = *x{FILEHANDLE};
127 print {*x{IO}} ($warn =~ /is deprecated/
128 ? "ok $test\n" : "not ok $test\n");
134 # test if defined() doesn't create any new symbols
152 *{$a} = sub { $state = "ok" };
160 # although it *should* if you're talking about magicals
177 "o" =~ /(((((((((((o)))))))))))/;
182 # [ID 20010526.001] localized glob loses value when assigned to
184 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
191 # does pp_readline() handle glob-ness correctly?
199 local $SIG{__WARN__} = sub { $w = $_[0] };
201 local *abc1 = sub { };
209 like ($w, qr/Prototype mismatch/);
213 # [17375] rcatline to formerly-defined undef was broken. Fixed in
214 # do_readline by checking SvOK. AMS, 20020918
222 # test the assignment of a GLOB to an LVALUE
224 local $SIG{__DIE__} = sub { $e = $_[0] };
226 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
228 is ($v, '*main::DATA');
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]} }
243 is ($ary[0], '*main::DATA');
245 my $x = readline $ary[0];
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');
255 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
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");
266 # Possibly not the correct test file for these tests.
267 # There are certain space optimisations implemented via promotion rules to
270 foreach (qw (oonk ga_shloip)) {
271 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
274 # A string in place of the typeglob is promoted to the function prototype
276 my $proto = eval 'prototype \&oonk';
278 is ($proto, "pie", "String is promoted to prototype");
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) {
286 $proto = eval 'prototype \&oonk';
288 is ($proto, '', "Prototype for a constant subroutine is empty");
290 my $got = eval 'oonk';
292 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
293 is ($got, $value, "Value is correctly set");
297 $::{oonk} = \"Value";
299 *{"ga_shloip"} = \&{"oonk"};
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");
307 delete $::{ga_shloip};
309 eval 'sub ga_shloip (); 1' or die $@;
310 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
312 # Check that a prototype expands.
313 *{"ga_shloip"} = \&{"oonk"};
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");
322 # Check that assignment to an existing typeglob works
325 local $SIG{__WARN__} = sub { $w = $_[0] };
326 *{"zwot"} = \&{"oonk"};
327 is($w, '', "Should be no warning");
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");
339 # Check that assignment to an existing subroutine works
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");
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");
353 # Check that assignment to an existing typeglob works
356 local $SIG{__WARN__} = sub { $w = $_[0] };
357 $result = *{"plunk"} = \&{"oonk"};
358 is($w, '', "Should be no warning");
361 is (ref \$result, 'GLOB',
362 "Non void assignment should still return a typeglob");
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");
368 my $gr = eval '\*plunk' or die;
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");
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");
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.
393 $proto = eval 'prototype \&oonk';
394 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
395 "Cannot upgrade ref-to-$type to typeglob");