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