This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Code assumes that *FOO{SCALAR} will always return a scalar reference,
[perl5.git] / t / op / gv.t
1 #!./perl
2
3 #
4 # various typeglob tests
5 #
6
7 BEGIN {
8     chdir 't' if -d 't';
9     @INC = '../lib';
10 }
11
12 use warnings;
13
14 require './test.pl';
15 plan( tests => 134 );
16
17 # type coersion on assignment
18 $foo = 'foo';
19 $bar = *main::foo;
20 $bar = $foo;
21 is(ref(\$bar), 'SCALAR');
22 $foo = *main::bar;
23
24 # type coersion (not) on misc ops
25
26 ok($foo);
27 is(ref(\$foo), 'GLOB');
28
29 unlike ($foo, qr/abcd/);
30 is(ref(\$foo), 'GLOB');
31
32 is($foo, '*main::bar');
33 is(ref(\$foo), 'GLOB');
34
35 # type coersion on substitutions that match
36 $a = *main::foo;
37 $b = $a;
38 $a =~ s/^X//;
39 is(ref(\$a), 'GLOB');
40 $a =~ s/^\*//;
41 is($a, 'main::foo');
42 is(ref(\$b), 'GLOB');
43
44 # typeglobs as lvalues
45 substr($foo, 0, 1) = "XXX";
46 is(ref(\$foo), 'SCALAR');
47 is($foo, 'XXXmain::bar');
48
49 # returning glob values
50 sub foo {
51   local($bar) = *main::foo;
52   $foo = *main::bar;
53   return ($foo, $bar);
54 }
55
56 ($fuu, $baa) = foo();
57 ok(defined $fuu);
58 is(ref(\$fuu), 'GLOB');
59
60
61 ok(defined $baa);
62 is(ref(\$baa), 'GLOB');
63
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
69 { package Foo::Bar; no warnings 'once'; $test=1; }
70 ok(exists $Foo::{'Bar::'});
71 is($Foo::{'Bar::'}, '*Foo::Bar::');
72
73
74 # test undef operator clearing out entire glob
75 $foo = 'stuff';
76 @foo = qw(more stuff);
77 %foo = qw(even more random stuff);
78 undef *foo;
79 is ($foo, undef);
80 is (scalar @foo, 0);
81 is (scalar %foo, 0);
82
83 {
84     # test warnings from assignment of undef to glob
85     my $msg = '';
86     local $SIG{__WARN__} = sub { $msg = $_[0] };
87     use warnings;
88     *foo = 'bar';
89     is($msg, '');
90     *foo = undef;
91     like($msg, qr/Undefined value assigned to typeglob/);
92 }
93
94 my $test = curr_test();
95 # test *glob{THING} syntax
96 $x = "ok $test\n";
97 ++$test;
98 @x = ("ok $test\n");
99 ++$test;
100 %x = ("ok $test" => "\n");
101 ++$test;
102 sub x { "ok $test\n" }
103 print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
104 # This needs to go here, after the print, as sub x will return the current
105 # value of test
106 ++$test;
107 format x =
108 XXX This text isn't used. Should it be?
109 .
110 curr_test($test);
111
112 is (ref *x{FORMAT}, "FORMAT");
113 *x = *STDOUT;
114 is (*{*x{GLOB}}, "*main::STDOUT");
115
116 {
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);
130 }
131
132
133 {
134     # test if defined() doesn't create any new symbols
135
136     my $a = "SYM000";
137     ok(!defined *{$a});
138
139     ok(!defined @{$a});
140     ok(!defined *{$a});
141
142     ok(!defined %{$a});
143     ok(!defined *{$a});
144
145     ok(!defined ${$a});
146     ok(!defined *{$a});
147
148     ok(!defined &{$a});
149     ok(!defined *{$a});
150
151     my $state = "not";
152     *{$a} = sub { $state = "ok" };
153     ok(defined &{$a});
154     ok(defined *{$a});
155     &{$a};
156     is ($state, 'ok');
157 }
158
159 {
160     # although it *should* if you're talking about magicals
161
162     my $a = "]";
163     ok(defined ${$a});
164     ok(defined *{$a});
165
166     $a = "1";
167     "o" =~ /(o)/;
168     ok(${$a});
169     ok(defined *{$a});
170     $a = "2";
171     ok(!${$a});
172     ok(defined *{$a});
173     $a = "1x";
174     ok(!defined ${$a});
175     ok(!defined *{$a});
176     $a = "11";
177     "o" =~ /(((((((((((o)))))))))))/;
178     ok(${$a});
179     ok(defined *{$a});
180 }
181
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
186 is($j, 1);
187 is($j{a}, 1);
188 is($j[0], 1);
189
190 {
191     # does pp_readline() handle glob-ness correctly?
192     my $g = *foo;
193     $g = <DATA>;
194     is ($g, "Perl\n");
195 }
196
197 {
198     my $w = '';
199     local $SIG{__WARN__} = sub { $w = $_[0] };
200     sub abc1 ();
201     local *abc1 = sub { };
202     is ($w, '');
203     sub abc2 ();
204     local *abc2;
205     *abc2 = sub { };
206     is ($w, '');
207     sub abc3 ();
208     *abc3 = sub { };
209     like ($w, qr/Prototype mismatch/);
210 }
211
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>;
218     is ($x, "Rules\n");
219 }
220
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);
228     is ($v, '*main::DATA');
229     my $x = <$v>;
230     is ($x, "perl\n");
231 }
232
233 {
234     $e = '';
235     # GLOB assignment to tied element
236     local $SIG{__DIE__} = sub { $e = $_[0] };
237     sub T::TIEARRAY  { bless [] => "T" }
238     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
239     sub T::FETCH     { $_[0]->[ $_[1] ] }
240     sub T::FETCHSIZE { @{$_[0]} }
241     tie my @ary => "T";
242     $ary[0] = *DATA;
243     is ($ary[0], '*main::DATA');
244     is ($e, '');
245     my $x = readline $ary[0];
246     is($x, "rocks\n");
247 }
248
249 {
250     # Need some sort of die or warn to get the global destruction text if the
251     # bug is still present
252     my $output = runperl(prog => <<'EOPROG');
253 package M;
254 $| = 1;
255 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
256 package main;
257
258 bless \$A::B, 'M';
259 *A:: = \*B::;
260 EOPROG
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 }
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
270 foreach (qw (oonk ga_shloip)) {
271     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
272 }
273
274 # A string in place of the typeglob is promoted to the function prototype
275 $::{oonk} = "pie";
276 my $proto = eval 'prototype \&oonk';
277 die if $@;
278 is ($proto, "pie", "String is promoted to prototype");
279
280
281 # A reference to a value is used to generate a constant subroutine
282 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
283                    \*STDIN, \&ok, \undef, *STDOUT) {
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 $@;
292     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
293     is ($got, $value, "Value is correctly set");
294 }
295
296 delete $::{oonk};
297 $::{oonk} = \"Value";
298
299 *{"ga_shloip"} = \&{"oonk"};
300
301 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
302 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
303 is (eval 'ga_shloip', "Value", "Constant has correct value");
304 is (ref $::{ga_shloip}, 'SCALAR',
305     "Inlining of constant doesn't change represenatation");
306
307 delete $::{ga_shloip};
308
309 eval 'sub ga_shloip (); 1' or die $@;
310 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
311
312 # Check that a prototype expands.
313 *{"ga_shloip"} = \&{"oonk"};
314
315 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
316 is (eval 'ga_shloip', "Value", "Constant has correct value");
317 is (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
330 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
331 is (eval 'zwot', "Value", "Constant has correct value");
332 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
333 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
334
335 sub 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
348 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
349 is (eval 'spritsits', "Value", "Constant has correct value");
350 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
351
352 my $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
361 is (ref \$result, 'GLOB',
362     "Non void assignment should still return a typeglob");
363
364 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
365 is (eval 'plunk', "Value", "Constant has correct value");
366 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
367
368 my $gr = eval '\*plunk' or die;
369
370 {
371   my $w = '';
372   local $SIG{__WARN__} = sub { $w = $_[0] };
373   $result = *{$gr} = \&{"oonk"};
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)");
375 }
376
377 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
378 is (eval 'plunk', "Value", "Constant has correct value");
379 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
380
381 format =
382 .
383
384 foreach 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 }
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
409 __END__
410 Perl
411 Rules
412 perl
413 rocks