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