This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make goto &CORE::sub use the right lexical scope
[perl5.git] / t / op / coresubs.t
CommitLineData
7fa5bd9b
FC
1#!./perl
2
bfce6a3e
FC
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.
7fa5bd9b
FC
6
7BEGIN {
8 chdir 't' if -d 't';
9 @INC = qw(. ../lib);
10 require "test.pl";
47ac839d 11 skip_all_without_dynamic_extension('B');
7fa5bd9b
FC
12 $^P |= 0x100;
13}
7fa5bd9b 14
47ac839d
FC
15use B::Deparse;
16my $bd = new B::Deparse '-p';
7fa5bd9b 17
47ac839d
FC
18my %unsupported = map +($_=>1), qw (CORE and cmp dump eq ge gt le
19 lt ne or x xor);
20my %args_for = (
21 dbmopen => '%1,$2,$3',
22 dbmclose => '%1',
46e00a91 23);
46e00a91 24
47ac839d
FC
25use File::Spec::Functions;
26my $keywords_file = catfile(updir,'regen','keywords.pl');
27open my $kh, $keywords_file
28 or die "$0 cannot open $keywords_file: $!";
29while(<$kh>) {
30 if (m?__END__?..${\0} and /^[+-]/) {
31 chomp(my $word = $');
32 if($& eq '+' || $unsupported{$word}) {
33 $tests ++;
9da346da 34 ok !defined &{"CORE::$word"}, "no CORE::$word";
46e00a91 35 }
47ac839d 36 else {
9da346da
FC
37 $tests += 4;
38
39 ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
47ac839d
FC
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 }";
46e00a91 70 }
47ac839d
FC
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";
46e00a91 81 }
93f0bc49 82
47ac839d
FC
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)/x;
bf0571fd 88
bccb6c7b 89 $tests ++;
47ac839d
FC
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
bccb6c7b
FC
107 }
108 }
109}
7fa5bd9b 110
309aab3a
FC
111$tests++;
112# This subroutine is outside the warnings scope:
113sub foo { goto &CORE::abs }
114use warnings;
115$SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
116foo(undef);
117
7fa5bd9b
FC
118is curr_test, $tests+1, 'right number of tests';
119done_testing;
120
47ac839d 121CORE::__END__