This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5.8.8: Unicos test skip (and for the record: config.sh and harness results)
[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';
f9d52e31 15plan( tests => 134 );
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/);
20408e3c 92}
640b9ef6 93
98e007d4 94my $test = curr_test();
640b9ef6 95# test *glob{THING} syntax
98e007d4
NC
96$x = "ok $test\n";
97++$test;
98@x = ("ok $test\n");
99++$test;
100%x = ("ok $test" => "\n");
101++$test;
102sub x { "ok $test\n" }
640b9ef6 103print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
98e007d4
NC
104# This needs to go here, after the print, as sub x will return the current
105# value of test
106++$test;
f4d13ee9 107format x =
98e007d4 108XXX This text isn't used. Should it be?
f4d13ee9 109.
98e007d4
NC
110curr_test($test);
111
112is (ref *x{FORMAT}, "FORMAT");
640b9ef6 113*x = *STDOUT;
98e007d4 114is (*{*x{GLOB}}, "*main::STDOUT");
39b99f21 115
29a56bd6 116{
98e007d4
NC
117 my $test = curr_test();
118
119 print {*x{IO}} "ok $test\n";
120 ++$test;
121
122 my $warn;
123 local $SIG{__WARN__} = sub {
124 $warn .= $_[0];
125 };
126 my $val = *x{FILEHANDLE};
127 print {*x{IO}} ($warn =~ /is deprecated/
128 ? "ok $test\n" : "not ok $test\n");
129 curr_test(++$test);
29a56bd6
JH
130}
131
35cd451c
GS
132
133{
98e007d4 134 # test if defined() doesn't create any new symbols
35cd451c
GS
135
136 my $a = "SYM000";
98e007d4 137 ok(!defined *{$a});
35cd451c 138
98e007d4
NC
139 ok(!defined @{$a});
140 ok(!defined *{$a});
35cd451c 141
98e007d4
NC
142 ok(!defined %{$a});
143 ok(!defined *{$a});
35cd451c 144
98e007d4
NC
145 ok(!defined ${$a});
146 ok(!defined *{$a});
35cd451c 147
98e007d4
NC
148 ok(!defined &{$a});
149 ok(!defined *{$a});
35cd451c 150
98e007d4
NC
151 my $state = "not";
152 *{$a} = sub { $state = "ok" };
153 ok(defined &{$a});
154 ok(defined *{$a});
155 &{$a};
156 is ($state, 'ok');
35cd451c 157}
640b9ef6 158
c9d5ac95 159{
98e007d4 160 # although it *should* if you're talking about magicals
c9d5ac95
GS
161
162 my $a = "]";
98e007d4
NC
163 ok(defined ${$a});
164 ok(defined *{$a});
c9d5ac95
GS
165
166 $a = "1";
167 "o" =~ /(o)/;
98e007d4
NC
168 ok(${$a});
169 ok(defined *{$a});
c9d5ac95 170 $a = "2";
98e007d4
NC
171 ok(!${$a});
172 ok(defined *{$a});
c9d5ac95 173 $a = "1x";
98e007d4
NC
174 ok(!defined ${$a});
175 ok(!defined *{$a});
c9d5ac95
GS
176 $a = "11";
177 "o" =~ /(((((((((((o)))))))))))/;
98e007d4
NC
178 ok(${$a});
179 ok(defined *{$a});
c9d5ac95
GS
180}
181
bd2155e9
JH
182# [ID 20010526.001] localized glob loses value when assigned to
183
184$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
185
98e007d4
NC
186is($j, 1);
187is($j{a}, 1);
188is($j[0], 1);
99491443
GS
189
190{
98e007d4 191 # does pp_readline() handle glob-ness correctly?
99491443
GS
192 my $g = *foo;
193 $g = <DATA>;
98e007d4 194 is ($g, "Perl\n");
99491443
GS
195}
196
fb24441d
RGS
197{
198 my $w = '';
bb112e5a 199 local $SIG{__WARN__} = sub { $w = $_[0] };
fb24441d
RGS
200 sub abc1 ();
201 local *abc1 = sub { };
98e007d4 202 is ($w, '');
fb24441d
RGS
203 sub abc2 ();
204 local *abc2;
205 *abc2 = sub { };
98e007d4 206 is ($w, '');
fb24441d
RGS
207 sub abc3 ();
208 *abc3 = sub { };
98e007d4 209 like ($w, qr/Prototype mismatch/);
fb24441d
RGS
210}
211
2b5e58c4
AMS
212{
213 # [17375] rcatline to formerly-defined undef was broken. Fixed in
214 # do_readline by checking SvOK. AMS, 20020918
215 my $x = "not ";
216 $x = undef;
217 $x .= <DATA>;
98e007d4 218 is ($x, "Rules\n");
2b5e58c4
AMS
219}
220
4ce457a6
TP
221{
222 # test the assignment of a GLOB to an LVALUE
223 my $e = '';
224 local $SIG{__DIE__} = sub { $e = $_[0] };
225 my $v;
226 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
227 f($v);
98e007d4 228 is ($v, '*main::DATA');
4ce457a6 229 my $x = <$v>;
98e007d4 230 is ($x, "perl\n");
4ce457a6
TP
231}
232
98e007d4
NC
233{
234 $e = '';
4ce457a6
TP
235 # GLOB assignment to tied element
236 local $SIG{__DIE__} = sub { $e = $_[0] };
98e007d4
NC
237 sub T::TIEARRAY { bless [] => "T" }
238 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
239 sub T::FETCH { $_[0]->[ $_[1] ] }
240 sub T::FETCHSIZE { @{$_[0]} }
4ce457a6
TP
241 tie my @ary => "T";
242 $ary[0] = *DATA;
98e007d4
NC
243 is ($ary[0], '*main::DATA');
244 is ($e, '');
4ce457a6 245 my $x = readline $ary[0];
98e007d4 246 is($x, "rocks\n");
4ce457a6
TP
247}
248
e15faf7d 249{
4184c77b
NC
250 # Need some sort of die or warn to get the global destruction text if the
251 # bug is still present
5c2a9b31 252 my $output = runperl(prog => <<'EOPROG');
e15faf7d 253package M;
5c2a9b31 254$| = 1;
4184c77b 255sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
e15faf7d
NC
256package main;
257
258bless \$A::B, 'M';
259*A:: = \*B::;
260EOPROG
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");
264}
63fa9adc
NC
265
266# Possibly not the correct test file for these tests.
267# There are certain space optimisations implemented via promotion rules to
268# GVs
269
bb112e5a
NC
270foreach (qw (oonk ga_shloip)) {
271 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
272}
63fa9adc
NC
273
274# A string in place of the typeglob is promoted to the function prototype
275$::{oonk} = "pie";
276my $proto = eval 'prototype \&oonk';
277die if $@;
278is ($proto, "pie", "String is promoted to prototype");
279
280
281# A reference to a value is used to generate a constant subroutine
282foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
5c1f4d79 283 \*STDIN, \&ok, \undef, *STDOUT) {
63fa9adc
NC
284 delete $::{oonk};
285 $::{oonk} = \$value;
286 $proto = eval 'prototype \&oonk';
287 die if $@;
288 is ($proto, '', "Prototype for a constant subroutine is empty");
289
290 my $got = eval 'oonk';
291 die if $@;
5c1f4d79 292 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
63fa9adc
NC
293 is ($got, $value, "Value is correctly set");
294}
5c1f4d79 295
bb112e5a
NC
296delete $::{oonk};
297$::{oonk} = \"Value";
298
299*{"ga_shloip"} = \&{"oonk"};
300
301is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
302is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
303is (eval 'ga_shloip', "Value", "Constant has correct value");
304is (ref $::{ga_shloip}, 'SCALAR',
305 "Inlining of constant doesn't change represenatation");
306
307delete $::{ga_shloip};
308
309eval 'sub ga_shloip (); 1' or die $@;
310is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
311
312# Check that a prototype expands.
313*{"ga_shloip"} = \&{"oonk"};
314
315is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
316is (eval 'ga_shloip', "Value", "Constant has correct value");
317is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
318
319
320@::zwot = ('Zwot!');
321
322# Check that assignment to an existing typeglob works
323{
324 my $w = '';
325 local $SIG{__WARN__} = sub { $w = $_[0] };
326 *{"zwot"} = \&{"oonk"};
327 is($w, '', "Should be no warning");
328}
329
330is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
331is (eval 'zwot', "Value", "Constant has correct value");
332is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
333is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
334
335sub spritsits () {
336 "Traditional";
337}
338
339# Check that assignment to an existing subroutine works
340{
341 my $w = '';
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");
346}
347
348is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
349is (eval 'spritsits', "Value", "Constant has correct value");
350is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
351
352my $result;
353# Check that assignment to an existing typeglob works
354{
355 my $w = '';
356 local $SIG{__WARN__} = sub { $w = $_[0] };
357 $result = *{"plunk"} = \&{"oonk"};
358 is($w, '', "Should be no warning");
359}
360
361is (ref \$result, 'GLOB',
362 "Non void assignment should still return a typeglob");
363
364is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
365is (eval 'plunk', "Value", "Constant has correct value");
366is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
367
368my $gr = eval '\*plunk' or die;
369
370{
371 my $w = '';
372 local $SIG{__WARN__} = sub { $w = $_[0] };
373 $result = *{$gr} = \&{"oonk"};
2111d928 374 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
375}
376
377is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
378is (eval 'plunk', "Value", "Constant has correct value");
379is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
380
5c1f4d79
NC
381format =
382.
383
384foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
385 # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
386 # IO::Handle, which isn't what we want.
387 my $type = $value;
388 $type =~ s/.*=//;
389 $type =~ s/\(.*//;
390 delete $::{oonk};
391 $::{oonk} = $value;
392 $proto = eval 'prototype \&oonk';
393 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
394 "Cannot upgrade ref-to-$type to typeglob");
395}
f9d52e31
NC
396
397{
398 no warnings qw(once uninitialized);
399 my $g = \*clatter;
400 my $r = eval {no strict; ${*{$g}{SCALAR}}};
401 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
402
403 $g = \*vowm;
404 $r = eval {use strict; ${*{$g}{SCALAR}}};
405 is ($@, '',
406 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
407}
408
99491443 409__END__
98e007d4
NC
410Perl
411Rules
412perl
413rocks