Devel::PPPort: Fix D_PPP_FIX_UTF8_ERRSV macro
[perl.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     require "./test.pl";
10     set_up_inc(qw(. ../lib));
11     skip_all_without_dynamic_extension('B');
12     $^P |= 0x100;
13 }
14
15 use B;
16
17 my %unsupported = map +($_=>1), qw (
18  __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
19   cmp default do dump else elsif eq eval for foreach
20   format ge given goto grep gt if last le local lt m map my ne next
21   no  or  our  package  print  printf  q  qq  qr  qw  qx  redo  require
22   return s say sort state sub tr unless until use
23   when while x xor y
24 );
25 my %args_for = (
26   dbmopen  => '%1,$2,$3',
27  (dbmclose => '%1',
28   keys     =>
29   values   =>
30   each     =>)[0,1,2,1,3,1,4,1],
31   delete   => '$1[2]',
32   exists   => '$1[2]',
33  (push     => '@1',
34   pop      =>
35   shift    =>
36   unshift  =>
37   splice   =>)[0,1,2,1,3,1,4,1,5,1],
38 );
39 my %desc = (
40   pos => 'match position',
41 );
42
43 use File::Spec::Functions;
44 my $keywords_file = catfile(updir,'regen','keywords.pl');
45 open my $kh, $keywords_file
46    or die "$0 cannot open $keywords_file: $!";
47 while(<$kh>) {
48   if (m?__END__?..${\0} and /^[+-]/) {
49     chomp(my $word = $');
50     if($unsupported{$word}) {
51       $tests ++;
52       ok !defined &{"CORE::$word"}, "no CORE::$word";
53     }
54     else {
55       $tests += 2;
56
57       ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
58
59       my $proto = prototype "CORE::$word";
60       *{"my$word"} = \&{"CORE::$word"};
61       is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
62
63       CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/;
64       my $numargs =
65             $word eq 'delete' || $word eq 'exists' ? 1 :
66             (() = $proto =~ s/;.*//r =~ /\G$protochar/g);
67
68       inlinable_ok($word, $args_for{$word} || join ",", map "\$$_", 1..$numargs);
69
70       # High-precedence tests
71       my $hpcode;
72       if (!$proto && defined $proto) { # nullary
73          $hpcode = "sub { () = my$word + 1 }";
74       }
75       elsif ($proto =~ /^;?$protochar\z/) { # unary
76          $hpcode = "sub { () = my$word "
77                            . ($args_for{$word}||'$a') . ' > $b'
78                        .'}';
79       }
80       if ($hpcode) {
81          $tests ++;
82          # __FILE__ won’t fold with warnings on, and then we get
83          # ‘(eval 21)’ vs ‘(eval 22)’.
84          no warnings 'numeric';
85          $core = op_list(eval $hpcode =~ s/my/CORE::/r or die);
86          $my   = op_list(eval $hpcode or die);
87          is $my, $core, "precedence of CORE::$word without parens";
88       }
89
90       next if ($proto =~ /\@/);
91       # These ops currently accept any number of args, despite their
92       # prototypes, if they have any:
93       next if $word =~ /^(?:chom?p|exec|keys|each|not
94                            |(?:prototyp|read(?:lin|pip))e
95                            |reset|system|values|l?stat)|evalbytes/x;
96
97       $tests ++;
98       $code =
99          "sub { () = (my$word("
100              . (
101                 $args_for{$word}
102                  ? $args_for{$word}.',$7'
103                  : join ",", map "\$$_", 1..$numargs+5+(
104                       $proto =~ /;/
105                        ? () = $' =~ /\G$protochar/g
106                        : 0
107                    )
108                )
109        . "))}";
110       eval $code;
111       my $desc = $desc{$word} || $word;
112       like $@, qr/^Too many arguments for $desc/,
113           "inlined CORE::$word with too many args"
114         or warn $code;
115
116     }
117   }
118 }
119
120 sub B::OP::pushname { push @op_names, shift->name }
121
122 sub op_list {
123     local @op_names;
124     B::walkoptree(B::svref_2object($_[0])->ROOT, 'pushname');
125     return "@op_names";
126 }
127
128 sub inlinable_ok {
129   my ($word, $args, $desc_suffix) = @_;
130   $tests += 2;
131
132   $desc_suffix //= '';
133
134   for ([with => "($args)"], [without => " $args"]) {
135     my ($preposition, $full_args) = @$_;
136     my $core_code =
137        "#line 1 This-line-makes-__FILE__-easier-to-test.
138         sub { () = (CORE::$word$full_args) }";
139     my $my_code = $core_code =~ s/CORE::$word/my$word/r;
140     my $core = op_list(eval $core_code or die);
141     my $my   = op_list(eval   $my_code or die);
142     is $my, $core, "inlinability of CORE::$word $preposition parens $desc_suffix";
143   }
144 }
145
146 $tests++;
147 # This subroutine is outside the warnings scope:
148 sub foo { goto &CORE::abs }
149 use warnings;
150 $SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
151 foo(undef);
152
153 $tests+=2;
154 is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
155  'methods calls autovivify coresubs';
156 is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n",
157  'inherted method calls autovivify coresubs';
158
159 { # RT #117607
160   $tests++;
161   like runperl(prog => '$foo/; \&CORE::lc', stderr => 1),
162     qr/^syntax error/, "RT #117607: \\&CORE::foo doesn't crash in error context";
163 }
164
165 $tests++;
166 ok eval { *CORE::exit = \42 },
167   '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
168
169 inlinable_ok($_, '$_{k}', 'on hash')
170     for qw<delete exists>;
171
172 @UNIVERSAL::ISA = CORE;
173 is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
174    "Just another Perl hacker,\n", 'coresubs do not return TARG';
175 ++$tests;
176
177 done_testing $tests;
178
179 CORE::__END__