1#!./perl
2
3# Test the core keywords.
4#
5# Initially this test file just checked that CORE::foo got correctly
6# deparsed as CORE::foo, hence the name. It's since been expanded
7# to fully test both CORE:: versus none, plus that any arguments
8# are correctly deparsed. It also cross-checks against regen/keywords.pl
9# to make sure we've tested all keywords, and with the correct strength.
10#
11# A keyword can be either weak or strong. Strong keywords can never be
12# overridden, while weak ones can. So deparsing of weak keywords depends
13# on whether a sub of that name has been created:
14#
15# for both:         keyword(..) deparsed as keyword(..)
16# for weak:   CORE::keyword(..) deparsed as CORE::keyword(..)
17# for strong: CORE::keyword(..) deparsed as keyword(..)
18#
19# Three permutations of lex/nonlex args are checked for:
20#
21#   foo($a,$b,$c,...)
22#   foo(my $a,$b,$c,...)
23#   my ($a,$b,$c,...); foo($a,$b,$c,...)
24#
25# Note that tests for prefixing feature.pm-enabled keywords with CORE:: when
26# feature.pm is not enabled are in deparse.t, as they fit that format better.
27
28
29BEGIN {
30    require Config;
31    if (($Config::Config{extensions} !~ /\bB\b/) ){
32        print "1..0 # Skip -- Perl configured without B module\n";
33        exit 0;
34    }
35}
36
37use strict;
38use Test::More;
39plan tests => 3904;
40
41use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
42                                    # logic to add CORE::
43use B::Deparse;
44my $deparse = B::Deparse->new();
45
46my %SEEN;
47my %SEEN_STRENGTH;
48
49# For a given keyword, create a sub of that name,
50# then deparse 3 different assignment expressions
51# using that keyword.  See if the $expr we get back
52# matches $expected_expr.
53
54sub testit {
55    my ($keyword, $expr, $expected_expr, $lexsub) = @_;
56
57    $expected_expr //= $expr;
58    $SEEN{$keyword} = 1;
59
60    # lex=0:   () = foo($a,$b,$c)
61    # lex=1:   my ($a,$b); () = foo($a,$b,$c)
62    # lex=2:   () = foo(my $a,$b,$c)
63    for my $lex (0, 1, 2) {
64        next if ($lex and $keyword =~ /local|our|state|my/);
65        my $vars = $lex == 1 ? 'my($a, $b, $c, $d, $e);' . "\n    " : "";
66
67        if ($lex == 2) {
68            my $repl = 'my $a';
69            if ($expr =~ 'CORE::do') {
70                # do foo() is a syntax error, so B::Deparse emits
71                # do (foo()), but does not distinguish between foo and my,
72                # because it is too complicated.
73                $repl = '(my $a)';
74            }
75            s/\$a/$repl/ for $expr, $expected_expr;
76        }
77
78        my $desc = "$keyword: lex=$lex $expr => $expected_expr";
79        $desc .= " (lex sub)" if $lexsub;
80
81        my $code;
82        my $code_ref;
83        if ($lexsub) {
84            package lexsubtest;
85            no warnings 'experimental::lexical_subs', 'experimental::isa';
86            use feature 'lexical_subs';
87            no strict 'vars';
88            $code = "sub { state sub $keyword; ${vars}() = $expr }";
89            $code = "use feature 'isa';\n$code" if $keyword eq "isa";
90            $code_ref = eval $code or die "$@ in $expr";
91        }
92        else {
93            package test;
94            no warnings 'experimental::isa';
95            use subs ();
96            import subs $keyword;
97            $code = "no strict 'vars'; sub { ${vars}() = $expr }";
98            $code = "use feature 'isa';\n$code" if $keyword eq "isa";
99            $code_ref = eval $code or die "$@ in $expr";
100        }
101
102        my $got_text = $deparse->coderef2text($code_ref);
103
104        unless ($got_text =~ /
105    package (?:lexsub)?test;
106(?:    BEGIN \{\$\{\^WARNING_BITS\} = "[^"]+"\}
107)?    use strict 'refs', 'subs';
108    use feature [^\n]+
109(?:    (?:CORE::)?state sub \w+;
110)?    \Q$vars\E\(\) = (.*)
111\}/s) {
112            ::fail($desc);
113            ::diag("couldn't extract line from boilerplate\n");
114            ::diag($got_text);
115            return;
116        }
117
118        my $got_expr = $1;
119        is $got_expr, $expected_expr, $desc
120            or ::diag("ORIGINAL CODE:\n$code");;
121    }
122}
123
124
125# Deparse can't distinguish 'and' from '&&' etc
126my %infix_map = qw(and && or ||);
127
128# Test a keyword that is a binary infix operator, like 'cmp'.
129# $parens - "$a op $b" is deparsed as "($a op $b)"
130# $strong - keyword is strong
131
132sub do_infix_keyword {
133    my ($keyword, $parens, $strong) = @_;
134    $SEEN_STRENGTH{$keyword} = $strong;
135    my $expr = "(\$a $keyword \$b)";
136    my $nkey = $infix_map{$keyword} // $keyword;
137    my $expr = "(\$a $keyword \$b)";
138    my $exp = "\$a $nkey \$b";
139    $exp = "($exp)" if $parens;
140    $exp .= ";";
141    # with infix notation, a keyword is always interpreted as core,
142    # so no need for Deparse to disambiguate with CORE::
143    testit $keyword, "(\$a CORE::$keyword \$b)", $exp;
144    testit $keyword, "(\$a $keyword \$b)", $exp;
145    testit $keyword, "(\$a CORE::$keyword \$b)", $exp, 1;
146    testit $keyword, "(\$a $keyword \$b)", $exp, 1;
147    if (!$strong) {
148        # B::Deparse fully qualifies any sub whose name is a keyword,
149        # imported or not, since the importedness may not be reproduced by
150        # the deparsed code.  x is special.
151        my $pre = "test::" x ($keyword ne 'x');
152        testit $keyword, "$keyword(\$a, \$b)", "$pre$keyword(\$a, \$b);";
153    }
154    testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);", 1;
155}
156
157# Test a keyword that is a standard op/function, like 'index(...)'.
158# $narg   - how many args to test it with
159# $parens - "foo $a, $b" is deparsed as "foo($a, $b)"
160# $dollar - an extra '$_' arg will appear in the deparsed output
161# $strong - keyword is strong
162
163
164sub do_std_keyword {
165    my ($keyword, $narg, $parens, $dollar, $strong) = @_;
166
167    $SEEN_STRENGTH{$keyword} = $strong;
168
169    for my $core (0,1) { # if true, add CORE:: to keyword being deparsed
170        for my $lexsub (0,1) { # if true, define lex sub
171            my @code;
172            for my $do_exp(0, 1) { # first create expr, then expected-expr
173                my @args = map "\$$_", (undef,"a".."z")[1..$narg];
174                push @args, '$_'
175                    if $dollar && $do_exp && ($strong && !$lexsub or $core);
176                my $args = join(', ', @args);
177                # XXX $lex_parens is temporary, until lex subs are
178                #     deparsed properly.
179                my $lex_parens =
180                    !$core && $do_exp && $lexsub && $keyword ne 'map';
181                $args = ((!$core && !$strong) || $parens || $lex_parens)
182                    ? "($args)"
183                    :  @args
184                        ? " $args"
185                        : "";
186                push @code, (
187                    ($core && !($do_exp && $strong))
188                    ? "CORE::"
189                    : $lexsub && $do_exp
190                        ? "CORE::" x $core
191                        : $do_exp && !$core && !$strong
192                            ? "test::"
193                            : ""
194                ) . "$keyword$args;";
195            }
196            # code[0]: to run; code[1]: expected
197            testit $keyword, @code, $lexsub;
198        }
199    }
200}
201
202
203while (<DATA>) {
204    chomp;
205    s/#.*//;
206    next unless /\S/;
207
208    my @fields = split;
209    die "not 3 fields" unless @fields == 3;
210    my ($keyword, $args, $flags) = @fields;
211
212    $args = '012' if $args eq '@';
213
214    my $parens  = $flags =~ s/p//;
215    my $invert1 = $flags =~ s/1//;
216    my $dollar  = $flags =~ s/\$//;
217    my $strong  = $flags =~ s/\+//;
218    die "unrecognised flag(s): '$flags'" unless $flags =~ /^-?$/;
219
220    if ($args eq 'B') { # binary infix
221        die "$keyword: binary (B) op can't have '\$' flag\\n" if $dollar;
222        die "$keyword: binary (B) op can't have '1' flag\\n" if $invert1;
223        do_infix_keyword($keyword, $parens, $strong);
224    }
225    else {
226        my @narg = split //, $args;
227        for my $n (0..$#narg) {
228            my $narg = $narg[$n];
229            my $p = $parens;
230            $p = !$p if ($n == 0 && $invert1);
231            do_std_keyword($keyword, $narg, $p, (!$n && $dollar), $strong);
232        }
233    }
234}
235
236
237# Special cases
238
239testit dbmopen  => 'CORE::dbmopen(%foo, $bar, $baz);';
240testit dbmclose => 'CORE::dbmclose %foo;';
241
242testit delete   => 'CORE::delete $h{\'foo\'};', 'delete $h{\'foo\'};';
243testit delete   => 'CORE::delete $h{\'foo\'};', undef, 1;
244testit delete   => 'CORE::delete @h{\'foo\'};', undef, 1;
245testit delete   => 'CORE::delete $h[0];', undef, 1;
246testit delete   => 'CORE::delete @h[0];', undef, 1;
247testit delete   => 'delete $h{\'foo\'};',       'delete $h{\'foo\'};';
248
249# do is listed as strong, but only do { block } is strong;
250# do $file is weak,  so test it separately here
251testit do       => 'CORE::do $a;';
252testit do       => 'do $a;',                    'test::do($a);';
253testit do       => 'CORE::do { 1 }',
254		   "do {\n        1\n    };";
255testit do       => 'CORE::do { 1 }',
256		   "CORE::do {\n        1\n    };", 1;
257testit do       => 'do { 1 };',
258		   "do {\n        1\n    };";
259
260testit each     => 'CORE::each %bar;';
261testit each     => 'CORE::each @foo;';
262
263testit eof      => 'CORE::eof();';
264
265testit exists   => 'CORE::exists $h{\'foo\'};', 'exists $h{\'foo\'};';
266testit exists   => 'CORE::exists $h{\'foo\'};', undef, 1;
267testit exists   => 'CORE::exists &foo;', undef, 1;
268testit exists   => 'CORE::exists $h[0];', undef, 1;
269testit exists   => 'exists $h{\'foo\'};',       'exists $h{\'foo\'};';
270
271testit exec     => 'CORE::exec($foo $bar);';
272
273testit glob     => 'glob;',                       'glob($_);';
274testit glob     => 'CORE::glob;',                 'CORE::glob($_);';
275testit glob     => 'glob $a;',                    'glob($a);';
276testit glob     => 'CORE::glob $a;',              'CORE::glob($a);';
277
278testit grep     => 'CORE::grep { $a } $b, $c',    'grep({$a;} $b, $c);';
279
280testit keys     => 'CORE::keys %bar;';
281testit keys     => 'CORE::keys @bar;';
282
283testit map      => 'CORE::map { $a } $b, $c',    'map({$a;} $b, $c);';
284
285testit not      => '3 unless CORE::not $a && $b;';
286
287testit pop      => 'CORE::pop @foo;';
288
289testit push     => 'CORE::push @foo;',           'CORE::push(@foo);';
290testit push     => 'CORE::push @foo, 1;',        'CORE::push(@foo, 1);';
291testit push     => 'CORE::push @foo, 1, 2;',     'CORE::push(@foo, 1, 2);';
292
293testit readline => 'CORE::readline $a . $b;';
294
295testit readpipe => 'CORE::readpipe $a + $b;';
296
297testit reverse  => 'CORE::reverse sort(@foo);';
298
299testit shift    => 'CORE::shift @foo;';
300
301testit splice   => q{CORE::splice @foo;},                 q{CORE::splice(@foo);};
302testit splice   => q{CORE::splice @foo, 0;},              q{CORE::splice(@foo, 0);};
303testit splice   => q{CORE::splice @foo, 0, 1;},           q{CORE::splice(@foo, 0, 1);};
304testit splice   => q{CORE::splice @foo, 0, 1, 'a';},      q{CORE::splice(@foo, 0, 1, 'a');};
305testit splice   => q{CORE::splice @foo, 0, 1, 'a', 'b';}, q{CORE::splice(@foo, 0, 1, 'a', 'b');};
306
307# note that the test does '() = split...' which is why the
308# limit is optimised to 1
309testit split    => 'split;',                     q{split(' ', $_, 1);};
310testit split    => 'CORE::split;',               q{split(' ', $_, 1);};
311testit split    => 'split $a;',                  q{split(/$a/u, $_, 1);};
312testit split    => 'CORE::split $a;',            q{split(/$a/u, $_, 1);};
313testit split    => 'split $a, $b;',              q{split(/$a/u, $b, 1);};
314testit split    => 'CORE::split $a, $b;',        q{split(/$a/u, $b, 1);};
315testit split    => 'split $a, $b, $c;',          q{split(/$a/u, $b, $c);};
316testit split    => 'CORE::split $a, $b, $c;',    q{split(/$a/u, $b, $c);};
317
318testit sub      => 'CORE::sub { $a, $b }',
319			"sub {\n        \$a, \$b;\n    }\n    ;";
320
321testit system   => 'CORE::system($foo $bar);';
322
323testit unshift  => 'CORE::unshift @foo;',        'CORE::unshift(@foo);';
324testit unshift  => 'CORE::unshift @foo, 1;',     'CORE::unshift(@foo, 1);';
325testit unshift  => 'CORE::unshift @foo, 1, 2;',  'CORE::unshift(@foo, 1, 2);';
326
327testit values   => 'CORE::values %bar;';
328testit values   => 'CORE::values @foo;';
329
330
331# XXX These are deparsed wrapped in parens.
332# whether they should be, I don't know!
333
334testit dump     => '(CORE::dump);';
335testit dump     => '(CORE::dump FOO);';
336testit goto     => '(CORE::goto);',     '(goto);';
337testit goto     => '(CORE::goto FOO);', '(goto FOO);';
338testit last     => '(CORE::last);',     '(last);';
339testit last     => '(CORE::last FOO);', '(last FOO);';
340testit next     => '(CORE::next);',     '(next);';
341testit next     => '(CORE::next FOO);', '(next FOO);';
342testit redo     => '(CORE::redo);',     '(redo);';
343testit redo     => '(CORE::redo FOO);', '(redo FOO);';
344testit redo     => '(CORE::redo);',     '(redo);';
345testit redo     => '(CORE::redo FOO);', '(redo FOO);';
346testit return   => '(return);',         '(return);';
347testit return   => '(CORE::return);',   '(return);';
348
349# these are the keywords I couldn't think how to test within this framework
350
351my %not_tested = map { $_ => 1} qw(
352    __DATA__
353    __END__
354    __FILE__
355    __LINE__
356    __PACKAGE__
357    AUTOLOAD
358    BEGIN
359    CHECK
360    CORE
361    DESTROY
362    END
363    INIT
364    UNITCHECK
365    catch
366    default
367    else
368    elsif
369    for
370    foreach
371    format
372    given
373    if
374    m
375    no
376    package
377    q
378    qq
379    qr
380    qw
381    qx
382    require
383    s
384    tr
385    try
386    unless
387    until
388    use
389    when
390    while
391    y
392);
393
394# Sanity check against keyword data:
395# make sure we haven't missed any keywords,
396# and that we got the strength right.
397
398SKIP:
399{
400    skip "sanity checks when not PERL_CORE", 1 unless defined $ENV{PERL_CORE};
401    my $count = 0;
402    my $file = '../regen/keywords.pl';
403    my $pass = 1;
404    if (open my $fh, '<', $file) {
405	while (<$fh>) {
406	    last if /^__END__$/;
407	}
408	while (<$fh>) {
409	    next unless /^([+\-])(\w+)$/;
410	    my ($strength, $key) = ($1, $2);
411	    $strength = ($strength eq '+') ? 1 : 0;
412	    $count++;
413	    if (!$SEEN{$key} && !$not_tested{$key}) {
414		diag("keyword '$key' seen in $file, but not tested here!!");
415		$pass = 0;
416	    }
417	    if (exists $SEEN_STRENGTH{$key} and $SEEN_STRENGTH{$key} != $strength) {
418		diag("keyword '$key' strengh as seen in $file doen't match here!!");
419		$pass = 0;
420	    }
421	}
422    }
423    else {
424	diag("Can't open $file: $!");
425	$pass = 0;
426    }
427    # insanity check
428    if ($count < 200) {
429	diag("Saw $count keywords: less than 200!");
430	$pass = 0;
431    }
432    ok($pass, "sanity checks");
433}
434
435__DATA__
436#
437# format:
438#   keyword args flags
439#
440# args consists of:
441#  * one of more digits indictating which lengths of args the function accepts,
442#  * or 'B' to indiate a binary infix operator,
443#  * or '@' to indicate a list function.
444#
445# Flags consists of the following (or '-' if no flags):
446#    + : strong keyword: can't be overrriden
447#    p : the args are parenthesised on deparsing;
448#    1 : parenthesising of 1st arg length is inverted
449#        so '234 p1' means: foo a1,a2;  foo(a1,a2,a3); foo(a1,a2,a3,a4)
450#    $ : on the first argument length, there is an implicit extra
451#        '$_' arg which will appear on deparsing;
452#        e.g. 12p$  will be tested as: foo(a1);     foo(a1,a2);
453#                     and deparsed as: foo(a1, $_); foo(a1,a2);
454#
455# XXX Note that we really should get this data from regen/keywords.pl
456# and regen/opcodes (augmented if necessary), rather than duplicating it
457# here.
458
459__SUB__          0     -
460abs              01    $
461accept           2     p
462alarm            01    $
463and              B     -
464atan2            2     p
465bind             2     p
466binmode          12    p
467bless            1     p
468break            0     -
469caller           0     -
470chdir            01    -
471chmod            @     p1
472chomp            @     $
473chop             @     $
474chown            @     p1
475chr              01    $
476chroot           01    $
477close            01    -
478closedir         1     -
479cmp              B     -
480connect          2     p
481continue         0     -
482cos              01    $
483crypt            2     p
484# dbmopen  handled specially
485# dbmclose handled specially
486defined          01    $+
487# delete handled specially
488die              @     p1
489# do handled specially
490# dump handled specially
491# each handled specially
492endgrent         0     -
493endhostent       0     -
494endnetent        0     -
495endprotoent      0     -
496endpwent         0     -
497endservent       0     -
498eof              01    - # also tested specially
499eq               B     -
500eval             01    $+
501evalbytes        01    $
502exec             @     p1 # also tested specially
503# exists handled specially
504exit             01    -
505exp              01    $
506fc               01    $
507fcntl            3     p
508fileno           1     -
509flock            2     p
510fork             0     -
511formline         2     p
512ge               B     -
513getc             01    -
514getgrent         0     -
515getgrgid         1     -
516getgrnam         1     -
517gethostbyaddr    2     p
518gethostbyname    1     -
519gethostent       0     -
520getlogin         0     -
521getnetbyaddr     2     p
522getnetbyname     1     -
523getnetent        0     -
524getpeername      1     -
525getpgrp          1     -
526getppid          0     -
527getpriority      2     p
528getprotobyname   1     -
529getprotobynumber 1     p
530getprotoent      0     -
531getpwent         0     -
532getpwnam         1     -
533getpwuid         1     -
534getservbyname    2     p
535getservbyport    2     p
536getservent       0     -
537getsockname      1     -
538getsockopt       3     p
539# given handled specially
540grep             123   p+ # also tested specially
541# glob handled specially
542# goto handled specially
543gmtime           01    -
544gt               B     -
545hex              01    $
546index            23    p
547int              01    $
548ioctl            3     p
549isa              B     -
550join             13    p
551# keys handled specially
552kill             123   p
553# last handled specially
554lc               01    $
555lcfirst          01    $
556le               B     -
557length           01    $
558link             2     p
559listen           2     p
560local            1     p+
561localtime        01    -
562lock             1     -
563log              01    $
564lstat            01    $
565lt               B     -
566map              123   p+ # also tested specially
567mkdir            @     p$
568msgctl           3     p
569msgget           2     p
570msgrcv           5     p
571msgsnd           3     p
572my               123   p+ # skip with 0 args, as my() => ()
573ne               B     -
574# next handled specially
575# not handled specially
576oct              01    $
577open             12345 p
578opendir          2     p
579or               B     -
580ord              01    $
581our              123   p+ # skip with 0 args, as our() => ()
582pack             123   p
583pipe             2     p
584pop              0     1 # also tested specially
585pos              01    $+
586print            @     p$+
587printf           @     p$+
588prototype        1     +
589# push handled specially
590quotemeta        01    $
591rand             01    -
592read             34    p
593readdir          1     -
594# readline handled specially
595readlink         01    $
596# readpipe handled specially
597recv             4     p
598# redo handled specially
599ref              01    $
600rename           2     p
601# XXX This code prints 'Undefined subroutine &main::require called':
602#   use subs (); import subs 'require';
603#   eval q[no strict 'vars'; sub { () = require; }]; print $@;
604# so disable for now
605#require          01    $+
606reset            01    -
607# return handled specially
608reverse          @     p1 # also tested specially
609rewinddir        1     -
610rindex           23    p
611rmdir            01    $
612say              @     p$+
613scalar           1     +
614seek             3     p
615seekdir          2     p
616select           014   p1
617semctl           4     p
618semget           3     p
619semop            2     p
620send             34    p
621setgrent         0     -
622sethostent       1     -
623setnetent        1     -
624setpgrp          2     p
625setpriority      3     p
626setprotoent      1     -
627setpwent         0     -
628setservent       1     -
629setsockopt       4     p
630shift            0     1 # also tested specially
631shmctl           3     p
632shmget           3     p
633shmread          4     p
634shmwrite         4     p
635shutdown         2     p
636sin              01    $
637sleep            01    -
638socket           4     p
639socketpair       5     p
640sort             @     p1+
641# split handled specially
642# splice handled specially
643sprintf          123   p
644sqrt             01    $
645srand            01    -
646stat             01    $
647state            123   p1+ # skip with 0 args, as state() => ()
648study            01    $+
649# sub handled specially
650substr           234   p
651symlink          2     p
652syscall          2     p
653sysopen          34    p
654sysread          34    p
655sysseek          3     p
656system           @     p1 # also tested specially
657syswrite         234   p
658tell             01    -
659telldir          1     -
660tie              234   p
661tied             1     -
662time             0     -
663times            0     -
664truncate         2     p
665uc               01    $
666ucfirst          01    $
667umask            01    -
668undef            01    +
669unlink           @     p$
670unpack           12    p$
671# unshift handled specially
672untie            1     -
673utime            @     p1
674# values handled specially
675vec              3     p
676wait             0     -
677waitpid          2     p
678wantarray        0     -
679warn             @     p1
680write            01    -
681x                B     -
682xor              B     p
683