#!./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/) ){
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
projects / platform / upstream / perl.git / commitdiff