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