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