1#!./perl 2 3# This script tests the inlining and prototype of CORE:: subs. Any generic 4# tests that are not specific to &foo-style calls should go in this 5# file, too. 6 7BEGIN { 8 chdir 't' if -d 't'; 9 @INC = qw(. ../lib); 10 require "test.pl"; 11 skip_all_without_dynamic_extension('B'); 12 $^P |= 0x100; 13} 14 15use B::Deparse; 16my $bd = new B::Deparse '-p'; 17 18my %unsupported = map +($_=>1), qw ( 19 __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and 20 cmp default do dump else elsif eq eval for foreach 21 format ge given goto grep gt if last le local lt m map my ne next 22 no or our package print printf q qq qr qw qx redo require 23 return s say sort state sub tr unless until use 24 when while x xor y 25); 26my %args_for = ( 27 dbmopen => '%1,$2,$3', 28 (dbmclose => '%1', 29 keys => 30 values => 31 each =>)[0,1,2,1,3,1,4,1], 32 delete => '$1[2]', 33 exists => '$1[2]', 34 (push => '@1', 35 pop => 36 shift => 37 unshift => 38 splice =>)[0,1,2,1,3,1,4,1,5,1], 39); 40my %desc = ( 41 pos => 'match position', 42); 43 44use File::Spec::Functions; 45my $keywords_file = catfile(updir,'regen','keywords.pl'); 46open my $kh, $keywords_file 47 or die "$0 cannot open $keywords_file: $!"; 48while(<$kh>) { 49 if (m?__END__?..${\0} and /^[+-]/) { 50 chomp(my $word = $'); 51 if($unsupported{$word}) { 52 $tests ++; 53 ok !defined &{"CORE::$word"}, "no CORE::$word"; 54 } 55 else { 56 $tests += 4; 57 58 ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}"; 59 60 my $proto = prototype "CORE::$word"; 61 *{"my$word"} = \&{"CORE::$word"}; 62 is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word"; 63 64 CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/; 65 my $numargs = 66 $word eq 'delete' || $word eq 'exists' ? 1 : 67 (() = $proto =~ s/;.*//r =~ /\G$protochar/g); 68 my $code = 69 "#line 1 This-line-makes-__FILE__-easier-to-test. 70 sub { () = (my$word(" 71 . ($args_for{$word} || join ",", map "\$$_", 1..$numargs) 72 . "))}"; 73 my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die); 74 my $my = $bd->coderef2text(eval $code or die); 75 is $my, $core, "inlinability of CORE::$word with parens"; 76 77 $code = 78 "#line 1 This-line-makes-__FILE__-easier-to-test. 79 sub { () = (my$word " 80 . ($args_for{$word} || join ",", map "\$$_", 1..$numargs) 81 . ")}"; 82 $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die); 83 $my = $bd->coderef2text(eval $code or die); 84 is $my, $core, "inlinability of CORE::$word without parens"; 85 86 # High-precedence tests 87 my $hpcode; 88 if (!$proto && defined $proto) { # nullary 89 $hpcode = "sub { () = my$word + 1 }"; 90 } 91 elsif ($proto =~ /^;?$protochar\z/) { # unary 92 $hpcode = "sub { () = my$word " 93 . ($args_for{$word}||'$a') . ' > $b' 94 .'}'; 95 } 96 if ($hpcode) { 97 $tests ++; 98 $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die); 99 $my = $bd->coderef2text(eval $hpcode or die); 100 is $my, $core, "precedence of CORE::$word without parens"; 101 } 102 103 next if ($proto =~ /\@/); 104 # These ops currently accept any number of args, despite their 105 # prototypes, if they have any: 106 next if $word =~ /^(?:chom?p|exec|keys|each|not 107 |(?:prototyp|read(?:lin|pip))e 108 |reset|system|values|l?stat)|evalbytes/x; 109 110 $tests ++; 111 $code = 112 "sub { () = (my$word(" 113 . ( 114 $args_for{$word} 115 ? $args_for{$word}.',$7' 116 : join ",", map "\$$_", 1..$numargs+5+( 117 $proto =~ /;/ 118 ? () = $' =~ /\G$protochar/g 119 : 0 120 ) 121 ) 122 . "))}"; 123 eval $code; 124 my $desc = $desc{$word} || $word; 125 like $@, qr/^Too many arguments for $desc/, 126 "inlined CORE::$word with too many args" 127 or warn $code; 128 129 } 130 } 131} 132 133$tests++; 134# This subroutine is outside the warnings scope: 135sub foo { goto &CORE::abs } 136use warnings; 137$SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ }; 138foo(undef); 139 140$tests+=2; 141is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n", 142 'methods calls autovivify coresubs'; 143is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n", 144 'inherted method calls autovivify coresubs'; 145 146{ # RT #117607 147 $tests++; 148 like runperl(prog => '$foo/; \&CORE::lc', stderr => 1), 149 qr/^syntax error/, "RT #117607: \\&CORE::foo doesn't crash in error context"; 150} 151 152$tests++; 153ok eval { *CORE::exit = \42 }, 154 '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only'; 155 156@UNIVERSAL::ISA = CORE; 157is "just another "->ucfirst . "perl hacker,\n"->ucfirst, 158 "Just another Perl hacker,\n", 'coresubs do not return TARG'; 159++$tests; 160 161done_testing $tests; 162 163CORE::__END__ 164