overhaul dist/B-Deparse/t/core.t

Originally, this test file just checked that CORE::foo got correctly
deparsed as CORE::foo, hence the name. This commit expands it
to fully test both CORE:: verses none, plus that any arguments
are correctly deparsed. It tests many more keywords, and it also
cross-checks against regen/keywords.pl to make sure we've tested all
keywords, and with the correct strength.

(There is very little of the original file left.)

1 files changed, 565 insertions, 88 deletions

diff --git a/dist/B-Deparse/t/core.t b/dist/B-Deparse/t/core.t
index de8d2802c2..433d26586f 100644
--- a/dist/B-Deparse/t/core.t
+++ b/dist/B-Deparse/t/core.t
@@ -1,5 +1,25 @@
 #!./perl
 
+# Test the core keywords.
+#
+# Initially this test file just checked that CORE::foo got correctly
+# deparsed as CORE::foo, hence the name. It's since been expanded
+# to fully test both CORE:: verses none, plus that any arguments
+# are correctly deparsed. It also cross-checks against regen/keywords.pl
+# to make sure we've tested all keywords, and with the correct strength.
+#
+# A keyword can be either weak or strong. Strong keywords can never be
+# overridden, while weak ones can. So deparsing of weak keywords depends
+# on whether a sub of that name has been created:
+#
+# for both:         keyword(..) deparsed as keyword(..)
+# for weak:   CORE::keyword(..) deparsed as CORE::keyword(..)
+# for strong: CORE::keyword(..) deparsed as keyword(..)
+#
+# Note that tests for prefixing feature.pm-enabled keywords with CORE:: when
+# feature.pm is not enabled are in deparse.t, as they fit that format better.
+
+
 BEGIN {
     require Config;
     if (($Config::Config{extensions} !~ /\bB\b/) ){
@@ -10,101 +30,558 @@ BEGIN {
 
 use strict;
 use Test::More;
+plan tests => 707;
+
 use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
                                     # logic to add CORE::
-
-# Many functions appear in multiple lists, so that shift() and shift(foo)
-# are both tested.
-# For lists, we test 0 to 2 arguments.
-my @nary = (
- # nullary functions
-     [qw( abs alarm break chr cos chop close chdir chomp chmod chown
-          chroot caller continue die dump exp exit exec endgrent
-          endpwent endnetent endhostent endservent
-          endprotoent evalbytes fc fork glob
-          getppid getpwent getprotoent gethostent getnetent getservent
-          getgrent getlogin getc gmtime hex int lc log lstat length
-          lcfirst localtime mkdir ord oct pop quotemeta ref rand
-          rmdir reset reverse readlink select setpwent setgrent
-          shift sin sleep sqrt srand stat __SUB__ system tell time times
-          uc utime umask unlink ucfirst wantarray warn wait write    )],
- # unary
-     [qw( abs alarm bless binmode chr cos chop close chdir chomp
-          chmod chown chroot closedir die do dump exp exit exec
-          each evalbytes fc fileno getpgrp getpwnam getpwuid getpeername
-          getprotobyname getprotobynumber gethostbyname
-          getnetbyname getsockname getgrnam getgrgid
-          getc glob gmtime hex int join keys kill lc
-          log lock lstat length lcfirst localtime
-          mkdir ord oct open pop push pack quotemeta
-          ref rand rmdir reset reverse readdir readlink
-          rewinddir select setnetent sethostent setservent
-          setprotoent shift sin sleep sprintf splice sqrt
-          srand stat system tell tied telldir uc utime umask
-          unpack unlink unshift untie ucfirst values warn write )],
- # binary, but not infix
-     [qw( atan2 accept bind binmode chop chomp chmod chown crypt
-          connect die exec flock formline getpriority gethostbyaddr
-          getnetbyaddr getservbyname getservbyport index join kill
-          link listen mkdir msgget open opendir push pack pipe
-          rename rindex reverse seekdir semop setpgrp shutdown
-          sprintf splice substr system symlink syscall syswrite
-          tie truncate utime unpack unlink warn waitpid           )],
- # ternary
-     [qw( fcntl getsockopt index ioctl join  kill  msgctl
-          msgsnd open push pack  read  rindex  seek  send
-          semget setpriority shmctl shmget sprintf splice
-          substr sysopen sysread sysseek syswrite tie vec )],
- # quaternary
-     [qw( open read  recv  send  select  semctl  setsockopt  shmread
-          shmwrite socket splice substr sysopen sysread syswrite tie )],
- # quinary
-     [qw( msgrcv open socketpair splice )]
-);
-
 use B::Deparse;
 my $deparse = new B::Deparse;
 
-sub CORE_test {
-  my($keyword,$expr,$name) = @_;
-  package test;
-  use subs ();
-  import subs $keyword;
-  ::like
-      $deparse->coderef2text(
-         eval "no strict 'vars'; sub { () = $expr }" or die "$@in $expr"
-      ),
-      qr/\bCORE::$keyword.*[);]/,
-      $name||$keyword  
+my %SEEN;
+my %SEEN_STRENGH;
+
+# for a given keyword, create a sub of that name, then
+# deparse "() = $expr", and see if it matches $expected_expr
+
+sub testit {
+    my ($keyword, $expr, $expected_expr) = @_;
+
+    $expected_expr //= $expr;
+    $SEEN{$keyword} = 1;
+
+    my $code_ref;
+    {
+	package test;
+	use subs ();
+	import subs $keyword;
+	$code_ref = eval "no strict 'vars'; sub { () = $expr }"
+			or die "$@ in $expr";
+    }
+
+    my $got_text = $deparse->coderef2text($code_ref);
+
+    unless ($got_text =~ /^{
+    package test;
+    use strict 'refs', 'subs';
+    use feature .*
+    \(\) = (.*)
+}/s) {
+	::fail("$keyword:   $expr");
+	::diag("couldn't extract line from boilerplate\n");
+	::diag($got_text);
+	return;
+    }
+
+    my $got_expr = $1;
+    is $got_expr, $expected_expr, "$keyword: $expr => $expected_expr";
 }
 
-for my $argc(0..$#nary) {
- for(@{$nary[$argc]}) {
-  CORE_test
-     $_,
-    "CORE::$_(" . join(',',map "\$$_", (undef,"a".."z")[1..$argc]) . ")",
-    "$_, $argc argument" . "s"x($argc != 1);
- }
+
+# Deparse can't distinguish 'and' from '&&' etc
+my %infix_map = qw(and && or ||);
+
+
+# test a keyword that is a binary infix operator, like 'cmp'.
+# $parens - "$a op $b" is deparsed as "($a op $b)"
+# $strong - keyword is strong
+
+sub do_infix_keyword {
+    my ($keyword, $parens, $strong) = @_;
+    $SEEN_STRENGH{$keyword} = $strong;
+    my $expr = "(\$a $keyword \$b)";
+    my $nkey = $infix_map{$keyword} // $keyword;
+    my $expr = "(\$a $keyword \$b)";
+    my $exp = "\$a $nkey \$b";
+    $exp = "($exp)" if $parens;
+    $exp .= ";";
+    # with infix notation, a keyword is always interpreted as core,
+    # so no need for Deparse to disambiguate with CORE::
+    testit $keyword, "(\$a CORE::$keyword \$b)", $exp;
+    testit $keyword, "(\$a $keyword \$b)", $exp;
+    if (!$strong) {
+	testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);";
+    }
+}
+
+# test a keyword that is as tandard op/function, like 'index(...)'.
+# narg    - how many args to test it with
+# $parens - "foo $a, $b" is deparsed as "foo($a, $b)"
+# $dollar - an extra '$_' arg will appear in the deparsed output
+# $strong - keyword is strong
+
+
+sub do_std_keyword {
+    my ($keyword, $narg, $parens, $dollar, $strong) = @_;
+
+    $SEEN_STRENGH{$keyword} = $strong;
+
+    for my $core (0,1) { # if true, add CORE:: to keyword being deparsed
+	my @code;
+	for my $do_exp(0, 1) { # first create expr, then expected-expr
+	    my @args = map "\$$_", (undef,"a".."z")[1..$narg];
+	    push @args, '$_' if $dollar && $do_exp && ($strong || $core);
+	    my $args = join(', ', @args);
+	    $args = ((!$core && !$strong) || $parens)
+			? "($args)"
+			:  @args ? " $args" : "";
+	    push @code, (($core && !($do_exp && $strong)) ? "CORE::" : "")
+						       	. "$keyword$args;";
+	}
+	testit $keyword, @code; # code[0]: to run; code[1]: expected
+    }
+}
+
+
+while (<DATA>) {
+    chomp;
+    s/#.*//;
+    next unless /\S/;
+
+    my @fields = split;
+    die "not 3 fields" unless @fields == 3;
+    my ($keyword, $args, $flags) = @fields;
+
+    $args = '012' if $args eq '@';
+
+    my $parens  = $flags =~ s/p//;
+    my $invert1 = $flags =~ s/1//;
+    my $dollar  = $flags =~ s/\$//;
+    my $strong  = $flags =~ s/\+//;
+    die "unrecognised flag(s): '$flags'" unless $flags =~ /^-?$/;
+
+    if ($args eq 'B') { # binary infix
+	die "$keyword: binary (B) op can't have '\$' flag\\n" if $dollar;
+	die "$keyword: binary (B) op can't have '1' flag\\n" if $invert1;
+	do_infix_keyword($keyword, $parens, $strong);
+    }
+    else {
+	my @narg = split //, $args;
+	for my $n (0..$#narg) {
+	    my $narg = $narg[$n];
+	    my $p = $parens;
+	    $p = !$p if ($n == 0 && $invert1);
+	    do_std_keyword($keyword, $narg, $p, (!$n && $dollar), $strong);
+	}
+    }
 }
 
+
 # Special cases
-CORE_test dbmopen => 'CORE::dbmopen %foo, $bar, $baz';
-CORE_test dbmclose => 'CORE::dbmclose %foo';
-CORE_test eof => 'CORE::eof $foo', 'eof $arg';
-CORE_test eof => 'CORE::eof', 'eof';
-CORE_test eof => 'CORE::eof()', 'eof()';
-CORE_test exec => 'CORE::exec $foo $bar', 'exec PROGRAM LIST';
-CORE_test each => 'CORE::each %bar', 'each %hash';
-CORE_test keys => 'CORE::keys %bar', 'keys %hash';
-CORE_test reverse => 'CORE::reverse sort @foo', 'reverse sort';
-CORE_test system => 'CORE::system $foo $bar', 'system PROGRAM LIST';
-CORE_test values => 'CORE::values %bar', 'values %hash';
-CORE_test not => '3 unless CORE::not $a && $b', 'not';
-CORE_test readline => 'CORE::readline $a.$b', 'readline';
-CORE_test readpipe => 'CORE::readpipe $a+$b', 'readpipe';
-
-# Tests for prefixing feature.pm-enabled keywords with CORE:: when
-# feature.pm is not enabled are in deparse.t, as they fit that for-
-# mat better.
-
-done_testing();
+
+testit dbmopen  => 'CORE::dbmopen(%foo, $bar, $baz);';
+testit dbmclose => 'CORE::dbmclose %foo;';
+
+testit delete   => 'CORE::delete $h{\'foo\'};', 'delete $h{\'foo\'};';
+testit delete   => 'delete $h{\'foo\'};',       'delete $h{\'foo\'};';
+
+# do is listed as strong, but only do { block } is strong;
+# do $file is weak,  so test it separately here
+testit do       => 'CORE::do $a;';
+testit do       => 'do $a;',                     'do($a);';
+testit do       => 'CORE::do { 1 }',
+		   "do {\n        1\n    };";
+testit do       => 'do { 1 };',
+		   "do {\n        1\n    };";
+
+testit each     => 'CORE::each %bar;';
+
+testit eof      => 'CORE::eof();';
+
+testit exists   => 'CORE::exists $h{\'foo\'};', 'exists $h{\'foo\'};';
+testit exists   => 'exists $h{\'foo\'};',       'exists $h{\'foo\'};';
+
+testit exec     => 'CORE::exec($foo $bar);';
+
+# glob($x) gets deparsed as glob("$x").
+# Whether this is correct, I don't know; but I didn't want
+# to start messing with the whole glob/readline/<> mess - DAPM.
+testit glob     => 'glob;',                       'glob("$_");';
+testit glob     => 'CORE::glob;',                 'glob("$_");';
+testit glob     => 'glob $a;',                    'glob("$a");';
+testit glob     => 'CORE::glob $a;',              'glob("$a");';
+
+testit grep     => 'CORE::grep { $a } $b, $c',    'grep({$a;} $b, $c);';
+
+testit keys     => 'CORE::keys %bar;';
+
+testit map      => 'CORE::map { $a } $b, $c',    'map({$a;} $b, $c);';
+
+testit not      => '3 unless CORE::not $a && $b;';
+
+testit readline => 'CORE::readline $a . $b;';
+
+testit readpipe => 'CORE::readpipe $a + $b;';
+
+testit reverse  => 'CORE::reverse sort(@foo);';
+
+# note that the test does '() = split...' which is why the
+# limit is optimised to 1
+testit split    => 'split;',                     q{split(' ', $_, 1);};
+testit split    => 'CORE::split;',               q{split(' ', $_, 1);};
+testit split    => 'split $a;',                  q{split(/$a/u, $_, 1);};
+testit split    => 'CORE::split $a;',            q{split(/$a/u, $_, 1);};
+testit split    => 'split $a, $b;',              q{split(/$a/u, $b, 1);};
+testit split    => 'CORE::split $a, $b;',        q{split(/$a/u, $b, 1);};
+testit split    => 'split $a, $b, $c;',          q{split(/$a/u, $b, $c);};
+testit split    => 'CORE::split $a, $b, $c;',    q{split(/$a/u, $b, $c);};
+
+testit sub      => 'CORE::sub { $a, $b }',
+			"sub {\n        \$a, \$b;\n    }\n    ;";
+
+testit system   => 'CORE::system($foo $bar);';
+
+testit values   => 'CORE::values %bar;';
+
+
+# XXX These are deparsed wrapped in parens.
+# whether they should be, I don't know!
+
+testit dump     => '(CORE::dump);';
+testit dump     => '(CORE::dump FOO);';
+testit goto     => '(CORE::goto);',     '(goto);';
+testit goto     => '(CORE::goto FOO);', '(goto FOO);';
+testit last     => '(CORE::last);',     '(last);';
+testit last     => '(CORE::last FOO);', '(last FOO);';
+testit next     => '(CORE::next);',     '(next);';
+testit next     => '(CORE::next FOO);', '(next FOO);';
+testit redo     => '(CORE::redo);',     '(redo);';
+testit redo     => '(CORE::redo FOO);', '(redo FOO);';
+testit redo     => '(CORE::redo);',     '(redo);';
+testit redo     => '(CORE::redo FOO);', '(redo FOO);';
+testit return   => '(return);',         '(return);';
+testit return   => '(CORE::return);',   '(return);';
+
+# these are the keywords I couldn't think how to test within this framework
+
+my %not_tested = map { $_ => 1} qw(
+    __DATA__
+    __END__
+    __FILE__
+    __LINE__
+    __PACKAGE__
+    __SUB__
+    AUTOLOAD
+    BEGIN
+    CHECK
+    CORE
+    DESTROY
+    END
+    INIT
+    UNITCHECK
+    default
+    else
+    elsif
+    for
+    foreach
+    format
+    given
+    if
+    m
+    no
+    package
+    q
+    qq
+    qr
+    qw
+    qx
+    require
+    s
+    tr
+    unless
+    until
+    use
+    when
+    while
+    y
+);
+
+
+
+# Sanity check against keyword data:
+# make sure we haven't missed any keywords,
+# and that we got the strength right.
+
+if (defined $ENV{PERL_CORE} and $^O ne 'VMS') {
+    my $count = 0;
+    my $file = '../../regen/keywords.pl';
+    my $pass = 1;
+    if (open my $fh, '<', $file) {
+	while (<$fh>) {
+	    last if /^__END__$/;
+	}
+	while (<$fh>) {
+	    next unless /^([+\-])(\w+)$/;
+	    my ($strength, $key) = ($1, $2);
+	    $strength = ($strength eq '+') ? 1 : 0;
+	    $count++;
+	    if (!$SEEN{$key} && !$not_tested{$key}) {
+		diag("keyword '$key' seen in $file, but not tested here!!");
+		$pass = 0;
+	    }
+	    if (exists $SEEN_STRENGH{$key} and $SEEN_STRENGH{$key} != $strength) {
+		diag("keyword '$key' strengh as seen in $file doen't match here!!");
+		$pass = 0;
+	    }
+	}
+    }
+    else {
+	diag("Can't open $file: $!");
+	$pass = 0;
+    }
+    # insanity check
+    if ($count < 200) {
+	diag("Saw $count keywords: less than 200!");
+	$pass = 0;
+    }
+    ok($pass, "sanity checks");
+}
+
+
+
+__DATA__
+#
+# format:
+#   keyword args flags
+#
+# args consists of:
+#  * one of more digits indictating which lengths of args the function accepts,
+#  * or 'B' to indiate a binary infix operator,
+#  * or '@' to indicate a list function.
+#
+# Flags consists of the following (or '-' if no flags):
+#    + : strong keyword: can't be overrriden
+#    p : the args are parenthesised on deparsing;
+#    1 : parenthesising of 1st arg length is inverted
+#        so '234 p1' means: foo a1,a2;  foo(a1,a2,a3); foo(a1,a2,a3,a4)
+#    $ : on the first argument length, there is an implicit extra
+#        '$_' arg which will appear on deparsing;
+#        e.g. 12p$  will be tested as: foo(a1);     foo(a1,a2);
+#                     and deparsed as: foo(a1, $_); foo(a1,a2);
+#
+# XXX Note that we really should get this data from regen/keywords.pl
+# and regen/opcodes (augmented if necessary), rather than duplicating it
+# here.
+
+__SUB__          0     -
+abs              01    $
+accept           2     p
+alarm            01    $
+and              B     -
+atan2            2     p
+bind             2     p
+binmode          12    p
+bless            1     p
+break            0     -
+caller           0     -
+chdir            01    -
+chmod            @     p1
+chomp            @     $
+chop             @     $
+chown            @     p1
+chr              01    $
+chroot           01    $
+close            01    -
+closedir         1     -
+cmp              B     -
+connect          2     p
+continue         0     -
+cos              01    $
+crypt            2     p
+# dbmopen  handled specially
+# dbmclose handled specially
+defined          01    $+
+# delete handled specially
+die              @     p1
+# do handled specially
+# dump handled specially
+each             1     - # also tested specially
+endgrent         0     -
+endhostent       0     -
+endnetent        0     -
+endprotoent      0     -
+endpwent         0     -
+endservent       0     -
+eof              01    - # also tested specially
+eq               B     -
+eval             01    $+
+evalbytes        01    $
+exec             @     p1 # also tested specially
+# exists handled specially
+exit             01    -
+exp              01    $
+fc               01    $
+fcntl            3     p
+fileno           1     -
+flock            2     p
+fork             0     -
+formline         2     p
+ge               B     -
+getc             01    -
+getgrent         0     -
+getgrgid         1     -
+getgrnam         1     -
+gethostbyaddr    2     p
+gethostbyname    1     -
+gethostent       0     -
+getlogin         0     -
+getnetbyaddr     2     p
+getnetbyname     1     -
+getnetent        0     -
+getpeername      1     -
+getpgrp          1     -
+getppid          0     -
+getpriority      2     p
+getprotobyname   1     -
+getprotobynumber 1     p
+getprotoent      0     -
+getpwent         0     -
+getpwnam         1     -
+getpwuid         1     -
+getservbyname    2     p
+getservbyport    2     p
+getservent       0     -
+getsockname      1     -
+getsockopt       3     p
+# given handled specially
+grep             123   p+ # also tested specially
+# glob handled specially
+# goto handled specially
+gmtime           01    -
+gt               B     -
+hex              01    $
+index            23    p
+int              01    $
+ioctl            3     p
+join             123   p
+keys             1     - # also tested specially
+kill             123   p
+# last handled specially
+lc               01    $
+lcfirst          01    $
+le               B     -
+length           01    $
+link             2     p
+listen           2     p
+local            1     p+
+localtime        01    -
+lock             1     -
+log              01    $
+lstat            01    $
+lt               B     -
+map              123   p+ # also tested specially
+mkdir            @     p$
+msgctl           3     p
+msgget           2     p
+msgrcv           5     p
+msgsnd           3     p
+my               123   p+ # skip with 0 args, as my() => ()
+ne               B     -
+# next handled specially
+# not handled specially
+oct              01    $
+open             12345 p
+opendir          2     p
+or               B     -
+ord              01    $
+our              123   p+ # skip with 0 args, as our() => ()
+pack             123   p
+pipe             2     p
+pop              01    1
+pos              01    $+
+print            @     p$+
+printf           @     p$+
+prototype        1     +
+push             123   p
+quotemeta        01    $
+rand             01    -
+read             34    p
+readdir          1     -
+# readline handled specially
+readlink         01    $
+# readpipe handled specially
+recv             4     p
+# redo handled specially
+ref              01    $
+rename           2     p
+# XXX This code prints 'Undefined subroutine &main::require called':
+#   use subs (); import subs 'require';
+#   eval q[no strict 'vars'; sub { () = require; }]; print $@;
+# so disable for now
+#require          01    $+
+reset            01    -
+# return handled specially
+reverse          @     p1 # also tested specially
+rewinddir        1     -
+rindex           23    p
+rmdir            01    $
+say              @     p$+
+scalar           1     +
+seek             3     p
+seekdir          2     p
+select           014   p1
+semctl           4     p
+semget           3     p
+semop            2     p
+send             34    p
+setgrent         0     -
+sethostent       1     -
+setnetent        1     -
+setpgrp          2     p
+setpriority      3     p
+setprotoent      1     -
+setpwent         0     -
+setservent       1     -
+setsockopt       4     p
+shift            01    1
+shmctl           3     p
+shmget           3     p
+shmread          4     p
+shmwrite         4     p
+shutdown         2     p
+sin              01    $
+sleep            01    -
+socket           4     p
+socketpair       5     p
+sort             @     p+
+# split handled specially
+splice           12345 p
+sprintf          123   p
+sqrt             01    $
+srand            01    -
+stat             01    $
+state            123   p+ # skip with 0 args, as state() => ()
+study            01    $+
+# sub handled specially
+substr           234   p
+symlink          2     p
+syscall          2     p
+sysopen          34    p
+sysread          34    p
+sysseek          3     p
+system           @     p1 # also tested specially
+syswrite         234   p
+tell             01    -
+telldir          1     -
+tie              234   p
+tied             1     -
+time             0     -
+times            0     -
+truncate         2     p
+uc               01    $
+ucfirst          01    $
+umask            01    -
+undef            01    +
+unlink           @     p$
+unpack           12    p$
+unshift          1     p
+untie            1     -
+utime            @     p1
+values           1     - # also tested specially
+vec              3     p
+wait             0     -
+waitpid          2     p
+wantarray        0     -
+warn             @     p1
+write            01    -
+x                B     -
+xor              B     p