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