This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add &CORE::pos
[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
6c871ae8
FC
18my %unsupported = map +($_=>1), qw (
19 __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
d51f8b19 20 cmp default do dump else elsif eq eval for foreach
498a02d8 21 format ge given goto grep gt if last le local lt m map my ne next
1efec5ed 22 no or our package print printf prototype q qq qr qw qx redo require
6c871ae8
FC
23 return s say scalar sort split state study sub tr undef unless until use
24 when while x xor y
25);
47ac839d
FC
26my %args_for = (
27 dbmopen => '%1,$2,$3',
28 dbmclose => '%1',
eb31eb35 29 delete => '$1[2]',
d51f8b19 30 exists => '$1[2]',
46e00a91 31);
1efec5ed
FC
32my %desc = (
33 pos => 'match position',
34);
46e00a91 35
47ac839d
FC
36use File::Spec::Functions;
37my $keywords_file = catfile(updir,'regen','keywords.pl');
38open my $kh, $keywords_file
39 or die "$0 cannot open $keywords_file: $!";
40while(<$kh>) {
41 if (m?__END__?..${\0} and /^[+-]/) {
42 chomp(my $word = $');
6c871ae8 43 if($unsupported{$word}) {
47ac839d 44 $tests ++;
9da346da 45 ok !defined &{"CORE::$word"}, "no CORE::$word";
46e00a91 46 }
47ac839d 47 else {
9da346da
FC
48 $tests += 4;
49
50 ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
47ac839d
FC
51
52 my $proto = prototype "CORE::$word";
53 *{"my$word"} = \&{"CORE::$word"};
54 is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
55
56 CORE::state $protochar = qr/([^\\]|\\(?:[^[]|\[[^]]+\]))/;
57 my $numargs =
d51f8b19 58 $word eq 'delete' || $word eq 'exists' ? 1 :
eb31eb35 59 (() = $proto =~ s/;.*//r =~ /\G$protochar/g);
47ac839d
FC
60 my $code =
61 "#line 1 This-line-makes-__FILE__-easier-to-test.
62 sub { () = (my$word("
63 . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
64 . "))}";
65 my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
66 my $my = $bd->coderef2text(eval $code or die);
67 is $my, $core, "inlinability of CORE::$word with parens";
68
69 $code =
70 "#line 1 This-line-makes-__FILE__-easier-to-test.
71 sub { () = (my$word "
72 . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
73 . ")}";
74 $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
75 $my = $bd->coderef2text(eval $code or die);
76 is $my, $core, "inlinability of CORE::$word without parens";
77
78 # High-precedence tests
79 my $hpcode;
80 if (!$proto && defined $proto) { # nullary
81 $hpcode = "sub { () = my$word + 1 }";
46e00a91 82 }
47ac839d
FC
83 elsif ($proto =~ /^;?$protochar\z/) { # unary
84 $hpcode = "sub { () = my$word "
85 . ($args_for{$word}||'$a') . ' > $b'
86 .'}';
87 }
88 if ($hpcode) {
89 $tests ++;
90 $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die);
91 $my = $bd->coderef2text(eval $hpcode or die);
92 is $my, $core, "precedence of CORE::$word without parens";
46e00a91 93 }
93f0bc49 94
47ac839d
FC
95 next if ($proto =~ /\@/);
96 # These ops currently accept any number of args, despite their
97 # prototypes, if they have any:
98 next if $word =~ /^(?:chom?p|exec|keys|each|not|read(?:lin|pip)e
7d789282 99 |reset|system|values|l?stat)|evalbytes/x;
bf0571fd 100
bccb6c7b 101 $tests ++;
47ac839d
FC
102 $code =
103 "sub { () = (my$word("
104 . (
105 $args_for{$word}
106 ? $args_for{$word}.',$7'
107 : join ",", map "\$$_", 1..$numargs+5+(
108 $proto =~ /;/
109 ? () = $' =~ /\G$protochar/g
110 : 0
111 )
112 )
113 . "))}";
114 eval $code;
1efec5ed
FC
115 my $desc = $desc{$word} || $word;
116 like $@, qr/^Too many arguments for $desc/,
47ac839d
FC
117 "inlined CORE::$word with too many args"
118 or warn $code;
119
bccb6c7b
FC
120 }
121 }
122}
7fa5bd9b 123
309aab3a
FC
124$tests++;
125# This subroutine is outside the warnings scope:
126sub foo { goto &CORE::abs }
127use warnings;
128$SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
129foo(undef);
130
0f8d4b5e
FC
131$tests+=2;
132is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
133 'methods calls autovivify coresubs';
134is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n",
135 'inherted method calls autovivify coresubs';
136
7e68c38b
FC
137$tests++;
138ok eval { *CORE::exit = \42 },
139 '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
140
5811c07e
FC
141@UNIVERSAL::ISA = CORE;
142is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
143 "Just another Perl hacker,\n", 'coresubs do not return TARG';
144++$tests;
145
ab157fa5 146done_testing $tests;
7fa5bd9b 147
47ac839d 148CORE::__END__