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 # test warnings for converting globs to other forms
96 foreach ($copy, *SKREEE) {
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");
104 $victim = sprintf "%u", $_;
105 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
106 "Warning on conversion to UV");
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");
116 $victim = sprintf "%s", $_;
117 is($msg, '', "No warning on stringification");
118 is($victim, '' . $_);
122 my $test = curr_test();
123 # test *glob{THING} syntax
128 %x = ("ok $test" => "\n");
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
136 XXX This text isn't used. Should it be?
140 is (ref *x{FORMAT}, "FORMAT");
142 is (*{*x{GLOB}}, "*main::STDOUT");
145 my $test = curr_test();
147 print {*x{IO}} "ok $test\n";
151 local $SIG{__WARN__} = sub {
154 my $val = *x{FILEHANDLE};
155 print {*x{IO}} ($warn =~ /is deprecated/
156 ? "ok $test\n" : "not ok $test\n");
162 # test if defined() doesn't create any new symbols
180 *{$a} = sub { $state = "ok" };
188 # although it *should* if you're talking about magicals
205 "o" =~ /(((((((((((o)))))))))))/;
210 # [ID 20010526.001] localized glob loses value when assigned to
212 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
219 # does pp_readline() handle glob-ness correctly?
227 local $SIG{__WARN__} = sub { $w = $_[0] };
229 local *abc1 = sub { };
237 like ($w, qr/Prototype mismatch/);
241 # [17375] rcatline to formerly-defined undef was broken. Fixed in
242 # do_readline by checking SvOK. AMS, 20020918
250 # test the assignment of a GLOB to an LVALUE
252 local $SIG{__DIE__} = sub { $e = $_[0] };
254 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
256 is ($v, '*main::DATA');
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]} }
271 is ($ary[0], '*main::DATA');
273 my $x = readline $ary[0];
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');
283 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
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");
294 # Possibly not the correct test file for these tests.
295 # There are certain space optimisations implemented via promotion rules to
298 foreach (qw (oonk ga_shloip)) {
299 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
302 # A string in place of the typeglob is promoted to the function prototype
304 my $proto = eval 'prototype \&oonk';
306 is ($proto, "pie", "String is promoted to prototype");
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) {
314 $proto = eval 'prototype \&oonk';
316 is ($proto, '', "Prototype for a constant subroutine is empty");
318 my $got = eval 'oonk';
320 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
321 is ($got, $value, "Value is correctly set");
325 $::{oonk} = \"Value";
327 *{"ga_shloip"} = \&{"oonk"};
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");
335 delete $::{ga_shloip};
337 eval 'sub ga_shloip (); 1' or die $@;
338 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
340 # Check that a prototype expands.
341 *{"ga_shloip"} = \&{"oonk"};
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");
350 # Check that assignment to an existing typeglob works
353 local $SIG{__WARN__} = sub { $w = $_[0] };
354 *{"zwot"} = \&{"oonk"};
355 is($w, '', "Should be no warning");
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");
367 # Check that assignment to an existing subroutine works
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");
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");
380 # Check that assignment to an existing typeglob works
383 local $SIG{__WARN__} = sub { $w = $_[0] };
385 *{"plunk"} = \&{"oonk"};
386 is($w, '', "Should be no warning");
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");
393 my $gr = eval '\*plunk' or die;
397 local $SIG{__WARN__} = sub { $w = $_[0] };
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)");
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");
406 # Non-void context should defeat the optimisation, and will cause the original
407 # to be promoted (what change 26482 intended)
411 local $SIG{__WARN__} = sub { $w = $_[0] };
412 $result = *{"awkkkkkk"} = \&{"oonk"};
413 is($w, '', "Should be no warning");
416 is (ref \$result, 'GLOB',
417 "Non void assignment should still return a typeglob");
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");
424 $::{oonk} = \"Value";
428 local $SIG{__WARN__} = sub { $w = $_[0] };
429 *{"zap"} = \&{"oonk"};
430 is($w, '', "Should be no warning");
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");
439 local $SIG{__WARN__} = sub { die $_[0] };
440 *{"biff"} = \&{"oonk"};
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");
449 use vars qw($glook $smek $foof);
450 # Check reference assignment isn't affected by the SV type (bug #38439)
453 $foof = "halt and cool down";
462 is($foof, "halt and cool down");
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.
478 $proto = eval 'prototype \&oonk';
479 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
480 "Cannot upgrade ref-to-$type to typeglob");
484 no warnings qw(once uninitialized);
486 my $r = eval {no strict; ${*{$g}{SCALAR}}};
487 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
490 $r = eval {use strict; ${*{$g}{SCALAR}}};
492 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
496 # Bug reported by broquaint on IRC
497 *slosh::{HASH}->{ISA}=[];
499 pass("gv_fetchmeth coped with the unexpected");
501 # An audit found these:
510 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
512 is(slosh->isa('swoosh'), '');
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");
519 $CORE::GLOBAL::{"readline"}=[];
520 eval "<STDOUT> if 0";
521 is($@, '', "Can't trip up readline overloading");
523 $CORE::GLOBAL::{"readpipe"}=[];
525 is($@, '', "Can't trip up readpipe overloading");
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'
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
542 no warnings 'numeric';
546 no warnings 'numeric';
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");