Commit | Line | Data |
b9894134 |
1 | #!./perl |
2 | |
3 | # |
4 | # various typeglob tests |
5 | # |
6 | |
9f1b1f2d |
7 | BEGIN { |
8 | chdir 't' if -d 't'; |
20822f61 |
9 | @INC = '../lib'; |
98e007d4 |
10 | } |
9f1b1f2d |
11 | |
12 | use warnings; |
13 | |
98e007d4 |
14 | require './test.pl'; |
2867cdbc |
15 | plan( tests => 188 ); |
b9894134 |
16 | |
17 | # type coersion on assignment |
18 | $foo = 'foo'; |
19 | $bar = *main::foo; |
20 | $bar = $foo; |
98e007d4 |
21 | is(ref(\$bar), 'SCALAR'); |
b9894134 |
22 | $foo = *main::bar; |
23 | |
24 | # type coersion (not) on misc ops |
25 | |
98e007d4 |
26 | ok($foo); |
27 | is(ref(\$foo), 'GLOB'); |
b9894134 |
28 | |
98e007d4 |
29 | unlike ($foo, qr/abcd/); |
30 | is(ref(\$foo), 'GLOB'); |
b9894134 |
31 | |
98e007d4 |
32 | is($foo, '*main::bar'); |
33 | is(ref(\$foo), 'GLOB'); |
b9894134 |
34 | |
35 | # type coersion on substitutions that match |
36 | $a = *main::foo; |
37 | $b = $a; |
38 | $a =~ s/^X//; |
98e007d4 |
39 | is(ref(\$a), 'GLOB'); |
b9894134 |
40 | $a =~ s/^\*//; |
98e007d4 |
41 | is($a, 'main::foo'); |
42 | is(ref(\$b), 'GLOB'); |
b9894134 |
43 | |
44 | # typeglobs as lvalues |
45 | substr($foo, 0, 1) = "XXX"; |
98e007d4 |
46 | is(ref(\$foo), 'SCALAR'); |
47 | is($foo, 'XXXmain::bar'); |
b9894134 |
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(); |
98e007d4 |
57 | ok(defined $fuu); |
58 | is(ref(\$fuu), 'GLOB'); |
b9894134 |
59 | |
98e007d4 |
60 | |
61 | ok(defined $baa); |
62 | is(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 |
70 | ok(exists $Foo::{'Bar::'}); |
71 | is($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); |
78 | undef *foo; |
98e007d4 |
79 | is ($foo, undef); |
80 | is (scalar @foo, 0); |
81 | is (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 |
122 | my $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; |
130 | sub x { "ok $test\n" } |
640b9ef6 |
131 | print ${*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 |
135 | format x = |
98e007d4 |
136 | XXX This text isn't used. Should it be? |
f4d13ee9 |
137 | . |
98e007d4 |
138 | curr_test($test); |
139 | |
140 | is (ref *x{FORMAT}, "FORMAT"); |
640b9ef6 |
141 | *x = *STDOUT; |
98e007d4 |
142 | is (*{*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 | |
d47e1c27 |
170 | { |
171 | no warnings 'deprecated'; |
172 | ok(!defined %{$a}); |
173 | } |
98e007d4 |
174 | ok(!defined *{$a}); |
35cd451c |
175 | |
98e007d4 |
176 | ok(!defined ${$a}); |
177 | ok(!defined *{$a}); |
35cd451c |
178 | |
98e007d4 |
179 | ok(!defined &{$a}); |
180 | ok(!defined *{$a}); |
35cd451c |
181 | |
98e007d4 |
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 |
192 | |
193 | my $a = "]"; |
98e007d4 |
194 | ok(defined ${$a}); |
195 | ok(defined *{$a}); |
c9d5ac95 |
196 | |
197 | $a = "1"; |
198 | "o" =~ /(o)/; |
98e007d4 |
199 | ok(${$a}); |
200 | ok(defined *{$a}); |
c9d5ac95 |
201 | $a = "2"; |
98e007d4 |
202 | ok(!${$a}); |
203 | ok(defined *{$a}); |
c9d5ac95 |
204 | $a = "1x"; |
98e007d4 |
205 | ok(!defined ${$a}); |
206 | ok(!defined *{$a}); |
c9d5ac95 |
207 | $a = "11"; |
208 | "o" =~ /(((((((((((o)))))))))))/; |
98e007d4 |
209 | ok(${$a}); |
210 | ok(defined *{$a}); |
c9d5ac95 |
211 | } |
212 | |
bd2155e9 |
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 |
217 | is($j, 1); |
218 | is($j{a}, 1); |
219 | is($j[0], 1); |
99491443 |
220 | |
221 | { |
98e007d4 |
222 | # does pp_readline() handle glob-ness correctly? |
99491443 |
223 | my $g = *foo; |
224 | $g = <DATA>; |
98e007d4 |
225 | is ($g, "Perl\n"); |
99491443 |
226 | } |
227 | |
fb24441d |
228 | { |
229 | my $w = ''; |
bb112e5a |
230 | local $SIG{__WARN__} = sub { $w = $_[0] }; |
fb24441d |
231 | sub abc1 (); |
232 | local *abc1 = sub { }; |
98e007d4 |
233 | is ($w, ''); |
fb24441d |
234 | sub abc2 (); |
235 | local *abc2; |
236 | *abc2 = sub { }; |
98e007d4 |
237 | is ($w, ''); |
fb24441d |
238 | sub abc3 (); |
239 | *abc3 = sub { }; |
98e007d4 |
240 | like ($w, qr/Prototype mismatch/); |
fb24441d |
241 | } |
242 | |
2b5e58c4 |
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 |
250 | } |
251 | |
4ce457a6 |
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 |
262 | } |
263 | |
98e007d4 |
264 | { |
265 | $e = ''; |
4ce457a6 |
266 | # GLOB assignment to tied element |
267 | local $SIG{__DIE__} = sub { $e = $_[0] }; |
98e007d4 |
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 |
272 | tie my @ary => "T"; |
273 | $ary[0] = *DATA; |
98e007d4 |
274 | is ($ary[0], '*main::DATA'); |
275 | is ($e, ''); |
4ce457a6 |
276 | my $x = readline $ary[0]; |
98e007d4 |
277 | is($x, "rocks\n"); |
4ce457a6 |
278 | } |
279 | |
e15faf7d |
280 | { |
4184c77b |
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 |
284 | package M; |
5c2a9b31 |
285 | $| = 1; |
4184c77b |
286 | sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} |
e15faf7d |
287 | package main; |
288 | |
289 | bless \$A::B, 'M'; |
290 | *A:: = \*B::; |
291 | EOPROG |
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 |
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 |
301 | foreach (qw (oonk ga_shloip)) { |
302 | ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); |
303 | } |
63fa9adc |
304 | |
305 | # A string in place of the typeglob is promoted to the function prototype |
306 | $::{oonk} = "pie"; |
307 | my $proto = eval 'prototype \&oonk'; |
308 | die if $@; |
309 | is ($proto, "pie", "String is promoted to prototype"); |
310 | |
311 | |
312 | # A reference to a value is used to generate a constant subroutine |
313 | foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2}, |
5c1f4d79 |
314 | \*STDIN, \&ok, \undef, *STDOUT) { |
63fa9adc |
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 |
324 | is ($got, $value, "Value is correctly set"); |
325 | } |
5c1f4d79 |
326 | |
bb112e5a |
327 | delete $::{oonk}; |
328 | $::{oonk} = \"Value"; |
329 | |
330 | *{"ga_shloip"} = \&{"oonk"}; |
331 | |
332 | is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is"); |
333 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); |
334 | is (eval 'ga_shloip', "Value", "Constant has correct value"); |
335 | is (ref $::{ga_shloip}, 'SCALAR', |
336 | "Inlining of constant doesn't change represenatation"); |
337 | |
338 | delete $::{ga_shloip}; |
339 | |
340 | eval 'sub ga_shloip (); 1' or die $@; |
341 | is ($::{ga_shloip}, '', "Prototype is stored as an empty string"); |
342 | |
343 | # Check that a prototype expands. |
344 | *{"ga_shloip"} = \&{"oonk"}; |
345 | |
346 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); |
347 | is (eval 'ga_shloip', "Value", "Constant has correct value"); |
348 | is (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 | |
361 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); |
362 | is (eval 'zwot', "Value", "Constant has correct value"); |
363 | is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob"); |
364 | is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob"); |
365 | |
366 | sub 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 | |
379 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); |
380 | is (eval 'spritsits', "Value", "Constant has correct value"); |
381 | is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob"); |
382 | |
bb112e5a |
383 | # Check that assignment to an existing typeglob works |
384 | { |
385 | my $w = ''; |
386 | local $SIG{__WARN__} = sub { $w = $_[0] }; |
50baa5ea |
387 | *{"plunk"} = []; |
388 | *{"plunk"} = \&{"oonk"}; |
bb112e5a |
389 | is($w, '', "Should be no warning"); |
390 | } |
391 | |
bb112e5a |
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] }; |
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 |
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 | |
50baa5ea |
409 | # Non-void context should defeat the optimisation, and will cause the original |
410 | # to be promoted (what change 26482 intended) |
411 | my $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 | |
419 | is (ref \$result, 'GLOB', |
420 | "Non void assignment should still return a typeglob"); |
421 | |
422 | is (ref \$::{oonk}, 'GLOB', "This export does affect original"); |
423 | is (eval 'plunk', "Value", "Constant has correct value"); |
424 | is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); |
425 | |
426 | delete $::{oonk}; |
427 | $::{oonk} = \"Value"; |
428 | |
429 | sub non_dangling { |
430 | my $w = ''; |
431 | local $SIG{__WARN__} = sub { $w = $_[0] }; |
432 | *{"zap"} = \&{"oonk"}; |
433 | is($w, '', "Should be no warning"); |
434 | } |
435 | |
436 | non_dangling(); |
437 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); |
438 | is (eval 'zap', "Value", "Constant has correct value"); |
439 | is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS"); |
440 | |
441 | sub dangling { |
442 | local $SIG{__WARN__} = sub { die $_[0] }; |
443 | *{"biff"} = \&{"oonk"}; |
444 | } |
445 | |
446 | dangling(); |
447 | is (ref \$::{oonk}, 'GLOB', "This export does affect original"); |
448 | is (eval 'biff', "Value", "Constant has correct value"); |
449 | is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob"); |
450 | |
acaa9288 |
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 |
470 | format = |
471 | . |
472 | |
473 | foreach 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 |
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 |
498 | { |
499 | # Bug reported by broquaint on IRC |
500 | *slosh::{HASH}->{ISA}=[]; |
501 | slosh->import; |
502 | pass("gv_fetchmeth coped with the unexpected"); |
9e0d86f8 |
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 |
525 | |
526 | $CORE::GLOBAL::{"readpipe"}=[]; |
527 | eval "`` if 0"; |
528 | is($@, '', "Can't trip up readpipe overloading"); |
06be3b40 |
529 | } |
53a42478 |
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 |
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 | |
544 | sub coerce_integer { |
545 | no warnings 'numeric'; |
546 | $_[0] |= 0; |
547 | } |
548 | sub coerce_number { |
549 | no warnings 'numeric'; |
550 | $_[0] += 0; |
551 | } |
552 | sub coerce_string { |
553 | $_[0] .= ''; |
554 | } |
555 | |
556 | foreach 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 |
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 |
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 |
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 | } |
610 | ok(exists($RT72740a::{s1}), "RT72740a::s1 exists"); |
611 | ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist"); |
612 | ok(exists($RT72740a::{s3}), "RT72740a::s3 exists"); |
613 | ok(exists($RT72740a::{s4}), "RT72740a::s4 exists"); |
614 | is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly"); |
615 | is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly"); |
616 | |
99491443 |
617 | __END__ |
98e007d4 |
618 | Perl |
619 | Rules |
620 | perl |
621 | rocks |