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