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 (CORE and cmp dump eq ge gt le
  19                                     lt ne or x xor);
  20 my %args_for = (
  21   dbmopen  => '%1,$2,$3',
  22   dbmclose => '%1',
  23 );
  24
  25 use File::Spec::Functions;
  26 my $keywords_file = catfile(updir,'regen','keywords.pl');
  27 open my $kh, $keywords_file
  28    or die "$0 cannot open $keywords_file: $!";
  29 while(<$kh>) {
  30   if (m?__END__?..${\0} and /^[+-]/) {
  31     chomp(my $word = $');
  32     if($& eq '+' || $unsupported{$word}) {
  33       $tests ++;
  34       ok !defined &{"CORE::$word"}, "no CORE::$word";
  35     }
  36     else {
  37       $tests += 4;
  38
  39       ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
  40
  41       my $proto = prototype "CORE::$word";
  42       *{"my$word"} = \&{"CORE::$word"};
  43       is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
  44
  45       CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/;
  46       my $numargs =
  47             () = $proto =~ s/;.*//r =~ /\G$protochar/g;
  48       my $code =
  49          "#line 1 This-line-makes-__FILE__-easier-to-test.
  50           sub { () = (my$word("
  51              . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
  52        . "))}";
  53       my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
  54       my $my   = $bd->coderef2text(eval $code or die);
  55       is $my, $core, "inlinability of CORE::$word with parens";
  56
  57       $code =
  58          "#line 1 This-line-makes-__FILE__-easier-to-test.
  59           sub { () = (my$word "
  60              . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
  61        . ")}";
  62       $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
  63       $my   = $bd->coderef2text(eval $code or die);
  64       is $my, $core, "inlinability of CORE::$word without parens";
  65
  66       # High-precedence tests
  67       my $hpcode;
  68       if (!$proto && defined $proto) { # nullary
  69          $hpcode = "sub { () = my$word + 1 }";
  70       }
  71       elsif ($proto =~ /^;?$protochar\z/) { # unary
  72          $hpcode = "sub { () = my$word "
  73                            . ($args_for{$word}||'$a') . ' > $b'
  74                        .'}';
  75       }
  76       if ($hpcode) {
  77          $tests ++;
  78          $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die);
  79          $my   = $bd->coderef2text(eval $hpcode or die);
  80          is $my, $core, "precedence of CORE::$word without parens";
  81       }
  82
  83       next if ($proto =~ /\@/);
  84       # These ops currently accept any number of args, despite their
  85       # prototypes, if they have any:
  86       next if $word =~ /^(?:chom?p|exec|keys|each|not|read(?:lin|pip)e
  87                            |reset|system|values|l?stat)|evalbytes/x;
  88
  89       $tests ++;
  90       $code =
  91          "sub { () = (my$word("
  92              . (
  93                 $args_for{$word}
  94                  ? $args_for{$word}.',$7'
  95                  : join ",", map "\$$_", 1..$numargs+5+(
  96                       $proto =~ /;/
  97                        ? () = $' =~ /\G$protochar/g
  98                        : 0
  99                    )
 100                )
 101        . "))}";
 102       eval $code;
 103       like $@, qr/^Too many arguments for $word/,
 104           "inlined CORE::$word with too many args"
 105         or warn $code;
 106
 107     }
 108   }
 109 }
 110
 111 $tests++;
 112 # This subroutine is outside the warnings scope:
 113 sub foo { goto &CORE::abs }
 114 use warnings;
 115 $SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
 116 foo(undef);
 117
 118 $tests+=2;
 119 is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
 120  'methods calls autovivify coresubs';
 121 is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n",
 122  'inherted method calls autovivify coresubs';
 123
 124 is curr_test, $tests+1, 'right number of tests';
 125 done_testing;
 126
 127 CORE::__END__