t/op/coresubs.t

   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
   7 BEGIN {
   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
  15 use B::Deparse;
  16 my $bd = new B::Deparse '-p';
  17
  18 my %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 );
  26 my %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 );
  40 my %desc = (
  41   pos => 'match position',
  42 );
  43
  44 use File::Spec::Functions;
  45 my $keywords_file = catfile(updir,'regen','keywords.pl');
  46 open my $kh, $keywords_file
  47    or die "$0 cannot open $keywords_file: $!";
  48 while(<$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 += 2;
  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
  69       inlinable_ok($word, $args_for{$word} || join ",", map "\$$_", 1..$numargs);
  70
  71       # High-precedence tests
  72       my $hpcode;
  73       if (!$proto && defined $proto) { # nullary
  74          $hpcode = "sub { () = my$word + 1 }";
  75       }
  76       elsif ($proto =~ /^;?$protochar\z/) { # unary
  77          $hpcode = "sub { () = my$word "
  78                            . ($args_for{$word}||'$a') . ' > $b'
  79                        .'}';
  80       }
  81       if ($hpcode) {
  82          $tests ++;
  83          # __FILE__ won’t fold with warnings on, and then we get
  84          # ‘(eval 21)’ vs ‘(eval 22)’.
  85          no warnings 'numeric';
  86          $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die);
  87          $my   = $bd->coderef2text(eval $hpcode or die);
  88          is $my, $core, "precedence of CORE::$word without parens";
  89       }
  90
  91       next if ($proto =~ /\@/);
  92       # These ops currently accept any number of args, despite their
  93       # prototypes, if they have any:
  94       next if $word =~ /^(?:chom?p|exec|keys|each|not
  95                            |(?:prototyp|read(?:lin|pip))e
  96                            |reset|system|values|l?stat)|evalbytes/x;
  97
  98       $tests ++;
  99       $code =
 100          "sub { () = (my$word("
 101              . (
 102                 $args_for{$word}
 103                  ? $args_for{$word}.',$7'
 104                  : join ",", map "\$$_", 1..$numargs+5+(
 105                       $proto =~ /;/
 106                        ? () = $' =~ /\G$protochar/g
 107                        : 0
 108                    )
 109                )
 110        . "))}";
 111       eval $code;
 112       my $desc = $desc{$word} || $word;
 113       like $@, qr/^Too many arguments for $desc/,
 114           "inlined CORE::$word with too many args"
 115         or warn $code;
 116
 117     }
 118   }
 119 }
 120
 121 sub inlinable_ok {
 122   my ($word, $args, $desc_suffix) = @_;
 123   $tests += 2;
 124
 125   $desc_suffix //= '';
 126
 127   for ([with => "($args)"], [without => " $args"]) {
 128     my ($preposition, $full_args) = @$_;
 129     my $core_code =
 130        "#line 1 This-line-makes-__FILE__-easier-to-test.
 131         sub { () = (CORE::$word$full_args) }";
 132     my $my_code = $core_code =~ s/CORE::$word/my$word/r;
 133     my $core = $bd->coderef2text(eval $core_code or die);
 134     my $my   = $bd->coderef2text(eval   $my_code or die);
 135     is $my, $core, "inlinability of CORE::$word $preposition parens $desc_suffix";
 136   }
 137 }
 138
 139 $tests++;
 140 # This subroutine is outside the warnings scope:
 141 sub foo { goto &CORE::abs }
 142 use warnings;
 143 $SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
 144 foo(undef);
 145
 146 $tests+=2;
 147 is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
 148  'methods calls autovivify coresubs';
 149 is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n",
 150  'inherted method calls autovivify coresubs';
 151
 152 { # RT #117607
 153   $tests++;
 154   like runperl(prog => '$foo/; \&CORE::lc', stderr => 1),
 155     qr/^syntax error/, "RT #117607: \\&CORE::foo doesn't crash in error context";
 156 }
 157
 158 $tests++;
 159 ok eval { *CORE::exit = \42 },
 160   '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
 161
 162 for my $word (qw<keys values each>) {
 163     # mykeys() etc were aliased to \&CORE::keys etc above
 164     my $code = qq{
 165         no warnings 'experimental::autoderef';
 166         my \$x = [];
 167         () = my$word(\$x);
 168         'ok'
 169     };
 170     $tests++;
 171     is(eval($code), 'ok', "inlined $word() on autoderef array") or diag $@;
 172 }
 173
 174 inlinable_ok($_, '$_{k}', 'on hash')
 175     for qw<delete exists>;
 176
 177 @UNIVERSAL::ISA = CORE;
 178 is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
 179    "Just another Perl hacker,\n", 'coresubs do not return TARG';
 180 ++$tests;
 181
 182 done_testing $tests;
 183
 184 CORE::__END__