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
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 (CORE and cmp dump eq ge gt le
19                                     lt ne or x xor);
20 my %args_for = (
21   dbmopen  => '%1,$2,$3',
22   dbmclose => '%1',
23 );
24
25 use File::Spec::Functions;
26 my $keywords_file = catfile(updir,'regen','keywords.pl');
27 open my $kh, $keywords_file
28    or die "$0 cannot open $keywords_file: $!";
29 while(<$kh>) {
30   if (m?__END__?..${\0} and /^[+-]/) {
31     chomp(my $word = $');
32     if($& eq '+' || $unsupported{$word}) {
33       $tests ++;
34       ok !defined &{"CORE::$word"}, "no CORE::$word";
35     }
36     else {
37       $tests += 4;
38
39       ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
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 }";
70       }
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";
81       }
82
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;
88
89       $tests ++;
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
107     }
108   }
109 }
110
111 $tests++;
112 # This subroutine is outside the warnings scope:
113 sub foo { goto &CORE::abs }
114 use warnings;
115 $SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
116 foo(undef);
117
118 is curr_test, $tests+1, 'right number of tests';
119 done_testing;
120
121 CORE::__END__