This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix build for threaded perls
[perl5.git] / t / op / gv.t
CommitLineData
b9894134
PP
1#!./perl
2
3#
4# various typeglob tests
5#
6
9f1b1f2d
GS
7BEGIN {
8 chdir 't' if -d 't';
20822f61 9 @INC = '../lib';
98e007d4 10}
9f1b1f2d
GS
11
12use warnings;
13
98e007d4 14require './test.pl';
0fe688f5 15plan( tests => 192 );
b9894134
PP
16
17# type coersion on assignment
18$foo = 'foo';
19$bar = *main::foo;
20$bar = $foo;
98e007d4 21is(ref(\$bar), 'SCALAR');
b9894134
PP
22$foo = *main::bar;
23
24# type coersion (not) on misc ops
25
98e007d4
NC
26ok($foo);
27is(ref(\$foo), 'GLOB');
b9894134 28
98e007d4
NC
29unlike ($foo, qr/abcd/);
30is(ref(\$foo), 'GLOB');
b9894134 31
98e007d4
NC
32is($foo, '*main::bar');
33is(ref(\$foo), 'GLOB');
b9894134
PP
34
35# type coersion on substitutions that match
36$a = *main::foo;
37$b = $a;
38$a =~ s/^X//;
98e007d4 39is(ref(\$a), 'GLOB');
b9894134 40$a =~ s/^\*//;
98e007d4
NC
41is($a, 'main::foo');
42is(ref(\$b), 'GLOB');
b9894134
PP
43
44# typeglobs as lvalues
45substr($foo, 0, 1) = "XXX";
98e007d4
NC
46is(ref(\$foo), 'SCALAR');
47is($foo, 'XXXmain::bar');
b9894134
PP
48
49# returning glob values
50sub foo {
51 local($bar) = *main::foo;
52 $foo = *main::bar;
53 return ($foo, $bar);
54}
55
56($fuu, $baa) = foo();
98e007d4
NC
57ok(defined $fuu);
58is(ref(\$fuu), 'GLOB');
b9894134 59
98e007d4
NC
60
61ok(defined $baa);
62is(ref(\$baa), 'GLOB');
b9894134 63
85aff577
CS
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
9f1b1f2d 69{ package Foo::Bar; no warnings 'once'; $test=1; }
98e007d4
NC
70ok(exists $Foo::{'Bar::'});
71is($Foo::{'Bar::'}, '*Foo::Bar::');
72
20408e3c
GS
73
74# test undef operator clearing out entire glob
75$foo = 'stuff';
76@foo = qw(more stuff);
77%foo = qw(even more random stuff);
78undef *foo;
98e007d4
NC
79is ($foo, undef);
80is (scalar @foo, 0);
81is (scalar %foo, 0);
20408e3c 82
20408e3c 83{
98e007d4
NC
84 # test warnings from assignment of undef to glob
85 my $msg = '';
20408e3c 86 local $SIG{__WARN__} = sub { $msg = $_[0] };
9f1b1f2d 87 use warnings;
20408e3c 88 *foo = 'bar';
98e007d4 89 is($msg, '');
20408e3c 90 *foo = undef;
98e007d4 91 like($msg, qr/Undefined value assigned to typeglob/);
e36cc0fb
NC
92
93 no warnings 'once';
94 # test warnings for converting globs to other forms
95 my $copy = *PWOMPF;
96 foreach ($copy, *SKREEE) {
97 $msg = '';
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");
101 is($victim, 0);
102
103 $msg = '';
104 $victim = sprintf "%u", $_;
105 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
106 "Warning on conversion to UV");
107 is($victim, 0);
108
109 $msg = '';
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");
114
115 $msg = '';
116 $victim = sprintf "%s", $_;
117 is($msg, '', "No warning on stringification");
118 is($victim, '' . $_);
119 }
20408e3c 120}
640b9ef6 121
98e007d4 122my $test = curr_test();
640b9ef6 123# test *glob{THING} syntax
98e007d4
NC
124$x = "ok $test\n";
125++$test;
126@x = ("ok $test\n");
127++$test;
128%x = ("ok $test" => "\n");
129++$test;
130sub x { "ok $test\n" }
640b9ef6 131print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
98e007d4
NC
132# This needs to go here, after the print, as sub x will return the current
133# value of test
134++$test;
f4d13ee9 135format x =
98e007d4 136XXX This text isn't used. Should it be?
f4d13ee9 137.
98e007d4
NC
138curr_test($test);
139
140is (ref *x{FORMAT}, "FORMAT");
640b9ef6 141*x = *STDOUT;
98e007d4 142is (*{*x{GLOB}}, "*main::STDOUT");
39b99f21 143
29a56bd6 144{
98e007d4
NC
145 my $test = curr_test();
146
147 print {*x{IO}} "ok $test\n";
148 ++$test;
149
150 my $warn;
151 local $SIG{__WARN__} = sub {
152 $warn .= $_[0];
153 };
154 my $val = *x{FILEHANDLE};
155 print {*x{IO}} ($warn =~ /is deprecated/
156 ? "ok $test\n" : "not ok $test\n");
157 curr_test(++$test);
29a56bd6
JH
158}
159
35cd451c
GS
160
161{
98e007d4 162 # test if defined() doesn't create any new symbols
35cd451c
GS
163
164 my $a = "SYM000";
98e007d4 165 ok(!defined *{$a});
35cd451c 166
98e007d4
NC
167 ok(!defined @{$a});
168 ok(!defined *{$a});
35cd451c 169
d47e1c27
NC
170 {
171 no warnings 'deprecated';
172 ok(!defined %{$a});
173 }
98e007d4 174 ok(!defined *{$a});
35cd451c 175
98e007d4
NC
176 ok(!defined ${$a});
177 ok(!defined *{$a});
35cd451c 178
98e007d4
NC
179 ok(!defined &{$a});
180 ok(!defined *{$a});
35cd451c 181
98e007d4
NC
182 my $state = "not";
183 *{$a} = sub { $state = "ok" };
184 ok(defined &{$a});
185 ok(defined *{$a});
186 &{$a};
187 is ($state, 'ok');
35cd451c 188}
640b9ef6 189
c9d5ac95 190{
98e007d4 191 # although it *should* if you're talking about magicals
c9d5ac95
GS
192
193 my $a = "]";
98e007d4
NC
194 ok(defined ${$a});
195 ok(defined *{$a});
c9d5ac95
GS
196
197 $a = "1";
198 "o" =~ /(o)/;
98e007d4
NC
199 ok(${$a});
200 ok(defined *{$a});
c9d5ac95 201 $a = "2";
98e007d4
NC
202 ok(!${$a});
203 ok(defined *{$a});
c9d5ac95 204 $a = "1x";
98e007d4
NC
205 ok(!defined ${$a});
206 ok(!defined *{$a});
c9d5ac95
GS
207 $a = "11";
208 "o" =~ /(((((((((((o)))))))))))/;
98e007d4
NC
209 ok(${$a});
210 ok(defined *{$a});
c9d5ac95
GS
211}
212
bd2155e9
JH
213# [ID 20010526.001] localized glob loses value when assigned to
214
215$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
216
98e007d4
NC
217is($j, 1);
218is($j{a}, 1);
219is($j[0], 1);
99491443
GS
220
221{
98e007d4 222 # does pp_readline() handle glob-ness correctly?
99491443
GS
223 my $g = *foo;
224 $g = <DATA>;
98e007d4 225 is ($g, "Perl\n");
99491443
GS
226}
227
fb24441d
RGS
228{
229 my $w = '';
bb112e5a 230 local $SIG{__WARN__} = sub { $w = $_[0] };
fb24441d
RGS
231 sub abc1 ();
232 local *abc1 = sub { };
98e007d4 233 is ($w, '');
fb24441d
RGS
234 sub abc2 ();
235 local *abc2;
236 *abc2 = sub { };
98e007d4 237 is ($w, '');
fb24441d
RGS
238 sub abc3 ();
239 *abc3 = sub { };
98e007d4 240 like ($w, qr/Prototype mismatch/);
fb24441d
RGS
241}
242
2b5e58c4
AMS
243{
244 # [17375] rcatline to formerly-defined undef was broken. Fixed in
245 # do_readline by checking SvOK. AMS, 20020918
246 my $x = "not ";
247 $x = undef;
248 $x .= <DATA>;
98e007d4 249 is ($x, "Rules\n");
2b5e58c4
AMS
250}
251
4ce457a6
TP
252{
253 # test the assignment of a GLOB to an LVALUE
254 my $e = '';
255 local $SIG{__DIE__} = sub { $e = $_[0] };
256 my $v;
257 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
258 f($v);
98e007d4 259 is ($v, '*main::DATA');
4ce457a6 260 my $x = <$v>;
98e007d4 261 is ($x, "perl\n");
4ce457a6
TP
262}
263
98e007d4
NC
264{
265 $e = '';
4ce457a6
TP
266 # GLOB assignment to tied element
267 local $SIG{__DIE__} = sub { $e = $_[0] };
98e007d4
NC
268 sub T::TIEARRAY { bless [] => "T" }
269 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
270 sub T::FETCH { $_[0]->[ $_[1] ] }
271 sub T::FETCHSIZE { @{$_[0]} }
4ce457a6
TP
272 tie my @ary => "T";
273 $ary[0] = *DATA;
98e007d4
NC
274 is ($ary[0], '*main::DATA');
275 is ($e, '');
4ce457a6 276 my $x = readline $ary[0];
98e007d4 277 is($x, "rocks\n");
4ce457a6
TP
278}
279
e15faf7d 280{
4184c77b
NC
281 # Need some sort of die or warn to get the global destruction text if the
282 # bug is still present
5c2a9b31 283 my $output = runperl(prog => <<'EOPROG');
e15faf7d 284package M;
5c2a9b31 285$| = 1;
4184c77b 286sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
e15faf7d
NC
287package main;
288
289bless \$A::B, 'M';
290*A:: = \*B::;
291EOPROG
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");
295}
63fa9adc
NC
296
297# Possibly not the correct test file for these tests.
298# There are certain space optimisations implemented via promotion rules to
299# GVs
300
bb112e5a
NC
301foreach (qw (oonk ga_shloip)) {
302 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
303}
63fa9adc
NC
304
305# A string in place of the typeglob is promoted to the function prototype
306$::{oonk} = "pie";
307my $proto = eval 'prototype \&oonk';
308die if $@;
309is ($proto, "pie", "String is promoted to prototype");
310
311
312# A reference to a value is used to generate a constant subroutine
313foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
5c1f4d79 314 \*STDIN, \&ok, \undef, *STDOUT) {
63fa9adc
NC
315 delete $::{oonk};
316 $::{oonk} = \$value;
317 $proto = eval 'prototype \&oonk';
318 die if $@;
319 is ($proto, '', "Prototype for a constant subroutine is empty");
320
321 my $got = eval 'oonk';
322 die if $@;
5c1f4d79 323 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
63fa9adc
NC
324 is ($got, $value, "Value is correctly set");
325}
5c1f4d79 326
bb112e5a
NC
327delete $::{oonk};
328$::{oonk} = \"Value";
329
330*{"ga_shloip"} = \&{"oonk"};
331
332is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
333is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
334is (eval 'ga_shloip', "Value", "Constant has correct value");
335is (ref $::{ga_shloip}, 'SCALAR',
336 "Inlining of constant doesn't change represenatation");
337
338delete $::{ga_shloip};
339
340eval 'sub ga_shloip (); 1' or die $@;
341is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
342
343# Check that a prototype expands.
344*{"ga_shloip"} = \&{"oonk"};
345
346is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
347is (eval 'ga_shloip', "Value", "Constant has correct value");
348is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
349
350
351@::zwot = ('Zwot!');
352
353# Check that assignment to an existing typeglob works
354{
355 my $w = '';
356 local $SIG{__WARN__} = sub { $w = $_[0] };
357 *{"zwot"} = \&{"oonk"};
358 is($w, '', "Should be no warning");
359}
360
361is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
362is (eval 'zwot', "Value", "Constant has correct value");
363is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
364is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
365
366sub spritsits () {
367 "Traditional";
368}
369
370# Check that assignment to an existing subroutine works
371{
372 my $w = '';
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");
377}
378
379is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
380is (eval 'spritsits', "Value", "Constant has correct value");
381is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
382
bb112e5a
NC
383# Check that assignment to an existing typeglob works
384{
385 my $w = '';
386 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea
VP
387 *{"plunk"} = [];
388 *{"plunk"} = \&{"oonk"};
bb112e5a
NC
389 is($w, '', "Should be no warning");
390}
391
bb112e5a
NC
392is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
393is (eval 'plunk', "Value", "Constant has correct value");
394is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
395
396my $gr = eval '\*plunk' or die;
397
398{
399 my $w = '';
400 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea 401 *{$gr} = \&{"oonk"};
2111d928 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)");
bb112e5a
NC
403}
404
405is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
406is (eval 'plunk', "Value", "Constant has correct value");
407is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
408
50baa5ea
VP
409# Non-void context should defeat the optimisation, and will cause the original
410# to be promoted (what change 26482 intended)
411my $result;
412{
413 my $w = '';
414 local $SIG{__WARN__} = sub { $w = $_[0] };
415 $result = *{"awkkkkkk"} = \&{"oonk"};
416 is($w, '', "Should be no warning");
417}
418
419is (ref \$result, 'GLOB',
420 "Non void assignment should still return a typeglob");
421
422is (ref \$::{oonk}, 'GLOB', "This export does affect original");
423is (eval 'plunk', "Value", "Constant has correct value");
424is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
425
426delete $::{oonk};
427$::{oonk} = \"Value";
428
429sub non_dangling {
430 my $w = '';
431 local $SIG{__WARN__} = sub { $w = $_[0] };
432 *{"zap"} = \&{"oonk"};
433 is($w, '', "Should be no warning");
434}
435
436non_dangling();
437is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
438is (eval 'zap', "Value", "Constant has correct value");
439is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
440
441sub dangling {
442 local $SIG{__WARN__} = sub { die $_[0] };
443 *{"biff"} = \&{"oonk"};
444}
445
446dangling();
447is (ref \$::{oonk}, 'GLOB', "This export does affect original");
448is (eval 'biff', "Value", "Constant has correct value");
449is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
450
acaa9288
NC
451{
452 use vars qw($glook $smek $foof);
453 # Check reference assignment isn't affected by the SV type (bug #38439)
454 $glook = 3;
455 $smek = 4;
456 $foof = "halt and cool down";
457
458 my $rv = \*smek;
459 is($glook, 3);
460 *glook = $rv;
461 is($glook, 4);
462
463 my $pv = "";
464 $pv = \*smek;
465 is($foof, "halt and cool down");
466 *foof = $pv;
467 is($foof, 4);
468}
469
5c1f4d79
NC
470format =
471.
472
473foreach 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.
476 my $type = $value;
477 $type =~ s/.*=//;
478 $type =~ s/\(.*//;
479 delete $::{oonk};
480 $::{oonk} = $value;
481 $proto = eval 'prototype \&oonk';
482 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
483 "Cannot upgrade ref-to-$type to typeglob");
484}
f9d52e31
NC
485
486{
487 no warnings qw(once uninitialized);
488 my $g = \*clatter;
489 my $r = eval {no strict; ${*{$g}{SCALAR}}};
490 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
491
492 $g = \*vowm;
493 $r = eval {use strict; ${*{$g}{SCALAR}}};
494 is ($@, '',
495 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
496}
497
06be3b40
NC
498{
499 # Bug reported by broquaint on IRC
500 *slosh::{HASH}->{ISA}=[];
501 slosh->import;
502 pass("gv_fetchmeth coped with the unexpected");
9e0d86f8
NC
503
504 # An audit found these:
505 {
506 package slosh;
507 sub rip {
508 my $s = shift;
509 $s->SUPER::rip;
510 }
511 }
512 eval {slosh->rip;};
513 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
514
515 is(slosh->isa('swoosh'), '');
516
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");
521
522 $CORE::GLOBAL::{"readline"}=[];
b3c9268e 523 eval "<STDOUT> if 0";
9e0d86f8 524 is($@, '', "Can't trip up readline overloading");
d5e716f5
NC
525
526 $CORE::GLOBAL::{"readpipe"}=[];
527 eval "`` if 0";
528 is($@, '', "Can't trip up readpipe overloading");
06be3b40 529}
53a42478
NC
530
531{
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'
537 or die $@;
538}
1f257c95
NC
539
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
543
544sub coerce_integer {
545 no warnings 'numeric';
546 $_[0] |= 0;
547}
548sub coerce_number {
549 no warnings 'numeric';
550 $_[0] += 0;
551}
552sub coerce_string {
553 $_[0] .= '';
554}
555
556foreach 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");
561}
562
1809c940
DM
563# RT #60954 anonymous glob should be defined, and not coredump when
564# stringified. The behaviours are:
565#
566# defined($glob) "$glob"
567# 5.8.8 false "" with uninit warning
568# 5.10.0 true (coredump)
569# 5.12.0 true ""
570
571{
572 my $io_ref = *STDOUT{IO};
573 my $glob = *$io_ref;
574 ok(defined $glob, "RT #60954 anon glob should be defined");
575
576 my $warn = '';
577 local $SIG{__WARN__} = sub { $warn = $_[0] };
578 use warnings;
579 my $str = "$glob";
580 is($warn, '', "RT #60954 anon glob stringification shouln't warn");
581 is($str, '', "RT #60954 anon glob stringification should be empty");
582}
583
1f730e6c
FC
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.)
587{
588 $m = 2; $m=~s/./0/gems; $m= *STDERR;
589 is(
590 "$m", "*main::STDERR",
591 '[perl #71254] assignment of globs to vars with pos'
592 );
593}
594
2867cdbc
Z
595# [perl #72740] - indirect object syntax, heuristically imputed due to
596# the non-existence of a function, should not cause a stash entry to be
597# created for the non-existent function.
598{
599 package RT72740a;
600 my $f = bless({}, RT72740b);
601 sub s1 { s2 $f; }
602 our $s4;
603 sub s3 { s4 $f; }
604}
605{
606 package RT72740b;
607 sub s2 { "RT72740b::s2" }
608 sub s4 { "RT72740b::s4" }
609}
610ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
611ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
612ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
613ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
614is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
615is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
616
b9e00b79
LRG
617# [perl #71686] Globs that are in symbol table can be un-globbed
618$sym = undef;
619$::{fake} = *sym;
620is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
621 "Localized glob didn't coerce into a RV");
622is ($@, '', "Can localize FAKE glob that's present in stash");
623is (scalar $::{fake}, "*main::sym",
624 "Localized FAKE glob's value was correctly restored");
625
0fe688f5
FC
626# [perl #1804] *$x assignment when $x is a copy of another glob
627{
628 no warnings 'once';
629 my $x = *_random::glob_that_is_not_used_elsewhere;
630 *$x = sub{};
631 is(
632 "$x", '*_random::glob_that_is_not_used_elsewhere',
633 '[perl #1804] *$x assignment when $x is FAKE',
634 );
635}
636
99491443 637__END__
98e007d4
NC
638Perl
639Rules
640perl
641rocks