This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Get coreamp.t working under miniperl
[perl5.git] / t / op / coreamp.t
CommitLineData
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
10BEGIN {
11 chdir 't' if -d 't';
0ea93a5d 12 @INC = qw(. ../lib ../dist/if);
47ac839d
FC
13 require "test.pl";
14 $^P |= 0x100;
15}
47ac839d 16
0f539b13
BF
17no warnings 'experimental::smartmatch';
18
47ac839d
FC
19sub lis($$;$) {
20 &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
21}
22
17008668
FC
23package hov {
24 use overload '%{}' => sub { +{} }
25}
26package sov {
27 use overload '${}' => sub { \my $x }
28}
29
47ac839d 30my %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);
41sub 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.
48sub 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.
261undef *_;
262&CORE::wantarray;
263$tests++;
264pass('no crash with &CORE::foo when *_{ARRAY} is undef');
265
47ac839d
FC
266test_proto '__FILE__';
267test_proto '__LINE__';
268test_proto '__PACKAGE__';
84ed0108 269test_proto '__SUB__';
47ac839d
FC
270
271is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests;
272is line(), 5 , '__LINE__ does check its caller' ; ++ $tests;
273is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
84ed0108
FC
274sub __SUB__test { &my__SUB__ }
275is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests;
47ac839d
FC
276
277test_proto 'abs', -5, 5;
278
279test_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
295test_proto 'alarm';
296test_proto 'atan2';
297
298test_proto 'bind';
299$tests += 3;
300is &CORE::bind('foo', 'bear'), undef, "&bind";
301lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context";
302eval { &mybind(my $foo, "bear") };
303like $@, qr/^Bad symbol for filehandle at/,
304 'CORE::bind dies with undef first arg';
305
306test_proto 'binmode';
307$tests += 3;
308is &CORE::binmode(qw[foo bar]), undef, "&binmode";
309lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context";
310is &mybinmode(foo), undef, '&binmode with one arg';
311
312test_proto 'bless';
313$tests += 3;
314like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless";
315like join(" ", &CORE::bless([],'parcel')),
316 qr/^parcel=ARRAY(?!.* )/, "&bless in list context";
317like &mybless([]), qr/^main=ARRAY/, '&bless with one arg';
318
319test_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
331test_proto 'caller';
332$tests += 4;
333sub 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}
347sub {
348 package hadhad;
349 ::caller_test();
350}->();
351
352test_proto 'chmod';
353$tests += 3;
354is &CORE::chmod(), 0, '&chmod with no args';
355is &CORE::chmod(0666), 0, '&chmod';
356lis [&CORE::chmod(0666)], [0], '&chmod in list context';
357
358test_proto 'chown';
359$tests += 4;
360is &CORE::chown(), 0, '&chown with no args';
361is &CORE::chown(1), 0, '&chown with 1 arg';
362is &CORE::chown(1,2), 0, '&chown';
363lis [&CORE::chown(1,2)], [0], '&chown in list context';
364
365test_proto 'chr', 5, "\5";
366test_proto 'chroot';
367
368test_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}
391lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests;
392
393test_proto 'closedir';
394$tests += 2;
395is &CORE::closedir(foo), undef, '&CORE::closedir';
396lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context';
397
398test_proto 'connect';
399$tests += 2;
400is &CORE::connect('foo','bar'), undef, '&connect';
401lis [&myconnect('foo','bar')], [undef], '&connect in list context';
402
403test_proto 'continue';
404$tests ++;
405CORE::given(1) {
406 CORE::when(1) {
407 &mycontinue();
408 }
409 pass "&continue";
410}
411
412test_proto 'cos';
413test_proto 'crypt';
414
415test_proto 'dbmclose';
416test_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
436test_proto 'die';
437eval { dier('quinquangle') };
438is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++;
439
440test_proto $_ for qw(
441 endgrent endhostent endnetent endprotoent endpwent endservent
442);
443
7d789282
FC
444test_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
467test_proto 'exit';
468$tests ++;
d3288251 469is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n",
47ac839d
FC
470 '&exit with no args';
471
472test_proto 'fork';
473
474test_proto 'formline';
475$tests += 3;
476is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval';
477is $^A, ' 1 2', 'effect of &myformline';
478lis [&myformline('@')], [1], '&myformline in list context';
479
480test_proto 'exp';
838f2281
BF
481
482test_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
491test_proto 'fcntl';
492
493test_proto 'fileno';
494$tests += 2;
495is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno';
496lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx';
497
498test_proto 'flock';
499test_proto 'fork';
500
501test_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
513test_proto "get$_" for qw '
514 grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
515 netent peername
516';
517
518test_proto 'getpgrp';
519eval {&mygetpgrp()};
520pass '&getpgrp with no args does not crash'; $tests++;
521
522test_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.
528ok ! $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($_);
537is join($", &myglob()), "@_", '&glob without arguments';
538is join($", &myglob("t/*.t")), "@_", '&glob with an arg';
539$tests += 2;
540
47ac839d
FC
541test_proto 'gmtime';
542&CORE::gmtime;
543pass '&gmtime without args does not crash'; ++$tests;
544
545test_proto 'hex', ff=>255;
546
547test_proto 'index';
548$tests += 3;
549is &myindex("foffooo","o",2),4,'&index';
550lis [&myindex("foffooo","o",2)],[4],'&index in list context';
551is &myindex("foffooo","o"),1,'&index with 2 args';
552
553test_proto 'int', 1.5=>1;
554test_proto 'ioctl';
555
556test_proto 'join';
557$tests += 2;
558is &myjoin('a','b','c'), 'bac', '&join';
559lis [&myjoin('a','b','c')], ['bac'], '&join in list context';
560
561test_proto 'kill'; # set up mykill alias
562if ($^O ne 'riscos') {
563 $tests ++;
564 ok( &mykill(0, $$), '&kill' );
565}
566
567test_proto 'lc', 'A', 'a';
568test_proto 'lcfirst', 'AA', 'aA';
569test_proto 'length', 'aaa', 3;
570test_proto 'link';
571test_proto 'listen';
572
573test_proto 'localtime';
574&CORE::localtime;
575pass '&localtime without args does not crash'; ++$tests;
576
577test_proto 'lock';
578$tests += 6;
579is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref';
580lis [\&mylock(\$foo)], [\$foo], '&lock in list context';
581is &mylock(\@foo), \@foo, '&lock retval when passed an array ref';
582is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref';
583is &mylock(\&foo), \&foo, '&lock retval when passed a code ref';
584is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref';
585
586test_proto 'log';
587
588test_proto 'mkdir';
589# mkdir is tested with implicit $_ at the end, to make the test easier
590
591test_proto "msg$_" for qw( ctl get rcv snd );
592
593test_proto 'not';
594$tests += 2;
595is &mynot(1), !1, '&not';
596lis [&mynot(0)], [!0], '&not in list context';
597
598test_proto 'oct', '666', 438;
599
600test_proto 'open';
601$tests += 5;
602$file = 'test.pl';
603ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!";
604like <file>, qr|^#|, 'result of &open with 1 arg';
605close 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
616test_proto 'opendir';
617test_proto 'ord', chr(64), 64;
618
619test_proto 'pack';
620$tests += 2;
621is &mypack("H*", '5065726c'), 'Perl', '&pack';
622lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context';
623
624test_proto 'pipe';
1efec5ed
FC
625
626test_proto 'pos';
627$tests += 4;
628$_ = "hello";
629pos = 3;
630is &mypos, 3, 'reading &pos without args';
631&mypos = 4;
632is 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
641test_proto 'prototype';
642$tests++;
643is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype';
1efec5ed 644
47ac839d
FC
645test_proto 'quotemeta', '$', '\$';
646
647test_proto 'rand';
648$tests += 3;
d62c8fd1
DDM
649my $r = &CORE::rand;
650ok eval {
651 use warnings FATAL => qw{numeric uninitialized};
652 $r >= 0 && $r < 1;
653}, '&rand returns a valid number';
47ac839d 654unlike 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
657test_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
669test_proto 'readdir';
670
671test_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);
682The Recursive Problem
683---------------------
684I have a problem I cannot solve.
685The problem is that I cannot solve it.
686END
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
696test_proto 'readlink';
697test_proto 'readpipe';
17008668 698test_proto 'recv';
47ac839d
FC
699
700use if !is_miniperl, File::Spec::Functions, qw "catfile";
701use if !is_miniperl, File::Temp, 'tempdir';
702
703test_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
715test_proto 'ref', [], 'ARRAY';
716
f650fa72
FC
717test_proto 'reset';
718$tests += 2;
719my $oncer = sub { "a" =~ m?a? };
720&$oncer;
721&myreset;
1eaae977 722ok &$oncer, '&reset with no args';
f650fa72
FC
723package 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
730test_proto 'reverse';
731$tests += 2;
732is &myreverse('reward'), 'drawer', '&reverse';
733lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'],
734 '&reverse in list context';
735
736test_proto 'rewinddir';
737
738test_proto 'rindex';
739$tests += 3;
740is &myrindex("foffooo","o",2),1,'&rindex';
741lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context';
742is &myrindex("foffooo","o"),6,'&rindex with 2 args';
743
744test_proto 'rmdir';
745
d33bb3da
FC
746test_proto 'scalar';
747$tests += 2;
748is &myscalar(3), 3, '&scalar';
749lis [&myscalar(3)], [3], '&scalar in list cx';
750
47ac839d
FC
751test_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
760test_proto 'seekdir';
720d5b2f
FC
761
762# Can’t test_proto, as it has none
763$tests += 8;
764*myselect = \&CORE::select;
765is defined prototype &myselect, defined prototype "CORE::select",
766 'prototype of &select (or lack thereof)';
767is &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}
775eval { &myselect(1,2) };
776like $@, qr/^Not enough arguments for select system call at /,
777 ,'&myselect($two,$args)';
778eval { &myselect(1,2,3) };
779like $@, qr/^Not enough arguments for select system call at /,
780 ,'&myselect($with,$three,$args)';
781eval { &myselect(1,2,3,4,5) };
782like $@, 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
788test_proto "sem$_" for qw "ctl get op";
789
1ed240b7
FC
790test_proto 'send';
791
47ac839d 792test_proto "set$_" for qw '
92f2ac5f
FC
793 grent hostent netent
794';
795
796test_proto 'setpgrp';
797$tests +=2;
798eval { &mysetpgrp( 0) };
799pass "&setpgrp with one argument";
800eval { &mysetpgrp };
801pass "&setpgrp with no arguments";
802
803test_proto "set$_" for qw '
804 priority protoent pwent servent sockopt
47ac839d
FC
805';
806
807test_proto "shm$_" for qw "ctl get read write";
808test_proto 'shutdown';
809test_proto 'sin';
0da4a804 810test_proto 'sleep';
47ac839d
FC
811test_proto "socket$_" for "", "pair";
812
813test_proto 'sprintf';
814$tests += 2;
815is &mysprintf("%x", 65), '41', '&sprintf';
816lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context';
817
818test_proto 'sqrt', 4, 2;
d22667bf
FC
819
820test_proto 'srand';
821$tests ++;
822&CORE::srand;
0a5f3363 823() = &CORE::srand;
d22667bf
FC
824pass '&srand with no args does not crash';
825
d80ed303
FC
826test_proto 'study';
827
7bc95ae1
FC
828test_proto 'substr';
829$tests += 5;
830$_ = "abc";
831is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr';
832is $_, 'adc', 'what 4-arg &substr does';
833is &mysubstr("abc", 1, 1), 'b', '3-arg &substr';
834is &mysubstr("abc", 1), 'bc', '2-arg &substr';
835&mysubstr($_, 1) = 'long';
836is $_, 'along', 'lvalue &substr';
837
47ac839d
FC
838test_proto 'symlink';
839test_proto 'syscall';
de5e49e1
FC
840
841test_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 849test_proto 'sysread';
47ac839d 850test_proto 'sysseek';
1ed240b7 851test_proto 'syswrite';
b64a1294
FC
852
853test_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
862test_proto 'telldir';
863
efe889ae
FC
864test_proto 'tie';
865test_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
883test_proto 'time';
884$tests += 2;
aaa63dae
AB
885like &mytime, qr/^\d+\z/, '&time in scalar context';
886like join('-', &mytime), qr/^\d+\z/, '&time in list context';
47ac839d
FC
887
888test_proto 'times';
889$tests += 2;
aaa63dae
AB
890like &mytimes, qr/^[\d.]+\z/, '&times in scalar context';
891like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/,
47ac839d
FC
892 '&times in list context';
893
894test_proto 'uc', 'aa', 'AA';
895test_proto 'ucfirst', 'aa', "Aa";
58536d15
FC
896
897test_proto 'umask';
898$tests ++;
899is &myumask, umask, '&umask with no args';
900
46bef06f 901test_proto 'undef';
88bb468b 902$tests += 12;
46bef06f
FC
903is &myundef(), undef, '&undef returns undef';
904lis [&myundef()], [undef], '&undef returns undef in list cx';
905lis [&myundef(\$_)], [undef], '&undef(...) returns undef in list cx';
906is \&myundef(), \undef, '&undef returns the right undef';
907$_ = 'anserine questions';
908&myundef(\$_);
909is $_, undef, '&undef(\$_) undefines $_';
910@_ = 1..3;
911&myundef(\@_);
912is @_, 0, '&undef(\@_) undefines @_';
913%_ = 1..4;
914&myundef(\%_);
915ok !%_, '&undef(\%_) undefines %_';
916&myundef(\&utf8::valid); # nobody should be using this :-)
917ok !defined &utf8::valid, '&undef(\&foo) undefines &foo';
918@_ = \*_;
919&myundef;
88bb468b
FC
920is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_';
921@_ = \*_;
922&myundef(\*_);
46bef06f 923is *_{ARRAY}, undef, '&undef(\*_) undefines *_';
c4ec50f1
FC
924(&myundef(), @_) = 1..10;
925lis \@_, [2..10], 'list assignment to &undef()';
926ok !defined undef, 'list assignment to &undef() does not affect undef';
46bef06f
FC
927undef @_;
928
d6d78e19
FC
929test_proto 'unpack';
930$tests += 2;
931$_ = 'abcd';
932is &myunpack("H*"), '61626364', '&unpack with one arg';
933is &myunpack("H*", "bcde"), '62636465', '&unpack with two arg';
934
935
efe889ae 936test_proto 'untie'; # behaviour already tested along with tie(d)
47ac839d
FC
937
938test_proto 'utime';
939$tests += 2;
940is &myutime(undef,undef), 0, '&utime';
941lis [&myutime(undef,undef)], [0], '&utime in list context';
942
943test_proto 'vec';
944$tests += 3;
945is &myvec("foo", 0, 4), 6, '&vec';
946lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
947$tmp = "foo";
948++&myvec($tmp,0,4);
949is $tmp, "goo", 'lvalue &vec';
950
951test_proto 'wait';
952test_proto 'waitpid';
953
954test_proto 'wantarray';
955$tests += 4;
956my $context;
957my $cx_sub = sub {
958 $context = qw[void scalar list][&mywantarray + defined mywantarray()]
959};
960() = &$cx_sub;
961is $context, 'list', '&wantarray with caller in list context';
962scalar &$cx_sub;
963is($context, 'scalar', '&wantarray with caller in scalar context');
964&$cx_sub;
965is($context, 'void', '&wantarray with caller in void context');
966lis [&mywantarray],[wantarray], '&wantarray itself in list context';
967
968test_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
977test_proto 'write';
978$tests ++;
979eval {&mywrite};
980like $@, 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 1046done_testing $tests;
47ac839d
FC
1047
1048#line 3 frob
1049
1050sub file { &CORE::__FILE__ }
1051sub line { &CORE::__LINE__ } # 5
1052sub dier { &CORE::die(@_) } # 6
1053package stribble;
1054sub main::pakg { &CORE::__PACKAGE__ }
1055
1056# Please do not add new tests here.
1057package main;
1058CORE::__DATA__
1059I wandered lonely as a cloud
1060That floats on high o’er vales and hills,
1061And all at once I saw a crowd,
1062A host of golden daffodils!
1063Beside the lake, beneath the trees,
1064Fluttering, dancing, in the breeze.
1065-- Wordsworth