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