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