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