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