This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid an assertion failure when overloading readpipe.
[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 => 160 );
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     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     }
120 }
121
122 my $test = curr_test();
123 # test *glob{THING} syntax
124 $x = "ok $test\n";
125 ++$test;
126 @x = ("ok $test\n");
127 ++$test;
128 %x = ("ok $test" => "\n");
129 ++$test;
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
133 # value of test
134 ++$test;
135 format x =
136 XXX This text isn't used. Should it be?
137 .
138 curr_test($test);
139
140 is (ref *x{FORMAT}, "FORMAT");
141 *x = *STDOUT;
142 is (*{*x{GLOB}}, "*main::STDOUT");
143
144 {
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);
158 }
159
160
161 {
162     # test if defined() doesn't create any new symbols
163
164     my $a = "SYM000";
165     ok(!defined *{$a});
166
167     ok(!defined @{$a});
168     ok(!defined *{$a});
169
170     ok(!defined %{$a});
171     ok(!defined *{$a});
172
173     ok(!defined ${$a});
174     ok(!defined *{$a});
175
176     ok(!defined &{$a});
177     ok(!defined *{$a});
178
179     my $state = "not";
180     *{$a} = sub { $state = "ok" };
181     ok(defined &{$a});
182     ok(defined *{$a});
183     &{$a};
184     is ($state, 'ok');
185 }
186
187 {
188     # although it *should* if you're talking about magicals
189
190     my $a = "]";
191     ok(defined ${$a});
192     ok(defined *{$a});
193
194     $a = "1";
195     "o" =~ /(o)/;
196     ok(${$a});
197     ok(defined *{$a});
198     $a = "2";
199     ok(!${$a});
200     ok(defined *{$a});
201     $a = "1x";
202     ok(!defined ${$a});
203     ok(!defined *{$a});
204     $a = "11";
205     "o" =~ /(((((((((((o)))))))))))/;
206     ok(${$a});
207     ok(defined *{$a});
208 }
209
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
214 is($j, 1);
215 is($j{a}, 1);
216 is($j[0], 1);
217
218 {
219     # does pp_readline() handle glob-ness correctly?
220     my $g = *foo;
221     $g = <DATA>;
222     is ($g, "Perl\n");
223 }
224
225 {
226     my $w = '';
227     local $SIG{__WARN__} = sub { $w = $_[0] };
228     sub abc1 ();
229     local *abc1 = sub { };
230     is ($w, '');
231     sub abc2 ();
232     local *abc2;
233     *abc2 = sub { };
234     is ($w, '');
235     sub abc3 ();
236     *abc3 = sub { };
237     like ($w, qr/Prototype mismatch/);
238 }
239
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>;
246     is ($x, "Rules\n");
247 }
248
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);
256     is ($v, '*main::DATA');
257     my $x = <$v>;
258     is ($x, "perl\n");
259 }
260
261 {
262     $e = '';
263     # GLOB assignment to tied element
264     local $SIG{__DIE__} = sub { $e = $_[0] };
265     sub T::TIEARRAY  { bless [] => "T" }
266     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
267     sub T::FETCH     { $_[0]->[ $_[1] ] }
268     sub T::FETCHSIZE { @{$_[0]} }
269     tie my @ary => "T";
270     $ary[0] = *DATA;
271     is ($ary[0], '*main::DATA');
272     is ($e, '');
273     my $x = readline $ary[0];
274     is($x, "rocks\n");
275 }
276
277 {
278     # Need some sort of die or warn to get the global destruction text if the
279     # bug is still present
280     my $output = runperl(prog => <<'EOPROG');
281 package M;
282 $| = 1;
283 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
284 package main;
285
286 bless \$A::B, 'M';
287 *A:: = \*B::;
288 EOPROG
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 }
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
298 foreach (qw (oonk ga_shloip)) {
299     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
300 }
301
302 # A string in place of the typeglob is promoted to the function prototype
303 $::{oonk} = "pie";
304 my $proto = eval 'prototype \&oonk';
305 die if $@;
306 is ($proto, "pie", "String is promoted to prototype");
307
308
309 # A reference to a value is used to generate a constant subroutine
310 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
311                    \*STDIN, \&ok, \undef, *STDOUT) {
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 $@;
320     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
321     is ($got, $value, "Value is correctly set");
322 }
323
324 delete $::{oonk};
325 $::{oonk} = \"Value";
326
327 *{"ga_shloip"} = \&{"oonk"};
328
329 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
330 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
331 is (eval 'ga_shloip', "Value", "Constant has correct value");
332 is (ref $::{ga_shloip}, 'SCALAR',
333     "Inlining of constant doesn't change represenatation");
334
335 delete $::{ga_shloip};
336
337 eval 'sub ga_shloip (); 1' or die $@;
338 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
339
340 # Check that a prototype expands.
341 *{"ga_shloip"} = \&{"oonk"};
342
343 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
344 is (eval 'ga_shloip', "Value", "Constant has correct value");
345 is (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
358 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
359 is (eval 'zwot', "Value", "Constant has correct value");
360 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
361 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
362
363 sub 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
376 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
377 is (eval 'spritsits', "Value", "Constant has correct value");
378 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
379
380 my $result;
381 # Check that assignment to an existing typeglob works
382 {
383   my $w = '';
384   local $SIG{__WARN__} = sub { $w = $_[0] };
385   $result = *{"plunk"} = \&{"oonk"};
386   is($w, '', "Should be no warning");
387 }
388
389 is (ref \$result, 'GLOB',
390     "Non void assignment should still return a typeglob");
391
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");
395
396 my $gr = eval '\*plunk' or die;
397
398 {
399   my $w = '';
400   local $SIG{__WARN__} = sub { $w = $_[0] };
401   $result = *{$gr} = \&{"oonk"};
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)");
403 }
404
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");
408
409 {
410     use vars qw($glook $smek $foof);
411     # Check reference assignment isn't affected by the SV type (bug #38439)
412     $glook = 3;
413     $smek = 4;
414     $foof = "halt and cool down";
415
416     my $rv = \*smek;
417     is($glook, 3);
418     *glook = $rv;
419     is($glook, 4);
420
421     my $pv = "";
422     $pv = \*smek;
423     is($foof, "halt and cool down");
424     *foof = $pv;
425     is($foof, 4);
426 }
427
428 format =
429 .
430
431 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
432     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
433     # IO::Handle, which isn't what we want.
434     my $type = $value;
435     $type =~ s/.*=//;
436     $type =~ s/\(.*//;
437     delete $::{oonk};
438     $::{oonk} = $value;
439     $proto = eval 'prototype \&oonk';
440     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
441           "Cannot upgrade ref-to-$type to typeglob");
442 }
443
444 {
445     no warnings qw(once uninitialized);
446     my $g = \*clatter;
447     my $r = eval {no strict; ${*{$g}{SCALAR}}};
448     is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
449
450     $g = \*vowm;
451     $r = eval {use strict; ${*{$g}{SCALAR}}};
452     is ($@, '',
453         "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
454 }
455
456 {
457     # Bug reported by broquaint on IRC
458     *slosh::{HASH}->{ISA}=[];
459     slosh->import;
460     pass("gv_fetchmeth coped with the unexpected");
461
462     # An audit found these:
463     {
464         package slosh;
465         sub rip {
466             my $s = shift;
467             $s->SUPER::rip;
468         }
469     }
470     eval {slosh->rip;};
471     like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
472
473     is(slosh->isa('swoosh'), '');
474
475     $CORE::GLOBAL::{"lock"}=[];
476     eval "no warnings; lock";
477     like($@, qr/^Not enough arguments for lock/,
478        "Can't trip up general keyword overloading");
479
480     $CORE::GLOBAL::{"readline"}=[];
481     eval "no warnings; <STDOUT>";
482     is($@, '', "Can't trip up readline overloading");
483
484     $CORE::GLOBAL::{"readpipe"}=[];
485     eval "`` if 0";
486     is($@, '', "Can't trip up readpipe overloading");
487 }
488 __END__
489 Perl
490 Rules
491 perl
492 rocks