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