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
171 no warnings 'deprecated';
183 *{$a} = sub { $state = "ok" };
191 # although it *should* if you're talking about magicals
208 "o" =~ /(((((((((((o)))))))))))/;
213 # [ID 20010526.001] localized glob loses value when assigned to
215 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
222 # does pp_readline() handle glob-ness correctly?
230 local $SIG{__WARN__} = sub { $w = $_[0] };
232 local *abc1 = sub { };
240 like ($w, qr/Prototype mismatch/);
244 # [17375] rcatline to formerly-defined undef was broken. Fixed in
245 # do_readline by checking SvOK. AMS, 20020918
253 # test the assignment of a GLOB to an LVALUE
255 local $SIG{__DIE__} = sub { $e = $_[0] };
257 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
259 is ($v, '*main::DATA');
266 # GLOB assignment to tied element
267 local $SIG{__DIE__} = sub { $e = $_[0] };
268 sub T::TIEARRAY { bless [] => "T" }
269 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
270 sub T::FETCH { $_[0]->[ $_[1] ] }
271 sub T::FETCHSIZE { @{$_[0]} }
274 is ($ary[0], '*main::DATA');
276 my $x = readline $ary[0];
281 # Need some sort of die or warn to get the global destruction text if the
282 # bug is still present
283 my $output = runperl(prog => <<'EOPROG');
286 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
292 like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
293 unlike($output, qr/global destruction/,
294 "unreferenced symbol tables should be cleaned up immediately");
297 # Possibly not the correct test file for these tests.
298 # There are certain space optimisations implemented via promotion rules to
301 foreach (qw (oonk ga_shloip)) {
302 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
305 # A string in place of the typeglob is promoted to the function prototype
307 my $proto = eval 'prototype \&oonk';
309 is ($proto, "pie", "String is promoted to prototype");
312 # A reference to a value is used to generate a constant subroutine
313 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
314 \*STDIN, \&ok, \undef, *STDOUT) {
317 $proto = eval 'prototype \&oonk';
319 is ($proto, '', "Prototype for a constant subroutine is empty");
321 my $got = eval 'oonk';
323 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
324 is ($got, $value, "Value is correctly set");
328 $::{oonk} = \"Value";
330 *{"ga_shloip"} = \&{"oonk"};
332 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
333 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
334 is (eval 'ga_shloip', "Value", "Constant has correct value");
335 is (ref $::{ga_shloip}, 'SCALAR',
336 "Inlining of constant doesn't change represenatation");
338 delete $::{ga_shloip};
340 eval 'sub ga_shloip (); 1' or die $@;
341 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
343 # Check that a prototype expands.
344 *{"ga_shloip"} = \&{"oonk"};
346 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
347 is (eval 'ga_shloip', "Value", "Constant has correct value");
348 is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
353 # Check that assignment to an existing typeglob works
356 local $SIG{__WARN__} = sub { $w = $_[0] };
357 *{"zwot"} = \&{"oonk"};
358 is($w, '', "Should be no warning");
361 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
362 is (eval 'zwot', "Value", "Constant has correct value");
363 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
364 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
370 # Check that assignment to an existing subroutine works
373 local $SIG{__WARN__} = sub { $w = $_[0] };
374 *{"spritsits"} = \&{"oonk"};
375 like($w, qr/^Constant subroutine main::spritsits redefined/,
376 "Redefining a constant sub should warn");
379 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
380 is (eval 'spritsits', "Value", "Constant has correct value");
381 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
383 # Check that assignment to an existing typeglob works
386 local $SIG{__WARN__} = sub { $w = $_[0] };
388 *{"plunk"} = \&{"oonk"};
389 is($w, '', "Should be no warning");
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");
396 my $gr = eval '\*plunk' or die;
400 local $SIG{__WARN__} = sub { $w = $_[0] };
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)");
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");
409 # Non-void context should defeat the optimisation, and will cause the original
410 # to be promoted (what change 26482 intended)
414 local $SIG{__WARN__} = sub { $w = $_[0] };
415 $result = *{"awkkkkkk"} = \&{"oonk"};
416 is($w, '', "Should be no warning");
419 is (ref \$result, 'GLOB',
420 "Non void assignment should still return a typeglob");
422 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
423 is (eval 'plunk', "Value", "Constant has correct value");
424 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
427 $::{oonk} = \"Value";
431 local $SIG{__WARN__} = sub { $w = $_[0] };
432 *{"zap"} = \&{"oonk"};
433 is($w, '', "Should be no warning");
437 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
438 is (eval 'zap', "Value", "Constant has correct value");
439 is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
442 local $SIG{__WARN__} = sub { die $_[0] };
443 *{"biff"} = \&{"oonk"};
447 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
448 is (eval 'biff', "Value", "Constant has correct value");
449 is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
452 use vars qw($glook $smek $foof);
453 # Check reference assignment isn't affected by the SV type (bug #38439)
456 $foof = "halt and cool down";
465 is($foof, "halt and cool down");
473 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
474 # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
475 # IO::Handle, which isn't what we want.
481 $proto = eval 'prototype \&oonk';
482 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
483 "Cannot upgrade ref-to-$type to typeglob");
487 no warnings qw(once uninitialized);
489 my $r = eval {no strict; ${*{$g}{SCALAR}}};
490 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
493 $r = eval {use strict; ${*{$g}{SCALAR}}};
495 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
499 # Bug reported by broquaint on IRC
500 *slosh::{HASH}->{ISA}=[];
502 pass("gv_fetchmeth coped with the unexpected");
504 # An audit found these:
513 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
515 is(slosh->isa('swoosh'), '');
517 $CORE::GLOBAL::{"lock"}=[];
518 eval "no warnings; lock";
519 like($@, qr/^Not enough arguments for lock/,
520 "Can't trip up general keyword overloading");
522 $CORE::GLOBAL::{"readline"}=[];
523 eval "<STDOUT> if 0";
524 is($@, '', "Can't trip up readline overloading");
526 $CORE::GLOBAL::{"readpipe"}=[];
528 is($@, '', "Can't trip up readpipe overloading");
532 die if exists $::{BONK};
533 $::{BONK} = \"powie";
534 *{"BONK"} = \&{"BONK"};
535 eval 'is(BONK(), "powie",
536 "Assigment works when glob created midway (bug 45607)"); 1'
540 # For now these tests are here, but they would probably be better in a file for
541 # tests for croaks. (And in turn, that probably deserves to be in a different
542 # directory. Gerard Goossen has a point about the layout being unclear
545 no warnings 'numeric';
549 no warnings 'numeric';
556 foreach my $type (qw(integer number string)) {
557 my $prog = "coerce_$type(*STDERR)";
558 is (scalar eval "$prog; 1", undef, "$prog failed...");
559 like ($@, qr/Can't coerce GLOB to $type in/,
560 "with the correct error message");
563 # RT #60954 anonymous glob should be defined, and not coredump when
564 # stringified. The behaviours are:
566 # defined($glob) "$glob"
567 # 5.8.8 false "" with uninit warning
568 # 5.10.0 true (coredump)
572 my $io_ref = *STDOUT{IO};
574 ok(defined $glob, "RT #60954 anon glob should be defined");
577 local $SIG{__WARN__} = sub { $warn = $_[0] };
580 is($warn, '', "RT #60954 anon glob stringification shouln't warn");
581 is($str, '', "RT #60954 anon glob stringification should be empty");
584 # [perl #71254] - Assigning a glob to a variable that has a current
585 # match position. (We are testing that Perl_magic_setmglob respects globs'
586 # special used of SvSCREAM.)
588 $m = 2; $m=~s/./0/gems; $m= *STDERR;
590 "$m", "*main::STDERR",
591 '[perl #71254] assignment of globs to vars with pos'