diff options
author | Father Chrysostomos <sprout@cpan.org> | 2011-08-26 21:48:47 -0700 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2011-08-26 21:48:47 -0700 |
commit | 47ac839d7e6d83a2222bbfea12c7e622983213a4 (patch) | |
tree | 4ac47af051c9342e444a31bead7f38d6574c23d3 /t/op/coresubs.t | |
parent | 94ec06bc74ba3a61d5daddf3adeaa53459960136 (diff) | |
download | perl-47ac839d7e6d83a2222bbfea12c7e622983213a4.tar.gz |
Rename t/op/core*.t
Originally, coresubs.t was going to be for generic tests and
coreinline.t was going to be for inlining. But the latter ended
up testing other things than inlining, the former testing just
&ersand() calls. So this commits renames coresubs.t to coreamp.t
and coreinline.t to coresubs.t.
Diffstat (limited to 't/op/coresubs.t')
-rw-r--r-- | t/op/coresubs.t | 767 |
1 files changed, 86 insertions, 681 deletions
diff --git a/t/op/coresubs.t b/t/op/coresubs.t index f21ba76888..34ae9e23ed 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -1,707 +1,112 @@ #!./perl -# This file tests the results of calling subroutines in the CORE:: -# namespace with ampersand syntax. In other words, it tests the bodies of -# the subroutines themselves, not the ops that they might inline themselves -# as when called as barewords. - -# coreinline.t tests the inlining of these subs as ops. Since it was -# convenient, I also put the prototype and undefinedness checking in that -# file, even though those have nothing to do with inlining. (coreinline.t -# reads the list in keywords.pl, which is why it’s convenient.) +# This script tests the inlining of CORE:: subs. Since it’s convenient +# (this script reads the list in keywords.pl), we also test that prototypes +# match the built-ins and check for undefinedness. BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); require "test.pl"; + skip_all_without_dynamic_extension('B'); $^P |= 0x100; } -# Since tests inside evals can too easily fail silently, we cannot rely -# on done_testing. It’s much easier to count the tests as we go than to -# declare the plan up front, so this script ends with a test that makes -# sure the right number of tests have happened. -sub lis($$;$) { - &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]); -} +use B::Deparse; +my $bd = new B::Deparse '-p'; -my %op_desc = ( - join => 'join or string', - readline => '<HANDLE>', - readpipe => 'quoted execution (``, qx)', - ref => 'reference-type operator', +my %unsupported = map +($_=>1), qw (CORE and cmp dump eq ge gt le + lt ne or x xor); +my %args_for = ( + dbmopen => '%1,$2,$3', + dbmclose => '%1', ); -sub op_desc($) { - return $op_desc{$_[0]} || $_[0]; -} - - -# This tests that the &{} syntax respects the number of arguments implied -# by the prototype, plus some extra tests for the (_) prototype. -sub test_proto { - my($o) = shift; - - # Create an alias, for the caller’s convenience. - *{"my$o"} = \&{"CORE::$o"}; - - my $p = prototype "CORE::$o"; - - if ($p eq '') { - $tests ++; - - eval " &CORE::$o(1) "; - like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; - - } - elsif ($p eq '_') { - $tests ++; - - eval " &CORE::$o(1,2) "; - my $desc = quotemeta op_desc($o); - like $@, qr/^Too many arguments for $desc at /, - "&$o with too many args"; - - if (!@_) { return } - - $tests += 6; - - my($in,$out) = @_; # for testing implied $_ - - # Since we have $in and $out values, we might as well test basic amper- - # sand calls, too. - - is &{"CORE::$o"}($in), $out, "&$o"; - lis [&{"CORE::$o"}($in)], [$out], "&$o in list context"; - $_ = $in; - is &{"CORE::$o"}(), $out, "&$o with no args"; - - # Since there is special code to deal with lexical $_, make sure it - # works in all cases. - undef $_; - { - my $_ = $in; - is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_"; +use File::Spec::Functions; +my $keywords_file = catfile(updir,'regen','keywords.pl'); +open my $kh, $keywords_file + or die "$0 cannot open $keywords_file: $!"; +while(<$kh>) { + if (m?__END__?..${\0} and /^[+-]/) { + chomp(my $word = $'); + if($& eq '+' || $unsupported{$word}) { + $tests ++; + ok !defined &{\&{"CORE::$word"}}, "no CORE::$word"; } - # Make sure we get the right pad under recursion - my $r; - $r = sub { - if($_[0]) { - my $_ = $in; - is &{"CORE::$o"}(), $out, - "&$o with no args uses the right lexical \$_ under recursion"; + else { + $tests += 3; + + my $proto = prototype "CORE::$word"; + *{"my$word"} = \&{"CORE::$word"}; + is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word"; + + CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/; + my $numargs = + () = $proto =~ s/;.*//r =~ /\G$protochar/g; + my $code = + "#line 1 This-line-makes-__FILE__-easier-to-test. + sub { () = (my$word(" + . ($args_for{$word} || join ",", map "\$$_", 1..$numargs) + . "))}"; + my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die); + my $my = $bd->coderef2text(eval $code or die); + is $my, $core, "inlinability of CORE::$word with parens"; + + $code = + "#line 1 This-line-makes-__FILE__-easier-to-test. + sub { () = (my$word " + . ($args_for{$word} || join ",", map "\$$_", 1..$numargs) + . ")}"; + $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die); + $my = $bd->coderef2text(eval $code or die); + is $my, $core, "inlinability of CORE::$word without parens"; + + # High-precedence tests + my $hpcode; + if (!$proto && defined $proto) { # nullary + $hpcode = "sub { () = my$word + 1 }"; } - else { - &$r(1) + elsif ($proto =~ /^;?$protochar\z/) { # unary + $hpcode = "sub { () = my$word " + . ($args_for{$word}||'$a') . ' > $b' + .'}'; + } + if ($hpcode) { + $tests ++; + $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die); + $my = $bd->coderef2text(eval $hpcode or die); + is $my, $core, "precedence of CORE::$word without parens"; } - }; - &$r(0); - my $_ = $in; - eval { - is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval" - }; - } - elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc. - my $maxargs = length $1; - $tests += 1; - eval " &CORE::$o((1)x($maxargs+1)) "; - my $desc = quotemeta op_desc($o); - like $@, qr/^Too many arguments for $desc at /, - "&$o with too many args"; - } - elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or *** - my $args = length $1; - $tests += 2; - eval " &CORE::$o((1)x($args-1)) "; - like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; - eval " &CORE::$o((1)x($args+1)) "; - like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; - } - elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or *** - my $minargs = length $1; - my $maxargs = $minargs + length $2; - $tests += 2; - eval " &CORE::$o((1)x($minargs-1)) "; - like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; - eval " &CORE::$o((1)x($maxargs+1)) "; - like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; - } - elsif ($p eq '_;$') { - $tests += 1; - - eval " &CORE::$o(1,2,3) "; - like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; - } - elsif ($p eq '@') { - # Do nothing, as we cannot test for too few or too many arguments. - } - elsif ($p =~ '^[$*;]+@\z') { - $tests ++; - $p =~ ';@'; - my $minargs = $-[0]; - eval " &CORE::$o((1)x($minargs-1)) "; - my $desc = quotemeta op_desc($o); - like $@, qr/^Not enough arguments for $desc at /, - "&$o with too few args"; - } - elsif ($p =~ /^\\%\$*\z/) { # \% and \%$$ - $tests += 5; - - eval "&CORE::$o(" . join(",", (1) x length $p) . ")"; - like $@, qr/^Too many arguments for $o at /, - "&$o with too many args"; - eval " &CORE::$o(" . join(",", (1) x (length($p)-2)) . ") "; - like $@, qr/^Not enough arguments for $o at /, - "&$o with too few args"; - my $moreargs = ",1" x (length($p) - 2); - eval " &CORE::$o([]$moreargs) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, - "&$o with array ref arg"; - eval " &CORE::$o(*foo$moreargs) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, - "&$o with typeglob arg"; - eval " &CORE::$o(bless([], 'hov')$moreargs) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, - "&$o with non-hash arg with hash overload (which does not count)"; - } - elsif ($p eq '\[$@%&*]') { - $tests += 5; - - eval " &CORE::$o(1,2) "; - like $@, qr/^Too many arguments for $o at /, - "&$o with too many args"; - eval " &CORE::$o() "; - like $@, qr/^Not enough arguments for $o at /, - "&$o with too few args"; - eval " &CORE::$o(2) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: - ) \[\$\@%&\*] at /, - "&$o with non-ref arg"; - eval " &CORE::$o(*STDOUT{IO}) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: - ) \[\$\@%&\*] at /, - "&$o with ioref arg"; - my $class = ref *DATA{IO}; - eval " &CORE::$o(bless(*DATA{IO}, 'hov')) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: - ) \[\$\@%&\*] at /, - "&$o with ioref arg with hash overload (which does not count)"; - bless *DATA{IO}, $class; - } - - else { - die "Please add tests for the $p prototype"; - } -} - -test_proto '__FILE__'; -test_proto '__LINE__'; -test_proto '__PACKAGE__'; - -is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests; -is line(), 5 , '__LINE__ does check its caller' ; ++ $tests; -is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests; - -test_proto 'abs', -5, 5; - -test_proto 'accept'; -$tests += 6; eval q{ - is &CORE::accept(qw{foo bar}), undef, "&accept"; - lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context"; - - &myaccept(my $foo, my $bar); - is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument'; - is $bar, undef, 'CORE::accept does not autovivify its second argument'; - use strict; - undef $foo; - eval { 'myaccept'->($foo, $bar) }; - like $@, qr/^Can't use an undefined value as a symbol reference at/, - 'CORE::accept will not accept undef 2nd arg under strict'; - is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict'; -}; - -test_proto 'alarm'; -test_proto 'atan2'; - -test_proto 'bind'; -$tests += 3; -is &CORE::bind('foo', 'bear'), undef, "&bind"; -lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context"; -eval { &mybind(my $foo, "bear") }; -like $@, qr/^Bad symbol for filehandle at/, - 'CORE::bind dies with undef first arg'; - -test_proto 'binmode'; -$tests += 3; -is &CORE::binmode(qw[foo bar]), undef, "&binmode"; -lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context"; -is &mybinmode(foo), undef, '&binmode with one arg'; - -test_proto 'bless'; -$tests += 3; -like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless"; -like join(" ", &CORE::bless([],'parcel')), - qr/^parcel=ARRAY(?!.* )/, "&bless in list context"; -like &mybless([]), qr/^main=ARRAY/, '&bless with one arg'; - -test_proto 'break'; -{ $tests ++; - my $tmp; - CORE::given(1) { - CORE::when(1) { - &mybreak; - $tmp = 'bad'; - } - } - is $tmp, undef, '&break'; -} - -test_proto 'caller'; -$tests += 4; -sub caller_test { - is scalar &CORE::caller, 'hadhad', '&caller'; - is scalar &CORE::caller(1), 'main', '&caller(1)'; - lis [&CORE::caller], [caller], '&caller in list context'; - lis [&CORE::caller(1)], [caller(1)], '&caller(1) in list context'; -} -sub { - package hadhad; - ::caller_test(); -}->(); - -test_proto 'chmod'; -$tests += 3; -is &CORE::chmod(), 0, '&chmod with no args'; -is &CORE::chmod(0666), 0, '&chmod'; -lis [&CORE::chmod(0666)], [0], '&chmod in list context'; - -test_proto 'chown'; -$tests += 4; -is &CORE::chown(), 0, '&chown with no args'; -is &CORE::chown(1), 0, '&chown with 1 arg'; -is &CORE::chown(1,2), 0, '&chown'; -lis [&CORE::chown(1,2)], [0], '&chown in list context'; - -test_proto 'chr', 5, "\5"; -test_proto 'chroot'; - -test_proto 'close'; -{ - last if is_miniperl; - $tests += 3; - - open my $fh, ">", \my $buffalo; - print $fh 'an address in the outskirts of Jersey'; - ok &CORE::close($fh), '&CORE::close retval'; - print $fh 'lalala'; - is $buffalo, 'an address in the outskirts of Jersey', - 'effect of &CORE::close'; - # This has to be a separate variable from $fh, as re-using the same - # variable can cause the tests to pass by accident. That actually hap- - # pened during developement, because the second close() was reading - # beyond the end of the stack and finding a $fh left over from before. - open my $fh2, ">", \($buffalo = ''); - select+(select($fh2), do { - print "Nasusiro Tokasoni"; - &CORE::close(); - print "jfd"; - is $buffalo, "Nasusiro Tokasoni", '&CORE::close with no args'; - })[0]; -} -lis [&CORE::close('tototootot')], [''], '&close in list context'; ++$tests; - -test_proto 'closedir'; -$tests += 2; -is &CORE::closedir(foo), undef, '&CORE::closedir'; -lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context'; - -test_proto 'connect'; -$tests += 2; -is &CORE::connect('foo','bar'), undef, '&connect'; -lis [&myconnect('foo','bar')], [undef], '&connect in list context'; - -test_proto 'continue'; -$tests ++; -CORE::given(1) { - CORE::when(1) { - &mycontinue(); - } - pass "&continue"; -} - -test_proto 'cos'; -test_proto 'crypt'; - -test_proto 'dbmclose'; -test_proto 'dbmopen'; -{ - last unless eval { require AnyDBM_File }; - $tests ++; - my $filename = tempfile(); - &mydbmopen(\my %db, $filename, 0666); - $db{1} = 2; $db{3} = 4; - &mydbmclose(\%db); - is scalar keys %db, 0, '&dbmopen and &dbmclose'; -} - -test_proto 'die'; -eval { dier('quinquangle') }; -is $@, "quinquangle at frob line 6.\n", '&CORE::die'; $tests ++; - -test_proto $_ for qw( - endgrent endhostent endnetent endprotoent endpwent endservent -); - -test_proto 'exit'; -$tests ++; -is runperl(prog => '&CORE::exit; END { print q-ok- }'), 'ok', - '&exit with no args'; - -test_proto 'fork'; - -test_proto 'formline'; -$tests += 3; -is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval'; -is $^A, ' 1 2', 'effect of &myformline'; -lis [&myformline('@')], [1], '&myformline in list context'; - -test_proto 'exp'; -test_proto 'fcntl'; - -test_proto 'fileno'; -$tests += 2; -is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno'; -lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx'; - -test_proto 'flock'; -test_proto 'fork'; - -test_proto 'getc'; -{ - last if is_miniperl; - $tests += 3; - local *STDIN; - open my $fh, "<", \(my $buf='falo'); - open STDIN, "<", \(my $buf2 = 'bison'); - is &mygetc($fh), 'f', '&mygetc'; - is &mygetc(), 'b', '&mygetc with no args'; - lis [&mygetc($fh)], ['a'], '&mygetc in list context'; -} - -test_proto "get$_" for qw ' - grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname - netent peername -'; - -test_proto 'getpgrp'; -eval {&mygetpgrp()}; -pass '&getpgrp with no args does not crash'; $tests++; - -test_proto "get$_" for qw ' - ppid priority protobyname protobynumber protoent - pwent pwnam pwuid servbyname servbyport servent sockname sockopt -'; - -test_proto 'gmtime'; -&CORE::gmtime; -pass '&gmtime without args does not crash'; ++$tests; - -test_proto 'hex', ff=>255; - -test_proto 'index'; -$tests += 3; -is &myindex("foffooo","o",2),4,'&index'; -lis [&myindex("foffooo","o",2)],[4],'&index in list context'; -is &myindex("foffooo","o"),1,'&index with 2 args'; - -test_proto 'int', 1.5=>1; -test_proto 'ioctl'; - -test_proto 'join'; -$tests += 2; -is &myjoin('a','b','c'), 'bac', '&join'; -lis [&myjoin('a','b','c')], ['bac'], '&join in list context'; - -test_proto 'kill'; # set up mykill alias -if ($^O ne 'riscos') { - $tests ++; - ok( &mykill(0, $$), '&kill' ); -} - -test_proto 'lc', 'A', 'a'; -test_proto 'lcfirst', 'AA', 'aA'; -test_proto 'length', 'aaa', 3; -test_proto 'link'; -test_proto 'listen'; - -test_proto 'localtime'; -&CORE::localtime; -pass '&localtime without args does not crash'; ++$tests; - -test_proto 'lock'; -$tests += 6; -is \&mylock(\$foo), \$foo, '&lock retval when passed a scalar ref'; -lis [\&mylock(\$foo)], [\$foo], '&lock in list context'; -is &mylock(\@foo), \@foo, '&lock retval when passed an array ref'; -is &mylock(\%foo), \%foo, '&lock retval when passed a ash ref'; -is &mylock(\&foo), \&foo, '&lock retval when passed a code ref'; -is \&mylock(\*foo), \*foo, '&lock retval when passed a glob ref'; - -test_proto 'log'; - -test_proto 'mkdir'; -# mkdir is tested with implicit $_ at the end, to make the test easier - -test_proto "msg$_" for qw( ctl get rcv snd ); - -test_proto 'not'; -$tests += 2; -is &mynot(1), !1, '¬'; -lis [&mynot(0)], [!0], '¬ in list context'; - -test_proto 'oct', '666', 438; - -test_proto 'open'; -$tests += 5; -$file = 'test.pl'; -ok &myopen('file'), '&open with 1 arg' or warn "1-arg open: $!"; -like <file>, qr|^#|, 'result of &open with 1 arg'; -close file; -{ - ok &myopen(my $fh, "test.pl"), 'two-arg &open'; - ok $fh, '&open autovivifies'; - like <$fh>, qr '^#', 'result of &open with 2 args'; - last if is_miniperl; - $tests +=2; - ok &myopen(my $fh2, "<", \"sharummbles"), 'retval of 3-arg &open'; - is <$fh2>, 'sharummbles', 'result of three-arg &open'; -} - -test_proto 'opendir'; -test_proto 'ord', chr(64), 64; - -test_proto 'pack'; -$tests += 2; -is &mypack("H*", '5065726c'), 'Perl', '&pack'; -lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context'; - -test_proto 'pipe'; -test_proto 'quotemeta', '$', '\$'; - -test_proto 'rand'; -$tests += 3; -like &CORE::rand, qr/^0[.\d]*\z/, '&rand'; -unlike join(" ", &CORE::rand), qr/ /, '&rand in list context'; -&cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 2 args'); - -test_proto 'readdir'; - -test_proto 'readline'; -{ - local *ARGV = *DATA; - $tests ++; - is scalar &myreadline, - "I wandered lonely as a cloud\n", '&readline w/no args'; -} -{ - last if is_miniperl; - $tests += 2; - open my $fh, "<", \(my $buff = <<END); -The Recursive Problem ---------------------- -I have a problem I cannot solve. -The problem is that I cannot solve it. -END - is &myreadline($fh), "The Recursive Problem\n", - '&readline with 1 arg'; - lis [&myreadline($fh)], [ - "---------------------\n", - "I have a problem I cannot solve.\n", - "The problem is that I cannot solve it.\n", - ], '&readline in list context'; -} - -test_proto 'readlink'; -test_proto 'readpipe'; - -use if !is_miniperl, File::Spec::Functions, qw "catfile"; -use if !is_miniperl, File::Temp, 'tempdir'; - -test_proto 'rename'; -{ - last if is_miniperl; - $tests ++; - my $dir = tempdir(uc cleanup => 1); - my $tmpfilenam = catfile $dir, 'aaa'; - open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!"; - close $fh or die "cannot close $tmpfilenam: $!"; - &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb'); - ok open(my $fh, '>', $tmpfilenam), '&rename'; -} - -test_proto 'ref', [], 'ARRAY'; - -test_proto 'reverse'; -$tests += 2; -is &myreverse('reward'), 'drawer', '&reverse'; -lis [&myreverse(qw 'dog bites man')], [qw 'man bites dog'], - '&reverse in list context'; - -test_proto 'rewinddir'; - -test_proto 'rindex'; -$tests += 3; -is &myrindex("foffooo","o",2),1,'&rindex'; -lis [&myrindex("foffooo","o",2)],[1],'&rindex in list context'; -is &myrindex("foffooo","o"),6,'&rindex with 2 args'; - -test_proto 'rmdir'; - -test_proto 'seek'; -{ - last if is_miniperl; - $tests += 1; - open my $fh, "<", \"misled" or die $!; - &myseek($fh, 2, 0); - is <$fh>, 'sled', '&seek in action'; -} - -test_proto 'seekdir'; -test_proto "sem$_" for qw "ctl get op"; - -test_proto "set$_" for qw ' - grent hostent netent priority protoent pwent servent sockopt -'; - -test_proto "shm$_" for qw "ctl get read write"; -test_proto 'shutdown'; -test_proto 'sin'; -test_proto "socket$_" for "", "pair"; - -test_proto 'sprintf'; -$tests += 2; -is &mysprintf("%x", 65), '41', '&sprintf'; -lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context'; - -test_proto 'sqrt', 4, 2; -test_proto 'symlink'; -test_proto 'syscall'; -test_proto 'sysseek'; -test_proto 'telldir'; - -test_proto 'time'; -$tests += 2; -like &mytime, '^\d+\z', '&time in scalar context'; -like join('-', &mytime), '^\d+\z', '&time in list context'; - -test_proto 'times'; -$tests += 2; -like &mytimes, '^[\d.]+\z', '× in scalar context'; -like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z', - '× in list context'; - -test_proto 'uc', 'aa', 'AA'; -test_proto 'ucfirst', 'aa', "Aa"; - -test_proto 'utime'; -$tests += 2; -is &myutime(undef,undef), 0, '&utime'; -lis [&myutime(undef,undef)], [0], '&utime in list context'; - -test_proto 'vec'; -$tests += 3; -is &myvec("foo", 0, 4), 6, '&vec'; -lis [&myvec("foo", 0, 4)], [6], '&vec in list context'; -$tmp = "foo"; -++&myvec($tmp,0,4); -is $tmp, "goo", 'lvalue &vec'; - -test_proto 'wait'; -test_proto 'waitpid'; - -test_proto 'wantarray'; -$tests += 4; -my $context; -my $cx_sub = sub { - $context = qw[void scalar list][&mywantarray + defined mywantarray()] -}; -() = &$cx_sub; -is $context, 'list', '&wantarray with caller in list context'; -scalar &$cx_sub; -is($context, 'scalar', '&wantarray with caller in scalar context'); -&$cx_sub; -is($context, 'void', '&wantarray with caller in void context'); -lis [&mywantarray],[wantarray], '&wantarray itself in list context'; -test_proto 'warn'; -{ $tests += 3; - my $w; - local $SIG{__WARN__} = sub { $w = shift }; - is &mywarn('a'), 1, '&warn retval'; - is $w, "a at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'warning'; - lis [&mywarn()], [1], '&warn retval in list context'; -} + next if ($proto =~ /\@/); + # These ops currently accept any number of args, despite their + # prototypes, if they have any: + next if $word =~ /^(?:chom?p|exec|keys|each|not|read(?:lin|pip)e + |reset|system|values|l?stat)/x; -# This is just a check to make sure we have tested everything. If we -# haven’t, then either the sub needs to be tested or the list in -# gv.c is wrong. -{ - last if is_miniperl; - require File::Spec::Functions; - my $keywords_file = - File::Spec::Functions::catfile( - File::Spec::Functions::updir,'regen','keywords.pl' - ); - open my $kh, $keywords_file - or die "$0 cannot open $keywords_file: $!"; - while(<$kh>) { - if (m?__END__?..${\0} and /^[-](.*)/) { - my $word = $1; - next if - $word =~ /^(?:CORE|and|cmp|dump|eq|ge|gt|le|lt|ne|or|x|xor)\z/; $tests ++; - ok exists &{"my$word"} - || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/), - "$word either has been tested or is not ampable"; + $code = + "sub { () = (my$word(" + . ( + $args_for{$word} + ? $args_for{$word}.',$7' + : join ",", map "\$$_", 1..$numargs+5+( + $proto =~ /;/ + ? () = $' =~ /\G$protochar/g + : 0 + ) + ) + . "))}"; + eval $code; + like $@, qr/^Too many arguments for $word/, + "inlined CORE::$word with too many args" + or warn $code; + } } } -# Add new tests above this line. - -# This test must come last (before the test count test): - -{ - last if is_miniperl; - $tests += 2; - require File::Temp ; - my $dir = File::Temp::tempdir(uc cleanup => 1); - chdir($dir); - my $_ = 'Phoo'; - ok &mymkdir(), '&mkdir'; - like <*>, qr/^phoo\z/i, 'mkdir works with implicit $_'; -} - -# ------------ END TESTING ----------- # - is curr_test, $tests+1, 'right number of tests'; done_testing; -#line 3 frob - -sub file { &CORE::__FILE__ } -sub line { &CORE::__LINE__ } # 5 -sub dier { &CORE::die(@_) } # 6 -package stribble; -sub main::pakg { &CORE::__PACKAGE__ } - -# Please do not add new tests here. -package main; -CORE::__DATA__ -I wandered lonely as a cloud -That floats on high o’er vales and hills, -And all at once I saw a crowd, -A host of golden daffodils! -Beside the lake, beneath the trees, -Fluttering, dancing, in the breeze. --- Wordsworth +CORE::__END__ |