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