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;
39
40use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature
41                                    # logic to add CORE::
42use B::Deparse;
43my $deparse = B::Deparse->new();
44
45my %SEEN;
46my %SEEN_STRENGTH;
47
48# For a given keyword, create a sub of that name,
49# then deparse 3 different assignment expressions
50# using that keyword.  See if the $expr we get back
51# matches $expected_expr.
52
53sub testit {
54    my ($keyword, $expr, $expected_expr, $lexsub) = @_;
55
56    $expected_expr //= $expr;
57    $SEEN{$keyword} = 1;
58
59    # lex=0:   () = foo($a,$b,$c)
60    # lex=1:   my ($a,$b); () = foo($a,$b,$c)
61    # lex=2:   () = foo(my $a,$b,$c)
62    for my $lex (0, 1, 2) {
63        next if ($lex and $keyword =~ /local|our|state|my/);
64        my $vars = $lex == 1 ? 'my($a, $b, $c, $d, $e);' . "\n    " : "";
65
66        if ($lex == 2) {
67            my $repl = 'my $a';
68            if ($expr =~ 'CORE::do') {
69                # do foo() is a syntax error, so B::Deparse emits
70                # do (foo()), but does not distinguish between foo and my,
71                # because it is too complicated.
72                $repl = '(my $a)';
73            }
74            s/\$a/$repl/ for $expr, $expected_expr;
75        }
76
77        my $desc = "$keyword: lex=$lex $expr => $expected_expr";
78        $desc .= " (lex sub)" if $lexsub;
79
80        my $code;
81        my $code_ref;
82        if ($lexsub) {
83            package lexsubtest;
84            no warnings 'experimental::lexical_subs';
85            use feature 'lexical_subs';
86            no strict 'vars';
87            $code = "sub { state sub $keyword; ${vars}() = $expr }";
88            $code = "use feature 'isa';\n$code" if $keyword eq "isa";
89            $code = "use feature 'switch';\n$code" if $keyword eq "break";
90            $code_ref = eval $code or die "$@ in $expr";
91        }
92        else {
93            package test;
94            use subs ();
95            import subs $keyword;
96            $code = "no strict 'vars'; sub { ${vars}() = $expr }";
97            $code = "use feature 'isa';\n$code" if $keyword eq "isa";
98            $code = "use feature 'switch';\n$code" if $keyword eq "break";
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    ADJUST
358    AUTOLOAD
359    BEGIN
360    CHECK
361    CORE
362    DESTROY
363    END
364    INIT
365    UNITCHECK
366    catch
367    class
368    default
369    defer
370    else
371    elsif
372    field
373    finally
374    for
375    foreach
376    format
377    given
378    if
379    m
380    method
381    no
382    package
383    q
384    qq
385    qr
386    qw
387    qx
388    require
389    s
390    tr
391    try
392    unless
393    until
394    use
395    when
396    while
397    y
398);
399
400# Sanity check against keyword data:
401# make sure we haven't missed any keywords,
402# and that we got the strength right.
403
404SKIP:
405{
406    skip "sanity checks when not PERL_CORE", 1 unless defined $ENV{PERL_CORE};
407    my $count = 0;
408    my $file = '../regen/keywords.pl';
409    my $pass = 1;
410    if (open my $fh, '<', $file) {
411	while (<$fh>) {
412	    last if /^__END__$/;
413	}
414	while (<$fh>) {
415	    next unless /^([+\-])(\w+)$/;
416	    my ($strength, $key) = ($1, $2);
417	    $strength = ($strength eq '+') ? 1 : 0;
418	    $count++;
419	    if (!$SEEN{$key} && !$not_tested{$key}) {
420		diag("keyword '$key' seen in $file, but not tested here!!");
421		$pass = 0;
422	    }
423	    if (exists $SEEN_STRENGTH{$key} and $SEEN_STRENGTH{$key} != $strength) {
424		diag("keyword '$key' strengh as seen in $file doen't match here!!");
425		$pass = 0;
426	    }
427	}
428    }
429    else {
430	diag("Can't open $file: $!");
431	$pass = 0;
432    }
433    # insanity check
434    if ($count < 200) {
435	diag("Saw $count keywords: less than 200!");
436	$pass = 0;
437    }
438    ok($pass, "sanity checks");
439}
440
441done_testing();
442
443__DATA__
444#
445# format:
446#   keyword args flags
447#
448# args consists of:
449#  * one of more digits indictating which lengths of args the function accepts,
450#  * or 'B' to indiate a binary infix operator,
451#  * or '@' to indicate a list function.
452#
453# Flags consists of the following (or '-' if no flags):
454#    + : strong keyword: can't be overrriden
455#    p : the args are parenthesised on deparsing;
456#    1 : parenthesising of 1st arg length is inverted
457#        so '234 p1' means: foo a1,a2;  foo(a1,a2,a3); foo(a1,a2,a3,a4)
458#    $ : on the first argument length, there is an implicit extra
459#        '$_' arg which will appear on deparsing;
460#        e.g. 12p$  will be tested as: foo(a1);     foo(a1,a2);
461#                     and deparsed as: foo(a1, $_); foo(a1,a2);
462#
463# XXX Note that we really should get this data from regen/keywords.pl
464# and regen/opcodes (augmented if necessary), rather than duplicating it
465# here.
466
467__SUB__          0     -
468abs              01    $
469accept           2     p
470alarm            01    $
471and              B     -
472atan2            2     p
473bind             2     p
474binmode          12    p
475bless            1     p
476break            0     -
477caller           0     -
478chdir            01    -
479chmod            @     p1
480chomp            @     $
481chop             @     $
482chown            @     p1
483chr              01    $
484chroot           01    $
485close            01    -
486closedir         1     -
487cmp              B     -
488connect          2     p
489continue         0     -
490cos              01    $
491crypt            2     p
492# dbmopen  handled specially
493# dbmclose handled specially
494defined          01    $+
495# delete handled specially
496die              @     p1
497# do handled specially
498# dump handled specially
499# each handled specially
500endgrent         0     -
501endhostent       0     -
502endnetent        0     -
503endprotoent      0     -
504endpwent         0     -
505endservent       0     -
506eof              01    - # also tested specially
507eq               B     -
508eval             01    $+
509evalbytes        01    $
510exec             @     p1 # also tested specially
511# exists handled specially
512exit             01    -
513exp              01    $
514fc               01    $
515fcntl            3     p
516fileno           1     -
517flock            2     p
518fork             0     -
519formline         2     p
520ge               B     -
521getc             01    -
522getgrent         0     -
523getgrgid         1     -
524getgrnam         1     -
525gethostbyaddr    2     p
526gethostbyname    1     -
527gethostent       0     -
528getlogin         0     -
529getnetbyaddr     2     p
530getnetbyname     1     -
531getnetent        0     -
532getpeername      1     -
533getpgrp          1     -
534getppid          0     -
535getpriority      2     p
536getprotobyname   1     -
537getprotobynumber 1     p
538getprotoent      0     -
539getpwent         0     -
540getpwnam         1     -
541getpwuid         1     -
542getservbyname    2     p
543getservbyport    2     p
544getservent       0     -
545getsockname      1     -
546getsockopt       3     p
547# given handled specially
548grep             123   p+ # also tested specially
549# glob handled specially
550# goto handled specially
551gmtime           01    -
552gt               B     -
553hex              01    $
554index            23    p
555int              01    $
556ioctl            3     p
557isa              B     -
558join             13    p
559# keys handled specially
560kill             123   p
561# last handled specially
562lc               01    $
563lcfirst          01    $
564le               B     -
565length           01    $
566link             2     p
567listen           2     p
568local            1     p+
569localtime        01    -
570lock             1     -
571log              01    $
572lstat            01    $
573lt               B     -
574map              123   p+ # also tested specially
575mkdir            @     p$
576msgctl           3     p
577msgget           2     p
578msgrcv           5     p
579msgsnd           3     p
580my               123   p+ # skip with 0 args, as my() => ()
581ne               B     -
582# next handled specially
583# not handled specially
584oct              01    $
585open             12345 p
586opendir          2     p
587or               B     -
588ord              01    $
589our              123   p+ # skip with 0 args, as our() => ()
590pack             123   p
591pipe             2     p
592pop              0     1 # also tested specially
593pos              01    $+
594print            @     p$+
595printf           @     p$+
596prototype        1     +
597# push handled specially
598quotemeta        01    $
599rand             01    -
600read             34    p
601readdir          1     -
602# readline handled specially
603readlink         01    $
604# readpipe handled specially
605recv             4     p
606# redo handled specially
607ref              01    $
608rename           2     p
609# XXX This code prints 'Undefined subroutine &main::require called':
610#   use subs (); import subs 'require';
611#   eval q[no strict 'vars'; sub { () = require; }]; print $@;
612# so disable for now
613#require          01    $+
614reset            01    -
615# return handled specially
616reverse          @     p1 # also tested specially
617rewinddir        1     -
618rindex           23    p
619rmdir            01    $
620say              @     p$+
621scalar           1     +
622seek             3     p
623seekdir          2     p
624select           014   p1
625semctl           4     p
626semget           3     p
627semop            2     p
628send             34    p
629setgrent         0     -
630sethostent       1     -
631setnetent        1     -
632setpgrp          2     p
633setpriority      3     p
634setprotoent      1     -
635setpwent         0     -
636setservent       1     -
637setsockopt       4     p
638shift            0     1 # also tested specially
639shmctl           3     p
640shmget           3     p
641shmread          4     p
642shmwrite         4     p
643shutdown         2     p
644sin              01    $
645sleep            01    -
646socket           4     p
647socketpair       5     p
648sort             12    p+
649# split handled specially
650# splice handled specially
651sprintf          123   p
652sqrt             01    $
653srand            01    -
654stat             01    $
655state            123   p1+ # skip with 0 args, as state() => ()
656study            01    $+
657# sub handled specially
658substr           234   p
659symlink          2     p
660syscall          2     p
661sysopen          34    p
662sysread          34    p
663sysseek          3     p
664system           @     p1 # also tested specially
665syswrite         234   p
666tell             01    -
667telldir          1     -
668tie              234   p
669tied             1     -
670time             0     -
671times            0     -
672truncate         2     p
673uc               01    $
674ucfirst          01    $
675umask            01    -
676undef            01    +
677unlink           @     p$
678unpack           12    p$
679# unshift handled specially
680untie            1     -
681utime            @     p1
682# values handled specially
683vec              3     p
684wait             0     -
685waitpid          2     p
686wantarray        0     -
687warn             @     p1
688write            01    -
689x                B     -
690xor              B     p
691