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