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