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