t/op/coreinline.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = qw(. ../lib);
   6     require "test.pl";
   7     skip_all_without_dynamic_extension('B');
   8     $^P |= 0x100;
   9 }
  10
  11 use B::Deparse;
  12 my $bd = new B::Deparse '-p';
  13
  14 my %unsupported = map +($_=>1), qw (CORE and cmp dump eq ge gt le
  15                                     getprotobynumber lt ne not or x xor);
  16 my %args_for = (
  17   dbmopen  => '%1,$2,$3',
  18   dbmclose => '%1',
  19 );
  20
  21 use File::Spec::Functions;
  22 my $keywords_file = catfile(updir,'regen','keywords.pl');
  23 open my $kh, $keywords_file
  24    or die "$0 cannot open $keywords_file: $!";
  25 while(<$kh>) {
  26   if (m?__END__?..${\0} and /^[+-]/) {
  27     chomp(my $word = $');
  28     if($& eq '+' || $unsupported{$word}) {
  29       $tests ++;
  30       ok !defined &{\&{"CORE::$word"}}, "no CORE::$word";
  31     }
  32     else {
  33       $tests += 3;
  34
  35       my $proto = prototype "CORE::$word";
  36       *{"my$word"} = \&{"CORE::$word"};
  37       is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
  38
  39       CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/;
  40       my $numargs =
  41             () = $proto =~ s/;.*//r =~ /\G$protochar/g;
  42       my $code =
  43          "#line 1 This-line-makes-__FILE__-easier-to-test.
  44           sub { () = (my$word("
  45              . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
  46        . "))}";
  47       my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
  48       my $my   = $bd->coderef2text(eval $code or die);
  49       is $my, $core, "inlinability of CORE::$word with parens";
  50
  51       $code =
  52          "#line 1 This-line-makes-__FILE__-easier-to-test.
  53           sub { () = (my$word "
  54              . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
  55        . ")}";
  56       $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
  57       $my   = $bd->coderef2text(eval $code or die);
  58       is $my, $core, "inlinability of CORE::$word without parens";
  59
  60       # High-precedence tests
  61       my $hpcode;
  62       if (!$proto && defined $proto) { # nullary
  63          $hpcode = "sub { () = my$word + 1 }";
  64       }
  65       elsif ($proto =~ /^;?$protochar\z/) { # unary
  66          $hpcode = "sub { () = my$word "
  67                            . ($args_for{$word}||'$a') . ' > $b'
  68                        .'}';
  69       }
  70       if ($hpcode) {
  71          $tests ++;
  72          $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die);
  73          $my   = $bd->coderef2text(eval $hpcode or die);
  74          is $my, $core, "precedence of CORE::$word without parens";
  75       }
  76
  77       next if ($proto =~ /\@/);
  78       # These ops currently accept any number of args, despite their
  79       # prototypes, if they have any:
  80       next if $word =~ /^(?:chom?p|exec|keys|each|read(?:lin|pip)e|reset
  81                            |system|values|l?stat)/x;
  82
  83       $tests ++;
  84       $code =
  85          "sub { () = (my$word("
  86              . (
  87                 $args_for{$word}
  88                  ? $args_for{$word}.',$7'
  89                  : join ",", map "\$$_", 1..$numargs+5+(
  90                       $proto =~ /;/
  91                        ? () = $' =~ /\G$protochar/g
  92                        : 0
  93                    )
  94                )
  95        . "))}";
  96       eval $code;
  97       like $@, qr/^Too many arguments for $word/,
  98           "inlined CORE::$word with too many args"
  99         or warn $code;
 100
 101     }
 102   }
 103 }
 104
 105 is curr_test, $tests+1, 'right number of tests';
 106 done_testing;
 107
 108 CORE::__END__