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