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