This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add tests for precedence of CORE:: subs
[perl5.git] / t / op / coreinline.t
CommitLineData
4aaa4757
FC
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = qw(. ../lib);
6 require "test.pl";
7 skip_all_without_dynamic_extension('B');
8 $^P |= 0x100;
9}
10
11use B::Deparse;
6f9f564c 12my $bd = new B::Deparse '-p';
4aaa4757
FC
13
14my %unsupported = map +($_=>1), qw (CORE and cmp dump eq ge gt le
15 getprotobynumber lt ne not or x xor);
16my %args_for = (
17 dbmopen => '%1,$2,$3',
18 dbmclose => '%1',
19);
20
21use File::Spec::Functions;
22my $keywords_file = catfile(updir,'regen','keywords.pl');
23open my $kh, $keywords_file
24 or die "$0 cannot open $keywords_file: $!";
25while(<$kh>) {
26 if (m?__END__?..${\0} and /^[+-]/) {
27 chomp(my $word = $');
28 if($& eq '+' || $unsupported{$word}) {
29 $tests ++;
30 ok !defined &{\&{"CORE::$word"}}, "no CORE::$word";
31 }
32 else {
33 $tests += 3;
34
35 my $proto = prototype "CORE::$word";
36 *{"my$word"} = \&{"CORE::$word"};
37 is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
38
6f9f564c 39 CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/;
4aaa4757 40 my $numargs =
6f9f564c 41 () = $proto =~ s/;.*//r =~ /\G$protochar/g;
4aaa4757
FC
42 my $code =
43 "#line 1 This-line-makes-__FILE__-easier-to-test.
44 sub { () = (my$word("
45 . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
46 . "))}";
47 my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
48 my $my = $bd->coderef2text(eval $code or die);
49 is $my, $core, "inlinability of CORE::$word with parens";
50
51 $code =
52 "#line 1 This-line-makes-__FILE__-easier-to-test.
53 sub { () = (my$word "
54 . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
55 . ")}";
56 $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
57 $my = $bd->coderef2text(eval $code or die);
58 is $my, $core, "inlinability of CORE::$word without parens";
59
6f9f564c
FC
60 # High-precedence tests
61 my $hpcode;
62 if (!$proto && defined $proto) { # nullary
63 $hpcode = "sub { () = my$word + 1 }";
64 }
65 elsif ($proto =~ /^;?$protochar\z/) { # unary
66 $hpcode = "sub { () = my$word "
67 . ($args_for{$word}||'$a') . ' > $b'
68 .'}';
69 }
70 if ($hpcode) {
71 $tests ++;
72 $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die);
73 $my = $bd->coderef2text(eval $hpcode or die);
74 is $my, $core, "precedence of CORE::$word without parens";
75 }
76
4aaa4757
FC
77 next if ($proto =~ /\@/);
78 # These ops currently accept any number of args, despite their
79 # prototypes, if they have any:
80 next if $word =~ /^(?:chom?p|exec|keys|each|read(?:lin|pip)e|reset
81 |system|values|l?stat)/x;
82
83 $tests ++;
84 $code =
85 "sub { () = (my$word("
86 . (
87 $args_for{$word}
88 ? $args_for{$word}.',$7'
89 : join ",", map "\$$_", 1..$numargs+5+(
90 $proto =~ /;/
6f9f564c 91 ? () = $' =~ /\G$protochar/g
4aaa4757
FC
92 : 0
93 )
94 )
95 . "))}";
96 eval $code;
97 like $@, qr/^Too many arguments for $word/,
98 "inlined CORE::$word with too many args"
99 or warn $code;
100
101 }
102 }
103}
104
105is curr_test, $tests+1, 'right number of tests';
106done_testing;
107
108CORE::__END__