perldelta for 125ddee8ebdb, 2e51033c15c9
[perl.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     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   open my $kh, $keywords_file
1162     or die "$0 cannot open $keywords_file: $!";
1163   while(<$kh>) {
1164     if (m?__END__?..${\0} and /^[-+](.*)/) {
1165       my $word = $1;
1166       next if
1167        $word =~ /^(?:s(?:tate|ort|ay|ub)?|d(?:ef
1168                   ault|ump|o)|p(?:rintf?|ackag
1169                   e)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto
1170                   |rep)|u(?:n(?:less|til)|se)|l(?:(?:as)?t|ocal|e)|re
1171                   (?:quire|turn|do)|__(?:DATA|END)__|for(?:each|mat)?|(?:
1172                   AUTOLOA|EN)D|n(?:e(?:xt)?|o)|C(?:HECK|ORE)|wh(?:ile|en)
1173                   |(?:ou?|t)r|m(?:ap|y)?|UNITCHECK|q[qrwx]?|x(?:or)?|DEST
1174                   ROY|BEGIN|INIT|and|cmp|if|y)\z/x;
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