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