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   delete   => '$1[2]',
  30   exists   => '$1[2]',
  31 );
  32 my %desc = (
  33   pos => 'match position',
  34 );
  35
  36 use File::Spec::Functions;
  37 my $keywords_file = catfile(updir,'regen','keywords.pl');
  38 open my $kh, $keywords_file
  39    or die "$0 cannot open $keywords_file: $!";
  40 while(<$kh>) {
  41   if (m?__END__?..${\0} and /^[+-]/) {
  42     chomp(my $word = $');
  43     if($unsupported{$word}) {
  44       $tests ++;
  45       ok !defined &{"CORE::$word"}, "no CORE::$word";
  46     }
  47     else {
  48       $tests += 4;
  49
  50       ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
  51
  52       my $proto = prototype "CORE::$word";
  53       *{"my$word"} = \&{"CORE::$word"};
  54       is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
  55
  56       CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/;
  57       my $numargs =
  58             $word eq 'delete' || $word eq 'exists' ? 1 :
  59             (() = $proto =~ s/;.*//r =~ /\G$protochar/g);
  60       my $code =
  61          "#line 1 This-line-makes-__FILE__-easier-to-test.
  62           sub { () = (my$word("
  63              . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
  64        . "))}";
  65       my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
  66       my $my   = $bd->coderef2text(eval $code or die);
  67       is $my, $core, "inlinability of CORE::$word with parens";
  68
  69       $code =
  70          "#line 1 This-line-makes-__FILE__-easier-to-test.
  71           sub { () = (my$word "
  72              . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
  73        . ")}";
  74       $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
  75       $my   = $bd->coderef2text(eval $code or die);
  76       is $my, $core, "inlinability of CORE::$word without parens";
  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          $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die);
  91          $my   = $bd->coderef2text(eval $hpcode or die);
  92          is $my, $core, "precedence of CORE::$word without parens";
  93       }
  94
  95       next if ($proto =~ /\@/);
  96       # These ops currently accept any number of args, despite their
  97       # prototypes, if they have any:
  98       next if $word =~ /^(?:chom?p|exec|keys|each|not
  99                            |(?:prototyp|read(?:lin|pip))e
 100                            |reset|system|values|l?stat)|evalbytes/x;
 101
 102       $tests ++;
 103       $code =
 104          "sub { () = (my$word("
 105              . (
 106                 $args_for{$word}
 107                  ? $args_for{$word}.',$7'
 108                  : join ",", map "\$$_", 1..$numargs+5+(
 109                       $proto =~ /;/
 110                        ? () = $' =~ /\G$protochar/g
 111                        : 0
 112                    )
 113                )
 114        . "))}";
 115       eval $code;
 116       my $desc = $desc{$word} || $word;
 117       like $@, qr/^Too many arguments for $desc/,
 118           "inlined CORE::$word with too many args"
 119         or warn $code;
 120
 121     }
 122   }
 123 }
 124
 125 $tests++;
 126 # This subroutine is outside the warnings scope:
 127 sub foo { goto &CORE::abs }
 128 use warnings;
 129 $SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
 130 foo(undef);
 131
 132 $tests+=2;
 133 is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
 134  'methods calls autovivify coresubs';
 135 is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n",
 136  'inherted method calls autovivify coresubs';
 137
 138 $tests++;
 139 ok eval { *CORE::exit = \42 },
 140   '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
 141
 142 @UNIVERSAL::ISA = CORE;
 143 is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
 144    "Just another Perl hacker,\n", 'coresubs do not return TARG';
 145 ++$tests;
 146
 147 done_testing $tests;
 148
 149 CORE::__END__