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 7use strict; 8 9BEGIN { 10 chdir 't' if -d 't'; 11 require "./test.pl"; 12 set_up_inc(qw(. ../lib)); 13 skip_all_without_dynamic_extension('B'); 14 $^P |= 0x100; 15} 16 17use B; 18 19my %unsupported = map +($_=>1), qw ( 20 __DATA__ __END__ ADJUST AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK 21 and catch class cmp default defer do dump else elsif eq eval field 22 finally for foreach format ge given goto grep gt if isa last le local 23 lt m map method my ne next no or our package print printf q qq qr qw qx 24 redo require return s say sort state sub tr try unless until use 25 when while x xor y 26); 27my %args_for = ( 28 dbmopen => '%1,$2,$3', 29 (dbmclose => '%1', 30 keys => 31 values => 32 each =>)[0,1,2,1,3,1,4,1], 33 delete => '$1[2]', 34 exists => '$1[2]', 35 (push => '@1', 36 pop => 37 shift => 38 unshift => 39 splice =>)[0,1,2,1,3,1,4,1,5,1], 40); 41my %desc = ( 42 #pos => 'match position', 43); 44my $tests = 0; 45 46use File::Spec::Functions; 47my $keywords_file = catfile(updir,'regen','keywords.pl'); 48open my $kh, $keywords_file 49 or die "$0 cannot open $keywords_file: $!"; 50while(<$kh>) { 51 if (m?__END__?..${\0} and /^[+-]/) { 52 chomp(my $word = $'); 53 if($unsupported{$word}) { 54 $tests ++; 55 ok !defined &{"CORE::$word"}, "no CORE::$word"; 56 } 57 else { 58 $tests += 2; 59 60 ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}"; 61 62 my $proto = prototype "CORE::$word"; 63 { 64 no strict 'refs'; 65 *{"my$word"} = \&{"CORE::$word"}; 66 } 67 is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word"; 68 69 CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/; 70 my $numargs = 71 $word eq 'delete' || $word eq 'exists' ? 1 : 72 (() = $proto =~ s/;.*//r =~ /\G$protochar/g); 73 74 inlinable_ok($word, $args_for{$word} || join ",", map "\$$_", 1..$numargs); 75 76 next if $word eq "__CLASS__"; 77 78 # High-precedence tests 79 my $hpcode; 80 if (!$proto && defined $proto) { # nullary 81 $hpcode = "sub { () = my$word + 1 }"; 82 } 83 elsif ($proto =~ /^;?$protochar\z/) { # unary 84 $hpcode = "sub { () = my$word " 85 . ($args_for{$word}||'$a') . ' > $b' 86 .'}'; 87 } 88 if ($hpcode) { 89 $tests ++; 90 # __FILE__ won’t fold with warnings on, and then we get 91 # ‘(eval 21)’ vs ‘(eval 22)’. 92 no warnings 'numeric'; 93 my $core = op_list(eval $hpcode =~ s/my/CORE::/r or die); 94 my $my = op_list(eval $hpcode or die); 95 is $my, $core, "precedence of CORE::$word without parens"; 96 } 97 98 next if ($proto =~ /\@/); 99 # These ops currently accept any number of args, despite their 100 # prototypes, if they have any: 101 next if $word =~ /^(?:chom?p|exec|keys|each|not 102 |(?:prototyp|read(?:lin|pip))e 103 |reset|system|values|l?stat)|evalbytes/x; 104 105 $tests ++; 106 my $code = 107 "sub { () = (my$word(" 108 . ( 109 $args_for{$word} 110 ? $args_for{$word}.',$7' 111 : join ",", map "\$$_", 1..$numargs+5+( 112 $proto =~ /;/ 113 ? () = $' =~ /\G$protochar/g 114 : 0 115 ) 116 ) 117 . "))}"; 118 eval $code; 119 my $desc = $desc{$word} || $word; 120 like $@, qr/^Too many arguments for $desc/, 121 "inlined CORE::$word with too many args" 122 or warn $code; 123 124 } 125 } 126} 127 128sub op_list { 129 my @op_names; 130 local *B::OP::pushname = sub { push @op_names, shift->name }; 131 B::walkoptree(B::svref_2object($_[0])->ROOT, 'pushname'); 132 return "@op_names"; 133} 134 135sub inlinable_ok { 136 my ($word, $args, $desc_suffix) = @_; 137 $tests += 2; 138 139 $desc_suffix //= ''; 140 141 for ([with => "($args)"], [without => " $args"]) { 142 my ($preposition, $full_args) = @$_; 143 my $core_code; 144 if($word eq "__CLASS__") { 145 use feature 'state'; 146 state $classcount = 1; 147 # __CLASS__ is only valid inside a method of a class 148 $core_code = 149 "#line 1 This-line-makes-__FILE__-easier-to-test. 150 use feature 'class'; 151 no warnings 'experimental::class'; 152 class TmpClassA$classcount { method { () = (CORE::$word$full_args) } }"; 153 $classcount++; 154 } 155 else { 156 $core_code = 157 "#line 1 This-line-makes-__FILE__-easier-to-test. 158 sub { () = (CORE::$word$full_args) }"; 159 } 160 my $my_code = $core_code =~ s/CORE::$word/::my$word/r; 161 $my_code =~ s/TmpClassA/TmpClassB/; 162 my $core = op_list(eval $core_code or die); 163 my $my = op_list(eval $my_code or die); 164 is $my, $core, "inlinability of CORE::$word $preposition parens $desc_suffix"; 165 166 } 167} 168 169$tests++; 170# This subroutine is outside the warnings scope: 171sub foo { goto &CORE::abs } 172use warnings; 173$SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ }; 174foo(undef); 175 176$tests+=2; 177is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n", 178 'methods calls autovivify coresubs'; 179is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n", 180 'inherted method calls autovivify coresubs'; 181 182{ # RT #117607 183 $tests++; 184 like runperl(prog => '$foo/; \&CORE::lc', stderr => 1), 185 qr/^syntax error/, "RT #117607: \\&CORE::foo doesn't crash in error context"; 186} 187 188$tests++; 189ok eval { *CORE::exit = \42 }, 190 '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only'; 191 192inlinable_ok($_, '$_{k}', 'on hash') 193 for qw<delete exists>; 194 195@UNIVERSAL::ISA = qw( CORE ); 196is "just another "->ucfirst . "perl hacker,\n"->ucfirst, 197 "Just another Perl hacker,\n", 'coresubs do not return TARG'; 198++$tests; 199 200done_testing $tests; 201 202CORE::__END__ 203