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