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