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
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 (
19  __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
20   cmp default do dump else elsif eq eval for foreach
21   format ge given goto grep gt if last le local lt m map my ne next
22   no or our package print printf prototype q qq qr qw qx  redo  require
23   return s say scalar sort split state study sub tr undef unless until use
24   when while x xor y
25 );
26 my %args_for = (
27   dbmopen  => '%1,$2,$3',
28   dbmclose => '%1',
29   delete   => '$1[2]',
30   exists   => '$1[2]',
31 );
32 my %desc = (
33   pos => 'match position',
34 );
35
36 use File::Spec::Functions;
37 my $keywords_file = catfile(updir,'regen','keywords.pl');
38 open my $kh, $keywords_file
39    or die "$0 cannot open $keywords_file: $!";
40 while(<$kh>) {
41   if (m?__END__?..${\0} and /^[+-]/) {
42     chomp(my $word = $');
43     if($unsupported{$word}) {
44       $tests ++;
45       ok !defined &{"CORE::$word"}, "no CORE::$word";
46     }
47     else {
48       $tests += 4;
49
50       ok defined &{"CORE::$word"}, "defined &{'CORE::$word'}";
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 =
58             $word eq 'delete' || $word eq 'exists' ? 1 :
59             (() = $proto =~ s/;.*//r =~ /\G$protochar/g);
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 }";
82       }
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";
93       }
94
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
99                            |reset|system|values|l?stat)|evalbytes/x;
100
101       $tests ++;
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;
115       my $desc = $desc{$word} || $word;
116       like $@, qr/^Too many arguments for $desc/,
117           "inlined CORE::$word with too many args"
118         or warn $code;
119
120     }
121   }
122 }
123
124 $tests++;
125 # This subroutine is outside the warnings scope:
126 sub foo { goto &CORE::abs }
127 use warnings;
128 $SIG{__WARN__} = sub { like shift, qr\^Use of uninitialized\ };
129 foo(undef);
130
131 $tests+=2;
132 is runperl(prog => 'print CORE->lc, qq-\n-'), "core\n",
133  'methods calls autovivify coresubs';
134 is runperl(prog => '@ISA=CORE; print main->uc, qq-\n-'), "MAIN\n",
135  'inherted method calls autovivify coresubs';
136
137 $tests++;
138 ok eval { *CORE::exit = \42 },
139   '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only';
140
141 @UNIVERSAL::ISA = CORE;
142 is "just another "->ucfirst . "perl hacker,\n"->ucfirst,
143    "Just another Perl hacker,\n", 'coresubs do not return TARG';
144 ++$tests;
145
146 done_testing $tests;
147
148 CORE::__END__