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