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