Move the require './test.pl' to the end of t/comp/hints.t
[p5sagit/p5-mst-13.2.git] / t / op / gv.t
CommitLineData
b9894134 1#!./perl
2
3#
4# various typeglob tests
5#
6
9f1b1f2d 7BEGIN {
8 chdir 't' if -d 't';
20822f61 9 @INC = '../lib';
98e007d4 10}
9f1b1f2d 11
12use warnings;
13
98e007d4 14require './test.pl';
50baa5ea 15plan( tests => 178 );
b9894134 16
17# type coersion on assignment
18$foo = 'foo';
19$bar = *main::foo;
20$bar = $foo;
98e007d4 21is(ref(\$bar), 'SCALAR');
b9894134 22$foo = *main::bar;
23
24# type coersion (not) on misc ops
25
98e007d4 26ok($foo);
27is(ref(\$foo), 'GLOB');
b9894134 28
98e007d4 29unlike ($foo, qr/abcd/);
30is(ref(\$foo), 'GLOB');
b9894134 31
98e007d4 32is($foo, '*main::bar');
33is(ref(\$foo), 'GLOB');
b9894134 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 41is($a, 'main::foo');
42is(ref(\$b), 'GLOB');
b9894134 43
44# typeglobs as lvalues
45substr($foo, 0, 1) = "XXX";
98e007d4 46is(ref(\$foo), 'SCALAR');
47is($foo, 'XXXmain::bar');
b9894134 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 57ok(defined $fuu);
58is(ref(\$fuu), 'GLOB');
b9894134 59
98e007d4 60
61ok(defined $baa);
62is(ref(\$baa), 'GLOB');
b9894134 63
85aff577 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 70ok(exists $Foo::{'Bar::'});
71is($Foo::{'Bar::'}, '*Foo::Bar::');
72
20408e3c 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 79is ($foo, undef);
80is (scalar @foo, 0);
81is (scalar %foo, 0);
20408e3c 82
20408e3c 83{
98e007d4 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 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 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 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 138curr_test($test);
139
140is (ref *x{FORMAT}, "FORMAT");
640b9ef6 141*x = *STDOUT;
98e007d4 142is (*{*x{GLOB}}, "*main::STDOUT");
39b99f21 143
29a56bd6 144{
98e007d4 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 158}
159
35cd451c 160
161{
98e007d4 162 # test if defined() doesn't create any new symbols
35cd451c 163
164 my $a = "SYM000";
98e007d4 165 ok(!defined *{$a});
35cd451c 166
98e007d4 167 ok(!defined @{$a});
168 ok(!defined *{$a});
35cd451c 169
98e007d4 170 ok(!defined %{$a});
171 ok(!defined *{$a});
35cd451c 172
98e007d4 173 ok(!defined ${$a});
174 ok(!defined *{$a});
35cd451c 175
98e007d4 176 ok(!defined &{$a});
177 ok(!defined *{$a});
35cd451c 178
98e007d4 179 my $state = "not";
180 *{$a} = sub { $state = "ok" };
181 ok(defined &{$a});
182 ok(defined *{$a});
183 &{$a};
184 is ($state, 'ok');
35cd451c 185}
640b9ef6 186
c9d5ac95 187{
98e007d4 188 # although it *should* if you're talking about magicals
c9d5ac95 189
190 my $a = "]";
98e007d4 191 ok(defined ${$a});
192 ok(defined *{$a});
c9d5ac95 193
194 $a = "1";
195 "o" =~ /(o)/;
98e007d4 196 ok(${$a});
197 ok(defined *{$a});
c9d5ac95 198 $a = "2";
98e007d4 199 ok(!${$a});
200 ok(defined *{$a});
c9d5ac95 201 $a = "1x";
98e007d4 202 ok(!defined ${$a});
203 ok(!defined *{$a});
c9d5ac95 204 $a = "11";
205 "o" =~ /(((((((((((o)))))))))))/;
98e007d4 206 ok(${$a});
207 ok(defined *{$a});
c9d5ac95 208}
209
bd2155e9 210# [ID 20010526.001] localized glob loses value when assigned to
211
212$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
213
98e007d4 214is($j, 1);
215is($j{a}, 1);
216is($j[0], 1);
99491443 217
218{
98e007d4 219 # does pp_readline() handle glob-ness correctly?
99491443 220 my $g = *foo;
221 $g = <DATA>;
98e007d4 222 is ($g, "Perl\n");
99491443 223}
224
fb24441d 225{
226 my $w = '';
bb112e5a 227 local $SIG{__WARN__} = sub { $w = $_[0] };
fb24441d 228 sub abc1 ();
229 local *abc1 = sub { };
98e007d4 230 is ($w, '');
fb24441d 231 sub abc2 ();
232 local *abc2;
233 *abc2 = sub { };
98e007d4 234 is ($w, '');
fb24441d 235 sub abc3 ();
236 *abc3 = sub { };
98e007d4 237 like ($w, qr/Prototype mismatch/);
fb24441d 238}
239
2b5e58c4 240{
241 # [17375] rcatline to formerly-defined undef was broken. Fixed in
242 # do_readline by checking SvOK. AMS, 20020918
243 my $x = "not ";
244 $x = undef;
245 $x .= <DATA>;
98e007d4 246 is ($x, "Rules\n");
2b5e58c4 247}
248
4ce457a6 249{
250 # test the assignment of a GLOB to an LVALUE
251 my $e = '';
252 local $SIG{__DIE__} = sub { $e = $_[0] };
253 my $v;
254 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
255 f($v);
98e007d4 256 is ($v, '*main::DATA');
4ce457a6 257 my $x = <$v>;
98e007d4 258 is ($x, "perl\n");
4ce457a6 259}
260
98e007d4 261{
262 $e = '';
4ce457a6 263 # GLOB assignment to tied element
264 local $SIG{__DIE__} = sub { $e = $_[0] };
98e007d4 265 sub T::TIEARRAY { bless [] => "T" }
266 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
267 sub T::FETCH { $_[0]->[ $_[1] ] }
268 sub T::FETCHSIZE { @{$_[0]} }
4ce457a6 269 tie my @ary => "T";
270 $ary[0] = *DATA;
98e007d4 271 is ($ary[0], '*main::DATA');
272 is ($e, '');
4ce457a6 273 my $x = readline $ary[0];
98e007d4 274 is($x, "rocks\n");
4ce457a6 275}
276
e15faf7d 277{
4184c77b 278 # Need some sort of die or warn to get the global destruction text if the
279 # bug is still present
5c2a9b31 280 my $output = runperl(prog => <<'EOPROG');
e15faf7d 281package M;
5c2a9b31 282$| = 1;
4184c77b 283sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
e15faf7d 284package main;
285
286bless \$A::B, 'M';
287*A:: = \*B::;
288EOPROG
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");
292}
63fa9adc 293
294# Possibly not the correct test file for these tests.
295# There are certain space optimisations implemented via promotion rules to
296# GVs
297
bb112e5a 298foreach (qw (oonk ga_shloip)) {
299 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
300}
63fa9adc 301
302# A string in place of the typeglob is promoted to the function prototype
303$::{oonk} = "pie";
304my $proto = eval 'prototype \&oonk';
305die if $@;
306is ($proto, "pie", "String is promoted to prototype");
307
308
309# A reference to a value is used to generate a constant subroutine
310foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
5c1f4d79 311 \*STDIN, \&ok, \undef, *STDOUT) {
63fa9adc 312 delete $::{oonk};
313 $::{oonk} = \$value;
314 $proto = eval 'prototype \&oonk';
315 die if $@;
316 is ($proto, '', "Prototype for a constant subroutine is empty");
317
318 my $got = eval 'oonk';
319 die if $@;
5c1f4d79 320 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
63fa9adc 321 is ($got, $value, "Value is correctly set");
322}
5c1f4d79 323
bb112e5a 324delete $::{oonk};
325$::{oonk} = \"Value";
326
327*{"ga_shloip"} = \&{"oonk"};
328
329is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
330is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
331is (eval 'ga_shloip', "Value", "Constant has correct value");
332is (ref $::{ga_shloip}, 'SCALAR',
333 "Inlining of constant doesn't change represenatation");
334
335delete $::{ga_shloip};
336
337eval 'sub ga_shloip (); 1' or die $@;
338is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
339
340# Check that a prototype expands.
341*{"ga_shloip"} = \&{"oonk"};
342
343is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
344is (eval 'ga_shloip', "Value", "Constant has correct value");
345is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
346
347
348@::zwot = ('Zwot!');
349
350# Check that assignment to an existing typeglob works
351{
352 my $w = '';
353 local $SIG{__WARN__} = sub { $w = $_[0] };
354 *{"zwot"} = \&{"oonk"};
355 is($w, '', "Should be no warning");
356}
357
358is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
359is (eval 'zwot', "Value", "Constant has correct value");
360is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
361is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
362
363sub spritsits () {
364 "Traditional";
365}
366
367# Check that assignment to an existing subroutine works
368{
369 my $w = '';
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");
374}
375
376is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
377is (eval 'spritsits', "Value", "Constant has correct value");
378is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
379
bb112e5a 380# Check that assignment to an existing typeglob works
381{
382 my $w = '';
383 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea 384 *{"plunk"} = [];
385 *{"plunk"} = \&{"oonk"};
bb112e5a 386 is($w, '', "Should be no warning");
387}
388
bb112e5a 389is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
390is (eval 'plunk', "Value", "Constant has correct value");
391is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
392
393my $gr = eval '\*plunk' or die;
394
395{
396 my $w = '';
397 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea 398 *{$gr} = \&{"oonk"};
2111d928 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)");
bb112e5a 400}
401
402is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
403is (eval 'plunk', "Value", "Constant has correct value");
404is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
405
50baa5ea 406# Non-void context should defeat the optimisation, and will cause the original
407# to be promoted (what change 26482 intended)
408my $result;
409{
410 my $w = '';
411 local $SIG{__WARN__} = sub { $w = $_[0] };
412 $result = *{"awkkkkkk"} = \&{"oonk"};
413 is($w, '', "Should be no warning");
414}
415
416is (ref \$result, 'GLOB',
417 "Non void assignment should still return a typeglob");
418
419is (ref \$::{oonk}, 'GLOB', "This export does affect original");
420is (eval 'plunk', "Value", "Constant has correct value");
421is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
422
423delete $::{oonk};
424$::{oonk} = \"Value";
425
426sub non_dangling {
427 my $w = '';
428 local $SIG{__WARN__} = sub { $w = $_[0] };
429 *{"zap"} = \&{"oonk"};
430 is($w, '', "Should be no warning");
431}
432
433non_dangling();
434is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
435is (eval 'zap', "Value", "Constant has correct value");
436is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
437
438sub dangling {
439 local $SIG{__WARN__} = sub { die $_[0] };
440 *{"biff"} = \&{"oonk"};
441}
442
443dangling();
444is (ref \$::{oonk}, 'GLOB', "This export does affect original");
445is (eval 'biff', "Value", "Constant has correct value");
446is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
447
acaa9288 448{
449 use vars qw($glook $smek $foof);
450 # Check reference assignment isn't affected by the SV type (bug #38439)
451 $glook = 3;
452 $smek = 4;
453 $foof = "halt and cool down";
454
455 my $rv = \*smek;
456 is($glook, 3);
457 *glook = $rv;
458 is($glook, 4);
459
460 my $pv = "";
461 $pv = \*smek;
462 is($foof, "halt and cool down");
463 *foof = $pv;
464 is($foof, 4);
465}
466
5c1f4d79 467format =
468.
469
470foreach 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.
473 my $type = $value;
474 $type =~ s/.*=//;
475 $type =~ s/\(.*//;
476 delete $::{oonk};
477 $::{oonk} = $value;
478 $proto = eval 'prototype \&oonk';
479 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
480 "Cannot upgrade ref-to-$type to typeglob");
481}
f9d52e31 482
483{
484 no warnings qw(once uninitialized);
485 my $g = \*clatter;
486 my $r = eval {no strict; ${*{$g}{SCALAR}}};
487 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
488
489 $g = \*vowm;
490 $r = eval {use strict; ${*{$g}{SCALAR}}};
491 is ($@, '',
492 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
493}
494
06be3b40 495{
496 # Bug reported by broquaint on IRC
497 *slosh::{HASH}->{ISA}=[];
498 slosh->import;
499 pass("gv_fetchmeth coped with the unexpected");
9e0d86f8 500
501 # An audit found these:
502 {
503 package slosh;
504 sub rip {
505 my $s = shift;
506 $s->SUPER::rip;
507 }
508 }
509 eval {slosh->rip;};
510 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
511
512 is(slosh->isa('swoosh'), '');
513
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");
518
519 $CORE::GLOBAL::{"readline"}=[];
b3c9268e 520 eval "<STDOUT> if 0";
9e0d86f8 521 is($@, '', "Can't trip up readline overloading");
d5e716f5 522
523 $CORE::GLOBAL::{"readpipe"}=[];
524 eval "`` if 0";
525 is($@, '', "Can't trip up readpipe overloading");
06be3b40 526}
53a42478 527
528{
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'
534 or die $@;
535}
1f257c95 536
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
540
541sub coerce_integer {
542 no warnings 'numeric';
543 $_[0] |= 0;
544}
545sub coerce_number {
546 no warnings 'numeric';
547 $_[0] += 0;
548}
549sub coerce_string {
550 $_[0] .= '';
551}
552
553foreach 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");
558}
559
99491443 560__END__
98e007d4 561Perl
562Rules
563perl
564rocks