Commit | Line | Data |
---|---|---|
47ac839d FC |
1 | #!./perl |
2 | ||
3 | # This file tests the results of calling subroutines in the CORE:: | |
4 | # namespace with ampersand syntax. In other words, it tests the bodies of | |
5 | # the subroutines themselves, not the ops that they might inline themselves | |
6 | # as when called as barewords. | |
7 | ||
bfce6a3e | 8 | # Other tests for CORE subs are in coresubs.t |
47ac839d FC |
9 | |
10 | BEGIN { | |
11 | chdir 't' if -d 't'; | |
12 | @INC = qw(. ../lib); | |
13 | require "test.pl"; | |
14 | $^P |= 0x100; | |
15 | } | |
47ac839d FC |
16 | |
17 | sub lis($$;$) { | |
18 | &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]); | |
19 | } | |
20 | ||
17008668 FC |
21 | package hov { |
22 | use overload '%{}' => sub { +{} } | |
23 | } | |
24 | package sov { | |
25 | use overload '${}' => sub { \my $x } | |
26 | } | |
27 | ||
47ac839d | 28 | my %op_desc = ( |
7d789282 | 29 | evalbytes=> 'eval "string"', |
47ac839d | 30 | join => 'join or string', |
1efec5ed | 31 | pos => 'match position', |
919ad5f7 | 32 | prototype=> 'subroutine prototype', |
47ac839d FC |
33 | readline => '<HANDLE>', |
34 | readpipe => 'quoted execution (``, qx)', | |
f650fa72 | 35 | reset => 'symbol reset', |
47ac839d | 36 | ref => 'reference-type operator', |
46bef06f | 37 | undef => 'undef operator', |
47ac839d FC |
38 | ); |
39 | sub op_desc($) { | |
40 | return $op_desc{$_[0]} || $_[0]; | |
41 | } | |
42 | ||
43 | ||
44 | # This tests that the &{} syntax respects the number of arguments implied | |
45 | # by the prototype, plus some extra tests for the (_) prototype. | |
46 | sub test_proto { | |
47 | my($o) = shift; | |
48 | ||
49 | # Create an alias, for the caller’s convenience. | |
50 | *{"my$o"} = \&{"CORE::$o"}; | |
51 | ||
52 | my $p = prototype "CORE::$o"; | |
d6d78e19 | 53 | $p = '$;$' if $p eq '$_'; |
47ac839d FC |
54 | |
55 | if ($p eq '') { | |
56 | $tests ++; | |
57 | ||
58 | eval " &CORE::$o(1) "; | |
59 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
60 | ||
61 | } | |
498a02d8 | 62 | elsif ($p =~ /^_;?\z/) { |
47ac839d FC |
63 | $tests ++; |
64 | ||
65 | eval " &CORE::$o(1,2) "; | |
66 | my $desc = quotemeta op_desc($o); | |
67 | like $@, qr/^Too many arguments for $desc at /, | |
68 | "&$o with too many args"; | |
69 | ||
70 | if (!@_) { return } | |
71 | ||
72 | $tests += 6; | |
73 | ||
74 | my($in,$out) = @_; # for testing implied $_ | |
75 | ||
76 | # Since we have $in and $out values, we might as well test basic amper- | |
77 | # sand calls, too. | |
78 | ||
79 | is &{"CORE::$o"}($in), $out, "&$o"; | |
80 | lis [&{"CORE::$o"}($in)], [$out], "&$o in list context"; | |
81 | ||
82 | $_ = $in; | |
83 | is &{"CORE::$o"}(), $out, "&$o with no args"; | |
84 | ||
85 | # Since there is special code to deal with lexical $_, make sure it | |
86 | # works in all cases. | |
87 | undef $_; | |
88 | { | |
89 | my $_ = $in; | |
90 | is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_"; | |
91 | } | |
92 | # Make sure we get the right pad under recursion | |
93 | my $r; | |
94 | $r = sub { | |
95 | if($_[0]) { | |
96 | my $_ = $in; | |
97 | is &{"CORE::$o"}(), $out, | |
98 | "&$o with no args uses the right lexical \$_ under recursion"; | |
99 | } | |
100 | else { | |
101 | &$r(1) | |
102 | } | |
103 | }; | |
104 | &$r(0); | |
105 | my $_ = $in; | |
106 | eval { | |
107 | is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval" | |
108 | }; | |
109 | } | |
110 | elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc. | |
111 | my $maxargs = length $1; | |
112 | $tests += 1; | |
113 | eval " &CORE::$o((1)x($maxargs+1)) "; | |
114 | my $desc = quotemeta op_desc($o); | |
115 | like $@, qr/^Too many arguments for $desc at /, | |
116 | "&$o with too many args"; | |
117 | } | |
118 | elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or *** | |
119 | my $args = length $1; | |
120 | $tests += 2; | |
7d789282 | 121 | my $desc = quotemeta op_desc($o); |
47ac839d | 122 | eval " &CORE::$o((1)x($args-1)) "; |
7d789282 | 123 | like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args"; |
47ac839d | 124 | eval " &CORE::$o((1)x($args+1)) "; |
7d789282 | 125 | like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args"; |
47ac839d FC |
126 | } |
127 | elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or *** | |
128 | my $minargs = length $1; | |
129 | my $maxargs = $minargs + length $2; | |
130 | $tests += 2; | |
131 | eval " &CORE::$o((1)x($minargs-1)) "; | |
132 | like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; | |
133 | eval " &CORE::$o((1)x($maxargs+1)) "; | |
134 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
135 | } | |
136 | elsif ($p eq '_;$') { | |
137 | $tests += 1; | |
138 | ||
139 | eval " &CORE::$o(1,2,3) "; | |
140 | like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; | |
141 | } | |
142 | elsif ($p eq '@') { | |
143 | # Do nothing, as we cannot test for too few or too many arguments. | |
144 | } | |
145 | elsif ($p =~ '^[$*;]+@\z') { | |
146 | $tests ++; | |
147 | $p =~ ';@'; | |
148 | my $minargs = $-[0]; | |
149 | eval " &CORE::$o((1)x($minargs-1)) "; | |
150 | my $desc = quotemeta op_desc($o); | |
151 | like $@, qr/^Not enough arguments for $desc at /, | |
152 | "&$o with too few args"; | |
153 | } | |
17008668 FC |
154 | elsif ($p =~ /^\*\\\$\$(;?)\$\z/) { # *\$$$ and *\$$;$ |
155 | $tests += 5; | |
156 | ||
157 | eval "&CORE::$o(1,1,1,1,1)"; | |
158 | like $@, qr/^Too many arguments for $o at /, | |
159 | "&$o with too many args"; | |
160 | eval " &CORE::$o((1)x(\$1?2:3)) "; | |
161 | like $@, qr/^Not enough arguments for $o at /, | |
162 | "&$o with too few args"; | |
163 | eval " &CORE::$o(1,[],1,1) "; | |
164 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
165 | "&$o with array ref arg"; | |
166 | eval " &CORE::$o(1,1,1,1) "; | |
167 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
168 | "&$o with scalar arg"; | |
169 | eval " &CORE::$o(1,bless([], 'sov'),1,1) "; | |
170 | like $@, qr/^Type of arg 2 to &CORE::$o must be scalar reference at /, | |
171 | "&$o with non-scalar arg w/scalar overload (which does not count)"; | |
172 | } | |
47ac839d FC |
173 | elsif ($p =~ /^\\%\$*\z/) { # \% and \%$$ |
174 | $tests += 5; | |
175 | ||
176 | eval "&CORE::$o(" . join(",", (1) x length $p) . ")"; | |
177 | like $@, qr/^Too many arguments for $o at /, | |
178 | "&$o with too many args"; | |
179 | eval " &CORE::$o(" . join(",", (1) x (length($p)-2)) . ") "; | |
180 | like $@, qr/^Not enough arguments for $o at /, | |
181 | "&$o with too few args"; | |
182 | my $moreargs = ",1" x (length($p) - 2); | |
183 | eval " &CORE::$o([]$moreargs) "; | |
184 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
185 | "&$o with array ref arg"; | |
186 | eval " &CORE::$o(*foo$moreargs) "; | |
187 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
188 | "&$o with typeglob arg"; | |
189 | eval " &CORE::$o(bless([], 'hov')$moreargs) "; | |
190 | like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, | |
191 | "&$o with non-hash arg with hash overload (which does not count)"; | |
192 | } | |
46bef06f FC |
193 | elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) { |
194 | $tests += 3; | |
47ac839d | 195 | |
46bef06f | 196 | unless ($3) { |
efe889ae FC |
197 | $tests ++; |
198 | eval " &CORE::$o(1,2) "; | |
46bef06f | 199 | like $@, qr/^Too many arguments for ${\op_desc($o)} at /, |
efe889ae FC |
200 | "&$o with too many args"; |
201 | } | |
46bef06f FC |
202 | unless ($1) { |
203 | $tests ++; | |
204 | eval { &{"CORE::$o"}($3 ? 1 : ()) }; | |
205 | like $@, qr/^Not enough arguments for $o at /, | |
47ac839d | 206 | "&$o with too few args"; |
46bef06f FC |
207 | } |
208 | my $more_args = $3 ? ',1' : ''; | |
efe889ae | 209 | eval " &CORE::$o(2$more_args) "; |
47ac839d | 210 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
46bef06f | 211 | ) \[\Q$2\E] at /, |
47ac839d | 212 | "&$o with non-ref arg"; |
efe889ae | 213 | eval " &CORE::$o(*STDOUT{IO}$more_args) "; |
47ac839d | 214 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
46bef06f | 215 | ) \[\Q$2\E] at /, |
47ac839d FC |
216 | "&$o with ioref arg"; |
217 | my $class = ref *DATA{IO}; | |
efe889ae | 218 | eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) "; |
47ac839d | 219 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: |
46bef06f | 220 | ) \[\Q$2\E] at /, |
47ac839d FC |
221 | "&$o with ioref arg with hash overload (which does not count)"; |
222 | bless *DATA{IO}, $class; | |
46bef06f | 223 | if (do {$2 !~ /&/}) { |
efe889ae FC |
224 | $tests++; |
225 | eval " &CORE::$o(\\&scriggle$more_args) "; | |
226 | like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x: | |
46bef06f | 227 | )of \[\Q$2\E] at /, |
efe889ae FC |
228 | "&$o with coderef arg"; |
229 | } | |
47ac839d | 230 | } |
1efec5ed FC |
231 | elsif ($p eq ';\[$*]') { |
232 | $tests += 4; | |
233 | ||
234 | my $desc = quotemeta op_desc($o); | |
235 | eval " &CORE::$o(1,2) "; | |
236 | like $@, qr/^Too many arguments for $desc at /, | |
237 | "&$o with too many args"; | |
238 | eval " &CORE::$o([]) "; | |
239 | like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, | |
240 | "&$o with array ref arg"; | |
241 | eval " &CORE::$o(1) "; | |
242 | like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, | |
243 | "&$o with scalar arg"; | |
244 | eval " &CORE::$o(bless([], 'sov')) "; | |
245 | like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, | |
246 | "&$o with non-scalar arg w/scalar overload (which does not count)"; | |
247 | } | |
47ac839d FC |
248 | |
249 | else { | |
250 | die "Please add tests for the $p prototype"; | |
251 | } | |
252 | } | |
253 | ||
0e80230d FC |
254 | # Test that &CORE::foo calls without parentheses (no new @_) can handle the |
255 | # total absence of any @_ without crashing. | |
256 | undef *_; | |
257 | &CORE::wantarray; | |
258 | $tests++; | |
259 | pass('no crash with &CORE::foo when *_{ARRAY} is undef'); | |
260 | ||
47ac839d FC |
261 | test_proto '__FILE__'; |
262 | test_proto '__LINE__'; | |
263 | test_proto '__PACKAGE__'; | |
84ed0108 | 264 | test_proto '__SUB__'; |
47ac839d FC |
265 | |
266 | is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests; | |
267 | is line(), 5 , '__LINE__ does check its caller' ; ++ $tests; | |
268 | is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests; | |
84ed0108 FC |
269 | sub __SUB__test { &my__SUB__ } |
270 | is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests; | |
47ac839d FC |
271 | |
272 | test_proto 'abs', -5, 5; | |
273 | ||
274 | test_proto 'accept'; | |
275 | $tests += 6; eval q{ | |
276 | is &CORE::accept(qw{foo bar}), undef, "&accept"; | |
277 | lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context"; | |
278 | ||
279 | &myaccept(my $foo, my $bar); | |
280 | is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument'; | |
281 | is $bar, undef, 'CORE::accept does not autovivify its second argument'; | |
282 | use strict; | |
283 | undef $foo; | |
284 | eval { 'myaccept'->($foo, $bar) }; | |
285 | like $@, qr/^Can't use an undefined value as a symbol reference at/, | |
286 | 'CORE::accept will not accept undef 2nd arg under strict'; | |
287 | is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict'; | |
288 | }; | |
289 | ||
290 | test_proto 'alarm'; | |
291 | test_proto 'atan2'; | |
292 | ||
293 | test_proto 'bind'; | |
294 | $tests += 3; | |
295 | is &CORE::bind('foo', 'bear'), undef, "&bind"; | |
296 | lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context"; | |
297 | eval { &mybind(my $foo, "bear") }; | |
298 | like $@, qr/^Bad symbol for filehandle at/, | |
299 | 'CORE::bind dies with undef first arg'; | |
300 | ||
301 | test_proto 'binmode'; | |
302 | $tests += 3; | |
303 | is &CORE::binmode(qw[foo bar]), undef, "&binmode"; | |
304 | lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context"; | |
305 | is &mybinmode(foo), undef, '&binmode with one arg'; | |
306 | ||
307 | test_proto 'bless'; | |
308 | $tests += 3; | |
309 | like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless"; | |
310 | like join(" ", &CORE::bless([],'parcel')), | |
311 | qr/^parcel=ARRAY(?!.* )/, "&bless in list context"; | |
312 | like &mybless([]), qr/^main=ARRAY/, '&bless with one arg'; | |
313 | ||
314 | test_proto 'break'; | |
315 | { $tests ++; | |
316 | my $tmp; | |
317 | CORE::given(1) { | |
318 | CORE::when(1) { | |
319 | &mybreak; | |
320 | $tmp = 'bad'; | |
321 | } | |
322 | } | |
323 | is $tmp, undef, '&break'; | |
324 | } | |
325 | ||
326 | test_proto 'caller'; | |
327 | $tests += 4; | |
328 | sub caller_test { | |
329 | is scalar &CORE::caller, 'hadhad', '&caller'; | |
330 | is scalar &CORE::caller(1), 'main', '&caller(1)'; | |
331 | lis [&CORE::caller], [caller], '&caller in list context'; | |
d90b3686 FC |
332 | # The last element of caller in list context is a hint hash, which |
333 | # may be a different hash for caller vs &CORE::caller, so an eq com- | |
334 | # parison (which lis() uses for convenience) won’t work. So just | |
335 | # pop the last element, since the rest are sufficient to prove that | |
336 | # &CORE::caller works. | |
337 | my @ampcaller = &CORE::caller(1); | |
338 | my @caller = caller(1); | |
339 | pop @ampcaller; pop @caller; | |
340 | lis \@ampcaller, \@caller, '&caller(1) in list context'; | |
47ac839d FC |
341 | } |
342 | sub { | |
343 | package hadhad; | |
344 | ::caller_test(); | |
345 | }->(); | |
346 | ||
347 | test_proto 'chmod'; | |
348 | $tests += 3; | |
349 | is &CORE::chmod(), 0, '&chmod with no args'; | |
350 | is &CORE::chmod(0666), 0, '&chmod'; | |
351 | lis [&CORE::chmod(0666)], [0], '&chmod in list context'; | |
352 | ||
353 | test_proto 'chown'; | |
354 | $tests += 4; | |
355 | is &CORE::chown(), 0, '&chown with no args'; | |
356 | is &CORE::chown(1), 0, '&chown with 1 arg'; | |
357 | is &CORE::chown(1,2), 0, '&chown'; | |
358 | lis [&CORE::chown(1,2)], [0], '&chown in list context'; | |
359 | ||
360 | test_proto 'chr', 5, "\5"; | |
361 | test_proto 'chroot'; | |
362 | ||
363 | test_proto 'close'; | |
364 | { | |
365 | last if is_miniperl; | |
366 | $tests += 3; | |
367 | ||
368 | open my $fh, ">", \my $buffalo; | |
369 | print $fh 'an address in the outskirts of Jersey'; | |
370 | ok &CORE::close($fh), '&CORE::close retval'; | |
371 | print $fh 'lalala'; | |
372 | is $buffalo, 'an address in the outskirts of Jersey', | |
373 | 'effect of &CORE::close'; | |
374 | # This has to be a separate variable from $fh, as re-using the same | |
375 | # variable can cause the tests to pass by accident. That actually hap- | |
376 | # pened during developement, because the second close() was reading | |
377 | # beyond the end of the stack and finding a $fh left over from before. | |
378 | open my $fh2, ">", \($buffalo = ''); | |
379 | select+(select($fh2), do { | |
380 | print "Nasusiro Tokasoni"; | |
381 | &CORE::close(); | |
382 | print "jfd"; | |
383 | is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args'; | |
384 | })[0]; | |
385 | } | |
386 | lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests; | |
387 | ||
388 | test_proto 'closedir'; | |
389 | $tests += 2; | |
390 | is &CORE::closedir(foo), undef, '&CORE::closedir'; | |
391 | lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context'; | |
392 | ||
393 | test_proto 'connect'; | |
394 | $tests += 2; | |
395 | is &CORE::connect('foo','bar'), undef, '&connect'; | |
396 | lis [&myconnect('foo','bar')], [undef], '&connect in list context'; | |
397 | ||
398 | test_proto 'continue'; | |
399 | $tests ++; | |
400 | CORE::given(1) { | |
401 | CORE::when(1) { | |
402 | &mycontinue(); | |
403 | } | |
404 | pass "&continue"; | |
405 | } | |
406 | ||
407 | test_proto 'cos'; | |
408 | test_proto 'crypt'; | |
409 | ||
410 | test_proto 'dbmclose'; | |
411 | test_proto 'dbmopen'; | |
412 | { | |
413 | last unless eval { require AnyDBM_File }; | |
414 | $tests ++; | |
415 | my $filename = tempfile(); | |
416 | &mydbmopen(\my %db, $filename, 0666); | |
417 | $db{1} = 2; $db{3} = 4; | |
418 | &mydbmclose(\%db); | |
419 | is scalar keys %db, 0, '&dbmopen and &dbmclose'; | |
420 | } | |
421 | ||
422 | test_proto 'die'; | |
423 | eval { dier('quinquangle') }; | |
424 | is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++; | |
425 | ||
426 | test_proto $_ for qw( | |
427 | endgrent endhostent endnetent endprotoent endpwent endservent | |
428 | ); | |
429 | ||
7d789282 FC |
430 | test_proto 'evalbytes'; |
431 | $tests += 4; | |
432 | { | |
433 | chop(my $upgraded = "use utf8; '\xc4\x80'" . chr 256); | |
434 | is &myevalbytes($upgraded), chr 256, '&evalbytes'; | |
435 | # Test hints | |
436 | require strict; | |
437 | strict->import; | |
438 | &myevalbytes(' | |
439 | is someone, "someone", "run-time hint bits do not leak into &evalbytes" | |
440 | '); | |
441 | use strict; | |
442 | BEGIN { $^H{coreamp} = 42 } | |
443 | $^H{coreamp} = 75; | |
444 | &myevalbytes(' | |
445 | BEGIN { | |
446 | is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes"; | |
447 | } | |
448 | ${"frobnicate"} | |
449 | '); | |
450 | like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes'; | |
451 | } | |
452 | ||
47ac839d FC |
453 | test_proto 'exit'; |
454 | $tests ++; | |
d3288251 | 455 | is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n", |
47ac839d FC |
456 | '&exit with no args'; |
457 | ||
458 | test_proto 'fork'; | |
459 | ||
460 | test_proto 'formline'; | |
461 | $tests += 3; | |
462 | is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval'; | |
463 | is $^A, ' 1 2', 'effect of &myformline'; | |
464 | lis [&myformline('@')], [1], '&myformline in list context'; | |
465 | ||
466 | test_proto 'exp'; | |
838f2281 BF |
467 | |
468 | test_proto 'fc'; | |
469 | $tests += 2; | |
470 | { | |
471 | my $sharp_s = "\xdf"; | |
472 | is &myfc($sharp_s), $sharp_s, '&fc, no unicode_strings'; | |
473 | use feature 'unicode_strings'; | |
474 | is &myfc($sharp_s), "ss", '&fc, unicode_strings'; | |
475 | } | |
476 | ||
47ac839d FC |
477 | test_proto 'fcntl'; |
478 | ||
479 | test_proto 'fileno'; | |
480 | $tests += 2; | |
481 | is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno'; | |
482 | lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx'; | |
483 | ||
484 | test_proto 'flock'; | |
485 | test_proto 'fork'; | |
486 | ||
487 | test_proto 'getc'; | |
488 | { | |
489 | last if is_miniperl; | |
490 | $tests += 3; | |
491 | local *STDIN; | |
492 | open my $fh, "<", \(my $buf='falo'); | |
493 | open STDIN, "<", \(my $buf2 = 'bison'); | |
494 | is &mygetc($fh), 'f', '&mygetc'; | |
495 | is &mygetc(), 'b', '&mygetc with no args'; | |
496 | lis [&mygetc($fh)], ['a'], '&mygetc in list context'; | |
497 | } | |
498 | ||
499 | test_proto "get$_" for qw ' | |
500 | grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname | |
501 | netent peername | |
502 | '; | |
503 | ||
504 | test_proto 'getpgrp'; | |
505 | eval {&mygetpgrp()}; | |
506 | pass '&getpgrp with no args does not crash'; $tests++; | |
507 | ||
508 | test_proto "get$_" for qw ' | |
509 | ppid priority protobyname protobynumber protoent | |
510 | pwent pwnam pwuid servbyname servbyport servent sockname sockopt | |
511 | '; | |
512 | ||
498a02d8 FC |
513 | # Make sure the following tests test what we think they are testing. |
514 | ok ! $CORE::{glob}, '*CORE::glob not autovivified yet'; $tests ++; | |
515 | { | |
516 | # Make sure ck_glob does not respect the override when &CORE::glob is | |
517 | # autovivified (by test_proto). | |
518 | local *CORE::GLOBAL::glob = sub {}; | |
519 | test_proto 'glob'; | |
520 | } | |
521 | $_ = "t/*.t"; | |
522 | @_ = &myglob($_); | |
523 | is join($", &myglob()), "@_", '&glob without arguments'; | |
524 | is join($", &myglob("t/*.t")), "@_", '&glob with an arg'; | |
525 | $tests += 2; | |
526 | ||
47ac839d FC |
527 | test_proto 'gmtime'; |
528 | &CORE::gmtime; | |
529 | pass '&gmtime without args does not crash'; ++$tests; | |
530 | ||
531 | test_proto 'hex', ff=>255; | |
532 | ||
533 | test_proto 'index'; | |
534 | $tests += 3; | |
535 | is &myindex("foffooo","o",2),4,'&index'; | |
536 | lis [&myindex("foffooo","o",2)],[4],'&index in list context'; | |
537 | is &myindex("foffooo","o"),1,'&index with 2 args'; | |
538 | ||
539 | test_proto 'int', 1.5=>1; | |
540 | test_proto 'ioctl'; | |
541 | ||
542 | test_proto 'join'; | |
543 | $tests += 2; | |
544 | is &myjoin('a','b','c'), 'bac', '&join'; | |
545 | lis [&myjoin('a','b','c')], ['bac'], '&join in list context'; | |
546 | ||
547 | test_proto 'kill'; # set up mykill alias | |
548 | if ($^O ne 'riscos') { | |
549 | $tests ++; | |
550 | ok( &mykill(0, $$), '&kill' ); | |
551 | } | |
552 | ||
553 | test_proto 'lc', 'A', 'a'; | |
554 | test_proto 'lcfirst', 'AA', 'aA'; | |
555 | test_proto 'length', 'aaa', 3; | |
556 | test_proto 'link'; | |
557 | test_proto 'listen'; | |
558 | ||
559 | test_proto 'localtime'; | |
560 | &CORE::localtime; | |
561 | pass '&localtime without args does not crash'; ++$tests; | |
562 | ||
563 | test_proto 'lock'; | |
564 | $tests += 6; | |
565 | is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref'; | |
566 | lis [\&mylock(\$foo)], [\$foo], '&lock in list context'; | |
567 | is &mylock(\@foo), \@foo, '&lock retval when passed an array ref'; | |
568 | is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref'; | |
569 | is &mylock(\&foo), \&foo, '&lock retval when passed a code ref'; | |
570 | is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref'; | |
571 | ||
572 | test_proto 'log'; | |
573 | ||
574 | test_proto 'mkdir'; | |
575 | # mkdir is tested with implicit $_ at the end, to make the test easier | |
576 | ||
577 | test_proto "msg$_" for qw( ctl get rcv snd ); | |
578 | ||
579 | test_proto 'not'; | |
580 | $tests += 2; | |
581 | is &mynot(1), !1, '¬'; | |
582 | lis [&mynot(0)], [!0], '¬ in list context'; | |
583 | ||
584 | test_proto 'oct', '666', 438; | |
585 | ||
586 | test_proto 'open'; | |
587 | $tests += 5; | |
588 | $file = 'test.pl'; | |
589 | ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!"; | |
590 | like <file>, qr|^#|, 'result of &open with 1 arg'; | |
591 | close file; | |
592 | { | |
593 | ok &myopen(my $fh, "test.pl"), 'two-arg &open'; | |
594 | ok $fh, '&open autovivifies'; | |
595 | like <$fh>, qr '^#', 'result of &open with 2 args'; | |
596 | last if is_miniperl; | |
597 | $tests +=2; | |
598 | ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open'; | |
599 | is <$fh2>, 'sharummbles', 'result of three-arg &open'; | |
600 | } | |
601 | ||
602 | test_proto 'opendir'; | |
603 | test_proto 'ord', chr(64), 64; | |
604 | ||
605 | test_proto 'pack'; | |
606 | $tests += 2; | |
607 | is &mypack("H*", '5065726c'), 'Perl', '&pack'; | |
608 | lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context'; | |
609 | ||
610 | test_proto 'pipe'; | |
1efec5ed FC |
611 | |
612 | test_proto 'pos'; | |
613 | $tests += 4; | |
614 | $_ = "hello"; | |
615 | pos = 3; | |
616 | is &mypos, 3, 'reading &pos without args'; | |
617 | &mypos = 4; | |
618 | is pos, 4, 'writing to &pos without args'; | |
619 | { | |
620 | my $x = "gubai"; | |
621 | pos $x = 3; | |
622 | is &mypos(\$x), 3, 'reading &pos without args'; | |
623 | &mypos(\$x) = 4; | |
624 | is pos $x, 4, 'writing to &pos without args'; | |
625 | } | |
626 | ||
919ad5f7 FC |
627 | test_proto 'prototype'; |
628 | $tests++; | |
629 | is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype'; | |
1efec5ed | 630 | |
47ac839d FC |
631 | test_proto 'quotemeta', '$', '\$'; |
632 | ||
633 | test_proto 'rand'; | |
634 | $tests += 3; | |
635 | like &CORE::rand, qr/^0[.\d]*\z/, '&rand'; | |
636 | unlike join(" ", &CORE::rand), qr/ /, '&rand in list context'; | |
637 | &cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 2 args'); | |
638 | ||
17008668 FC |
639 | test_proto 'read'; |
640 | { | |
641 | last if is_miniperl; | |
642 | $tests += 5; | |
643 | open my $fh, "<", \(my $buff = 'morays have their mores'); | |
644 | ok &myread($fh, \my $input, 6), '&read with 3 args'; | |
645 | is $input, 'morays', 'value read by 3-arg &read'; | |
646 | ok &myread($fh, \$input, 6, 6), '&read with 4 args'; | |
647 | is $input, 'morays have ', 'value read by 4-arg &read'; | |
648 | is +()=&myread($fh, \$input, 6), 1, '&read in list context'; | |
649 | } | |
650 | ||
47ac839d FC |
651 | test_proto 'readdir'; |
652 | ||
653 | test_proto 'readline'; | |
654 | { | |
655 | local *ARGV = *DATA; | |
656 | $tests ++; | |
657 | is scalar &myreadline, | |
658 | "I wandered lonely as a cloud\n", '&readline w/no args'; | |
659 | } | |
660 | { | |
661 | last if is_miniperl; | |
662 | $tests += 2; | |
663 | open my $fh, "<", \(my $buff = <<END); | |
664 | The Recursive Problem | |
665 | --------------------- | |
666 | I have a problem I cannot solve. | |
667 | The problem is that I cannot solve it. | |
668 | END | |
669 | is &myreadline($fh), "The Recursive Problem\n", | |
670 | '&readline with 1 arg'; | |
671 | lis [&myreadline($fh)], [ | |
672 | "---------------------\n", | |
673 | "I have a problem I cannot solve.\n", | |
674 | "The problem is that I cannot solve it.\n", | |
675 | ], '&readline in list context'; | |
676 | } | |
677 | ||
678 | test_proto 'readlink'; | |
679 | test_proto 'readpipe'; | |
17008668 | 680 | test_proto 'recv'; |
47ac839d FC |
681 | |
682 | use if !is_miniperl, File::Spec::Functions, qw "catfile"; | |
683 | use if !is_miniperl, File::Temp, 'tempdir'; | |
684 | ||
685 | test_proto 'rename'; | |
686 | { | |
687 | last if is_miniperl; | |
688 | $tests ++; | |
689 | my $dir = tempdir(uc cleanup => 1); | |
690 | my $tmpfilenam = catfile $dir, 'aaa'; | |
691 | open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!"; | |
692 | close $fh or die "cannot close $tmpfilenam: $!"; | |
693 | &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb'); | |
694 | ok open(my $fh, '>', $tmpfilenam), '&rename'; | |
695 | } | |
696 | ||
697 | test_proto 'ref', [], 'ARRAY'; | |
698 | ||
f650fa72 FC |
699 | test_proto 'reset'; |
700 | $tests += 2; | |
701 | my $oncer = sub { "a" =~ m?a? }; | |
702 | &$oncer; | |
703 | &myreset; | |
1eaae977 | 704 | ok &$oncer, '&reset with no args'; |
f650fa72 FC |
705 | package resettest { |
706 | $b = "c"; | |
707 | $banana = "cream"; | |
708 | &::myreset('b'); | |
1eaae977 | 709 | ::lis [$b,$banana],[(undef)x2], '1-arg &reset'; |
f650fa72 FC |
710 | } |
711 | ||
47ac839d FC |
712 | test_proto 'reverse'; |
713 | $tests += 2; | |
714 | is &myreverse('reward'), 'drawer', '&reverse'; | |
715 | lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'], | |
716 | '&reverse in list context'; | |
717 | ||
718 | test_proto 'rewinddir'; | |
719 | ||
720 | test_proto 'rindex'; | |
721 | $tests += 3; | |
722 | is &myrindex("foffooo","o",2),1,'&rindex'; | |
723 | lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context'; | |
724 | is &myrindex("foffooo","o"),6,'&rindex with 2 args'; | |
725 | ||
726 | test_proto 'rmdir'; | |
727 | ||
d33bb3da FC |
728 | test_proto 'scalar'; |
729 | $tests += 2; | |
730 | is &myscalar(3), 3, '&scalar'; | |
731 | lis [&myscalar(3)], [3], '&scalar in list cx'; | |
732 | ||
47ac839d FC |
733 | test_proto 'seek'; |
734 | { | |
735 | last if is_miniperl; | |
736 | $tests += 1; | |
737 | open my $fh, "<", \"misled" or die $!; | |
738 | &myseek($fh, 2, 0); | |
739 | is <$fh>, 'sled', '&seek in action'; | |
740 | } | |
741 | ||
742 | test_proto 'seekdir'; | |
720d5b2f FC |
743 | |
744 | # Can’t test_proto, as it has none | |
745 | $tests += 8; | |
746 | *myselect = \&CORE::select; | |
747 | is defined prototype &myselect, defined prototype "CORE::select", | |
748 | 'prototype of &select (or lack thereof)'; | |
749 | is &myselect, select, '&select with no args'; | |
750 | { | |
751 | my $prev = select; | |
752 | is &myselect(my $fh), $prev, '&select($arg) retval'; | |
753 | is lc ref $fh, 'glob', '&select autovivifies'; | |
754 | is select=~s/\*//rug, (*$fh."")=~s/\*//rug, '&select selects'; | |
755 | select $prev; | |
756 | } | |
757 | eval { &myselect(1,2) }; | |
758 | like $@, qr/^Not enough arguments for select system call at /, | |
759 | ,'&myselect($two,$args)'; | |
760 | eval { &myselect(1,2,3) }; | |
761 | like $@, qr/^Not enough arguments for select system call at /, | |
762 | ,'&myselect($with,$three,$args)'; | |
763 | eval { &myselect(1,2,3,4,5) }; | |
764 | like $@, qr/^Too many arguments for select system call at /, | |
765 | ,'&myselect($a,$total,$of,$five,$args)'; | |
766 | &myselect((undef)x3,.25); | |
767 | # Just have to assume that worked. :-) If we get here, at least it didn’t | |
768 | # crash or anything. | |
769 | ||
47ac839d FC |
770 | test_proto "sem$_" for qw "ctl get op"; |
771 | ||
1ed240b7 FC |
772 | test_proto 'send'; |
773 | ||
47ac839d | 774 | test_proto "set$_" for qw ' |
92f2ac5f FC |
775 | grent hostent netent |
776 | '; | |
777 | ||
778 | test_proto 'setpgrp'; | |
779 | $tests +=2; | |
780 | eval { &mysetpgrp( 0) }; | |
781 | pass "&setpgrp with one argument"; | |
782 | eval { &mysetpgrp }; | |
783 | pass "&setpgrp with no arguments"; | |
784 | ||
785 | test_proto "set$_" for qw ' | |
786 | priority protoent pwent servent sockopt | |
47ac839d FC |
787 | '; |
788 | ||
789 | test_proto "shm$_" for qw "ctl get read write"; | |
790 | test_proto 'shutdown'; | |
791 | test_proto 'sin'; | |
0da4a804 | 792 | test_proto 'sleep'; |
47ac839d FC |
793 | test_proto "socket$_" for "", "pair"; |
794 | ||
795 | test_proto 'sprintf'; | |
796 | $tests += 2; | |
797 | is &mysprintf("%x", 65), '41', '&sprintf'; | |
798 | lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context'; | |
799 | ||
800 | test_proto 'sqrt', 4, 2; | |
d22667bf FC |
801 | |
802 | test_proto 'srand'; | |
803 | $tests ++; | |
804 | &CORE::srand; | |
805 | pass '&srand with no args does not crash'; | |
806 | ||
d80ed303 FC |
807 | test_proto 'study'; |
808 | ||
7bc95ae1 FC |
809 | test_proto 'substr'; |
810 | $tests += 5; | |
811 | $_ = "abc"; | |
812 | is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr'; | |
813 | is $_, 'adc', 'what 4-arg &substr does'; | |
814 | is &mysubstr("abc", 1, 1), 'b', '3-arg &substr'; | |
815 | is &mysubstr("abc", 1), 'bc', '2-arg &substr'; | |
816 | &mysubstr($_, 1) = 'long'; | |
817 | is $_, 'along', 'lvalue &substr'; | |
818 | ||
47ac839d FC |
819 | test_proto 'symlink'; |
820 | test_proto 'syscall'; | |
de5e49e1 FC |
821 | |
822 | test_proto 'sysopen'; | |
823 | $tests +=2; | |
824 | { | |
825 | &mysysopen(my $fh, 'test.pl', 0); | |
826 | pass '&sysopen does not crash with 3 args'; | |
827 | ok $fh, 'sysopen autovivifies'; | |
828 | } | |
829 | ||
17008668 | 830 | test_proto 'sysread'; |
47ac839d | 831 | test_proto 'sysseek'; |
1ed240b7 | 832 | test_proto 'syswrite'; |
b64a1294 FC |
833 | |
834 | test_proto 'tell'; | |
835 | { | |
836 | $tests += 2; | |
837 | open my $fh, "test.pl" or die "Cannot open test.pl"; | |
838 | <$fh>; | |
839 | is &mytell(), tell($fh), '&tell with no args'; | |
840 | is &mytell($fh), tell($fh), '&tell with an arg'; | |
841 | } | |
842 | ||
47ac839d FC |
843 | test_proto 'telldir'; |
844 | ||
efe889ae FC |
845 | test_proto 'tie'; |
846 | test_proto 'tied'; | |
847 | $tests += 3; | |
848 | { | |
849 | my $fetches; | |
850 | package tier { | |
851 | sub TIESCALAR { bless[] } | |
852 | sub FETCH { ++$fetches } | |
853 | } | |
854 | my $tied; | |
855 | my $obj = &mytie(\$tied, 'tier'); | |
856 | is &mytied(\$tied), $obj, '&tie and &tied retvals'; | |
857 | () = "$tied"; | |
858 | is $fetches, 1, '&tie actually ties'; | |
859 | &CORE::untie(\$tied); | |
860 | () = "$tied"; | |
861 | is $fetches, 1, '&untie unties'; | |
862 | } | |
863 | ||
47ac839d FC |
864 | test_proto 'time'; |
865 | $tests += 2; | |
866 | like &mytime, '^\d+\z', '&time in scalar context'; | |
867 | like join('-', &mytime), '^\d+\z', '&time in list context'; | |
868 | ||
869 | test_proto 'times'; | |
870 | $tests += 2; | |
871 | like &mytimes, '^[\d.]+\z', '× in scalar context'; | |
872 | like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z', | |
873 | '× in list context'; | |
874 | ||
875 | test_proto 'uc', 'aa', 'AA'; | |
876 | test_proto 'ucfirst', 'aa', "Aa"; | |
58536d15 FC |
877 | |
878 | test_proto 'umask'; | |
879 | $tests ++; | |
880 | is &myumask, umask, '&umask with no args'; | |
881 | ||
46bef06f | 882 | test_proto 'undef'; |
88bb468b | 883 | $tests += 12; |
46bef06f FC |
884 | is &myundef(), undef, '&undef returns undef'; |
885 | lis [&myundef()], [undef], '&undef returns undef in list cx'; | |
886 | lis [&myundef(\$_)], [undef], '&undef(...) returns undef in list cx'; | |
887 | is \&myundef(), \undef, '&undef returns the right undef'; | |
888 | $_ = 'anserine questions'; | |
889 | &myundef(\$_); | |
890 | is $_, undef, '&undef(\$_) undefines $_'; | |
891 | @_ = 1..3; | |
892 | &myundef(\@_); | |
893 | is @_, 0, '&undef(\@_) undefines @_'; | |
894 | %_ = 1..4; | |
895 | &myundef(\%_); | |
896 | ok !%_, '&undef(\%_) undefines %_'; | |
897 | &myundef(\&utf8::valid); # nobody should be using this :-) | |
898 | ok !defined &utf8::valid, '&undef(\&foo) undefines &foo'; | |
899 | @_ = \*_; | |
900 | &myundef; | |
88bb468b FC |
901 | is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_'; |
902 | @_ = \*_; | |
903 | &myundef(\*_); | |
46bef06f | 904 | is *_{ARRAY}, undef, '&undef(\*_) undefines *_'; |
c4ec50f1 FC |
905 | (&myundef(), @_) = 1..10; |
906 | lis \@_, [2..10], 'list assignment to &undef()'; | |
907 | ok !defined undef, 'list assignment to &undef() does not affect undef'; | |
46bef06f FC |
908 | undef @_; |
909 | ||
d6d78e19 FC |
910 | test_proto 'unpack'; |
911 | $tests += 2; | |
912 | $_ = 'abcd'; | |
913 | is &myunpack("H*"), '61626364', '&unpack with one arg'; | |
914 | is &myunpack("H*", "bcde"), '62636465', '&unpack with two arg'; | |
915 | ||
916 | ||
efe889ae | 917 | test_proto 'untie'; # behaviour already tested along with tie(d) |
47ac839d FC |
918 | |
919 | test_proto 'utime'; | |
920 | $tests += 2; | |
921 | is &myutime(undef,undef), 0, '&utime'; | |
922 | lis [&myutime(undef,undef)], [0], '&utime in list context'; | |
923 | ||
924 | test_proto 'vec'; | |
925 | $tests += 3; | |
926 | is &myvec("foo", 0, 4), 6, '&vec'; | |
927 | lis [&myvec("foo", 0, 4)], [6], '&vec in list context'; | |
928 | $tmp = "foo"; | |
929 | ++&myvec($tmp,0,4); | |
930 | is $tmp, "goo", 'lvalue &vec'; | |
931 | ||
932 | test_proto 'wait'; | |
933 | test_proto 'waitpid'; | |
934 | ||
935 | test_proto 'wantarray'; | |
936 | $tests += 4; | |
937 | my $context; | |
938 | my $cx_sub = sub { | |
939 | $context = qw[void scalar list][&mywantarray + defined mywantarray()] | |
940 | }; | |
941 | () = &$cx_sub; | |
942 | is $context, 'list', '&wantarray with caller in list context'; | |
943 | scalar &$cx_sub; | |
944 | is($context, 'scalar', '&wantarray with caller in scalar context'); | |
945 | &$cx_sub; | |
946 | is($context, 'void', '&wantarray with caller in void context'); | |
947 | lis [&mywantarray],[wantarray], '&wantarray itself in list context'; | |
948 | ||
949 | test_proto 'warn'; | |
950 | { $tests += 3; | |
951 | my $w; | |
952 | local $SIG{__WARN__} = sub { $w = shift }; | |
953 | is &mywarn('a'), 1, '&warn retval'; | |
954 | is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning'; | |
955 | lis [&mywarn()], [1], '&warn retval in list context'; | |
956 | } | |
957 | ||
96db40ac FC |
958 | test_proto 'write'; |
959 | $tests ++; | |
960 | eval {&mywrite}; | |
961 | like $@, qr'^Undefined format "STDOUT" called', | |
962 | "&write without arguments can handle the null"; | |
963 | ||
47ac839d FC |
964 | # This is just a check to make sure we have tested everything. If we |
965 | # haven’t, then either the sub needs to be tested or the list in | |
966 | # gv.c is wrong. | |
967 | { | |
968 | last if is_miniperl; | |
969 | require File::Spec::Functions; | |
970 | my $keywords_file = | |
971 | File::Spec::Functions::catfile( | |
972 | File::Spec::Functions::updir,'regen','keywords.pl' | |
973 | ); | |
974 | open my $kh, $keywords_file | |
975 | or die "$0 cannot open $keywords_file: $!"; | |
976 | while(<$kh>) { | |
94c7f5d8 | 977 | if (m?__END__?..${\0} and /^[-+](.*)/) { |
47ac839d FC |
978 | my $word = $1; |
979 | next if | |
d80ed303 | 980 | $word =~ /^(?:s(?:tate|ort|ay|ub)?|d(?:ef |
919ad5f7 | 981 | ault|ump|o)|p(?:rintf?|ackag |
1efec5ed | 982 | e)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto |
46bef06f | 983 | |rep)|u(?:n(?:less|til)|se)|l(?:(?:as)?t|ocal|e)|re |
94c7f5d8 FC |
984 | (?:quire|turn|do)|__(?:DATA|END)__|for(?:each|mat)?|(?: |
985 | AUTOLOA|EN)D|n(?:e(?:xt)?|o)|C(?:HECK|ORE)|wh(?:ile|en) | |
986 | |(?:ou?|t)r|m(?:ap|y)?|UNITCHECK|q[qrwx]?|x(?:or)?|DEST | |
987 | ROY|BEGIN|INIT|and|cmp|if|y)\z/x; | |
47ac839d FC |
988 | $tests ++; |
989 | ok exists &{"my$word"} | |
990 | || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/), | |
991 | "$word either has been tested or is not ampable"; | |
992 | } | |
993 | } | |
994 | } | |
995 | ||
996 | # Add new tests above this line. | |
997 | ||
998 | # This test must come last (before the test count test): | |
999 | ||
1000 | { | |
1001 | last if is_miniperl; | |
d3288251 CB |
1002 | require Cwd; |
1003 | import Cwd; | |
d6d78e19 | 1004 | $tests += 3; |
47ac839d FC |
1005 | require File::Temp ; |
1006 | my $dir = File::Temp::tempdir(uc cleanup => 1); | |
d3288251 | 1007 | my $cwd = cwd(); |
47ac839d | 1008 | chdir($dir); |
d6d78e19 FC |
1009 | |
1010 | # Make sure that implicit $_ is not applied to mkdir’s second argument. | |
1011 | local $^W = 1; | |
1012 | my $warnings; | |
1013 | local $SIG{__WARN__} = sub { ++$warnings }; | |
1014 | ||
47ac839d FC |
1015 | my $_ = 'Phoo'; |
1016 | ok &mymkdir(), '&mkdir'; | |
d3288251 | 1017 | like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_'; |
d6d78e19 FC |
1018 | |
1019 | is $warnings, undef, 'no implicit $_ for second argument to mkdir'; | |
1020 | ||
d3288251 | 1021 | chdir($cwd); # so auto-cleanup can remove $dir |
47ac839d FC |
1022 | } |
1023 | ||
1024 | # ------------ END TESTING ----------- # | |
1025 | ||
cbfc5cbc | 1026 | done_testing $tests; |
47ac839d FC |
1027 | |
1028 | #line 3 frob | |
1029 | ||
1030 | sub file { &CORE::__FILE__ } | |
1031 | sub line { &CORE::__LINE__ } # 5 | |
1032 | sub dier { &CORE::die(@_) } # 6 | |
1033 | package stribble; | |
1034 | sub main::pakg { &CORE::__PACKAGE__ } | |
1035 | ||
1036 | # Please do not add new tests here. | |
1037 | package main; | |
1038 | CORE::__DATA__ | |
1039 | I wandered lonely as a cloud | |
1040 | That floats on high o’er vales and hills, | |
1041 | And all at once I saw a crowd, | |
1042 | A host of golden daffodils! | |
1043 | Beside the lake, beneath the trees, | |
1044 | Fluttering, dancing, in the breeze. | |
1045 | -- Wordsworth |