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 += 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:
 135 sub foo { goto &CORE::abs }
 136 use warnings;
 137 $SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
 138 foo(undef);
 139
 140 $tests+=2;
 141 is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
 142  'methods calls autovivify coresubs';
 143 is 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++;
 153 ok eval { *CORE::exit = \42 },
 154   '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
 155
 156 @UNIVERSAL::ISA = CORE;
 157 is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
 158    "Just another Perl hacker,\n", 'coresubs do not return TARG';
 159 ++$tests;
 160
 161 done_testing $tests;
 162
 163 CORE::__END__