Commit | Line | Data |
---|---|---|
b9894134 | 1 | #!./perl |
2 | ||
3 | # | |
4 | # various typeglob tests | |
5 | # | |
6 | ||
9f1b1f2d GS |
7 | BEGIN { |
8 | chdir 't' if -d 't'; | |
20822f61 | 9 | @INC = '../lib'; |
98e007d4 | 10 | } |
9f1b1f2d GS |
11 | |
12 | use warnings; | |
13 | ||
98e007d4 | 14 | require './test.pl'; |
50baa5ea | 15 | plan( tests => 178 ); |
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 NC |
26 | ok($foo); |
27 | is(ref(\$foo), 'GLOB'); | |
b9894134 | 28 | |
98e007d4 NC |
29 | unlike ($foo, qr/abcd/); |
30 | is(ref(\$foo), 'GLOB'); | |
b9894134 | 31 | |
98e007d4 NC |
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 NC |
41 | is($a, 'main::foo'); |
42 | is(ref(\$b), 'GLOB'); | |
b9894134 | 43 | |
44 | # typeglobs as lvalues | |
45 | substr($foo, 0, 1) = "XXX"; | |
98e007d4 NC |
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 NC |
57 | ok(defined $fuu); |
58 | is(ref(\$fuu), 'GLOB'); | |
b9894134 | 59 | |
98e007d4 NC |
60 | |
61 | ok(defined $baa); | |
62 | is(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 |
70 | ok(exists $Foo::{'Bar::'}); |
71 | is($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); | |
78 | undef *foo; | |
98e007d4 NC |
79 | is ($foo, undef); |
80 | is (scalar @foo, 0); | |
81 | is (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/); |
e36cc0fb NC |
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 NC |
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 NC |
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 NC |
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 NC |
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 JH |
158 | } |
159 | ||
35cd451c GS |
160 | |
161 | { | |
98e007d4 | 162 | # test if defined() doesn't create any new symbols |
35cd451c GS |
163 | |
164 | my $a = "SYM000"; | |
98e007d4 | 165 | ok(!defined *{$a}); |
35cd451c | 166 | |
98e007d4 NC |
167 | ok(!defined @{$a}); |
168 | ok(!defined *{$a}); | |
35cd451c | 169 | |
98e007d4 NC |
170 | ok(!defined %{$a}); |
171 | ok(!defined *{$a}); | |
35cd451c | 172 | |
98e007d4 NC |
173 | ok(!defined ${$a}); |
174 | ok(!defined *{$a}); | |
35cd451c | 175 | |
98e007d4 NC |
176 | ok(!defined &{$a}); |
177 | ok(!defined *{$a}); | |
35cd451c | 178 | |
98e007d4 NC |
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 GS |
189 | |
190 | my $a = "]"; | |
98e007d4 NC |
191 | ok(defined ${$a}); |
192 | ok(defined *{$a}); | |
c9d5ac95 GS |
193 | |
194 | $a = "1"; | |
195 | "o" =~ /(o)/; | |
98e007d4 NC |
196 | ok(${$a}); |
197 | ok(defined *{$a}); | |
c9d5ac95 | 198 | $a = "2"; |
98e007d4 NC |
199 | ok(!${$a}); |
200 | ok(defined *{$a}); | |
c9d5ac95 | 201 | $a = "1x"; |
98e007d4 NC |
202 | ok(!defined ${$a}); |
203 | ok(!defined *{$a}); | |
c9d5ac95 GS |
204 | $a = "11"; |
205 | "o" =~ /(((((((((((o)))))))))))/; | |
98e007d4 NC |
206 | ok(${$a}); |
207 | ok(defined *{$a}); | |
c9d5ac95 GS |
208 | } |
209 | ||
bd2155e9 JH |
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 NC |
214 | is($j, 1); |
215 | is($j{a}, 1); | |
216 | is($j[0], 1); | |
99491443 GS |
217 | |
218 | { | |
98e007d4 | 219 | # does pp_readline() handle glob-ness correctly? |
99491443 GS |
220 | my $g = *foo; |
221 | $g = <DATA>; | |
98e007d4 | 222 | is ($g, "Perl\n"); |
99491443 GS |
223 | } |
224 | ||
fb24441d RGS |
225 | { |
226 | my $w = ''; | |
bb112e5a | 227 | local $SIG{__WARN__} = sub { $w = $_[0] }; |
fb24441d RGS |
228 | sub abc1 (); |
229 | local *abc1 = sub { }; | |
98e007d4 | 230 | is ($w, ''); |
fb24441d RGS |
231 | sub abc2 (); |
232 | local *abc2; | |
233 | *abc2 = sub { }; | |
98e007d4 | 234 | is ($w, ''); |
fb24441d RGS |
235 | sub abc3 (); |
236 | *abc3 = sub { }; | |
98e007d4 | 237 | like ($w, qr/Prototype mismatch/); |
fb24441d RGS |
238 | } |
239 | ||
2b5e58c4 AMS |
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 AMS |
247 | } |
248 | ||
4ce457a6 TP |
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 TP |
259 | } |
260 | ||
98e007d4 NC |
261 | { |
262 | $e = ''; | |
4ce457a6 TP |
263 | # GLOB assignment to tied element |
264 | local $SIG{__DIE__} = sub { $e = $_[0] }; | |
98e007d4 NC |
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 TP |
269 | tie my @ary => "T"; |
270 | $ary[0] = *DATA; | |
98e007d4 NC |
271 | is ($ary[0], '*main::DATA'); |
272 | is ($e, ''); | |
4ce457a6 | 273 | my $x = readline $ary[0]; |
98e007d4 | 274 | is($x, "rocks\n"); |
4ce457a6 TP |
275 | } |
276 | ||
e15faf7d | 277 | { |
4184c77b NC |
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 | 281 | package M; |
5c2a9b31 | 282 | $| = 1; |
4184c77b | 283 | sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} |
e15faf7d NC |
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 | } | |
63fa9adc NC |
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 NC |
298 | foreach (qw (oonk ga_shloip)) { |
299 | ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); | |
300 | } | |
63fa9adc NC |
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}, | |
5c1f4d79 | 311 | \*STDIN, \&ok, \undef, *STDOUT) { |
63fa9adc NC |
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 NC |
321 | is ($got, $value, "Value is correctly set"); |
322 | } | |
5c1f4d79 | 323 | |
bb112e5a NC |
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 | ||
bb112e5a NC |
380 | # Check that assignment to an existing typeglob works |
381 | { | |
382 | my $w = ''; | |
383 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
50baa5ea VP |
384 | *{"plunk"} = []; |
385 | *{"plunk"} = \&{"oonk"}; | |
bb112e5a NC |
386 | is($w, '', "Should be no warning"); |
387 | } | |
388 | ||
bb112e5a NC |
389 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); |
390 | is (eval 'plunk', "Value", "Constant has correct value"); | |
391 | is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); | |
392 | ||
393 | my $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 NC |
400 | } |
401 | ||
402 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); | |
403 | is (eval 'plunk', "Value", "Constant has correct value"); | |
404 | is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); | |
405 | ||
50baa5ea VP |
406 | # Non-void context should defeat the optimisation, and will cause the original |
407 | # to be promoted (what change 26482 intended) | |
408 | my $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 | ||
416 | is (ref \$result, 'GLOB', | |
417 | "Non void assignment should still return a typeglob"); | |
418 | ||
419 | is (ref \$::{oonk}, 'GLOB', "This export does affect original"); | |
420 | is (eval 'plunk', "Value", "Constant has correct value"); | |
421 | is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); | |
422 | ||
423 | delete $::{oonk}; | |
424 | $::{oonk} = \"Value"; | |
425 | ||
426 | sub non_dangling { | |
427 | my $w = ''; | |
428 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
429 | *{"zap"} = \&{"oonk"}; | |
430 | is($w, '', "Should be no warning"); | |
431 | } | |
432 | ||
433 | non_dangling(); | |
434 | is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); | |
435 | is (eval 'zap', "Value", "Constant has correct value"); | |
436 | is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS"); | |
437 | ||
438 | sub dangling { | |
439 | local $SIG{__WARN__} = sub { die $_[0] }; | |
440 | *{"biff"} = \&{"oonk"}; | |
441 | } | |
442 | ||
443 | dangling(); | |
444 | is (ref \$::{oonk}, 'GLOB', "This export does affect original"); | |
445 | is (eval 'biff', "Value", "Constant has correct value"); | |
446 | is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob"); | |
447 | ||
acaa9288 NC |
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 NC |
467 | format = |
468 | . | |
469 | ||
470 | foreach 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 NC |
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 NC |
495 | { |
496 | # Bug reported by broquaint on IRC | |
497 | *slosh::{HASH}->{ISA}=[]; | |
498 | slosh->import; | |
499 | pass("gv_fetchmeth coped with the unexpected"); | |
9e0d86f8 NC |
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 NC |
522 | |
523 | $CORE::GLOBAL::{"readpipe"}=[]; | |
524 | eval "`` if 0"; | |
525 | is($@, '', "Can't trip up readpipe overloading"); | |
06be3b40 | 526 | } |
53a42478 NC |
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 NC |
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 | ||
541 | sub coerce_integer { | |
542 | no warnings 'numeric'; | |
543 | $_[0] |= 0; | |
544 | } | |
545 | sub coerce_number { | |
546 | no warnings 'numeric'; | |
547 | $_[0] += 0; | |
548 | } | |
549 | sub coerce_string { | |
550 | $_[0] .= ''; | |
551 | } | |
552 | ||
553 | foreach 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 NC |
561 | Perl |
562 | Rules | |
563 | perl | |
564 | rocks |