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