This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Improved ICMP_UNREACHABLE handling in Net::Ping
[perl5.git] / ext / B / t / concise-xs.t
CommitLineData
c0939cee
JC
1#!./perl
2
3# 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
4
5=head1 synopsis
6
7To verify that B::Concise properly reports whether functions are XS or
8perl, we test against 2 (currently) core packages which have lots of
9XS functions; B and Digest::MD5. They're listed in %$testpkgs, along
10with a list of functions that are (or are not) XS. For brevity, you
11can specify the shorter list; if they're non-xs routines, start list
12with a '!'. Data::Dumper is also tested, partly to prove the non-!
13usage.
14
15We demand-load each package, scan its stash for function names, and
16mark them as XS/not-XS according to the list given for each package.
17Then we test B::Concise's report on each.
18
19If module-names are given as args, those packages are run through the
20test harness; this is handy for collecting further items to test, and
21may be useful otherwise (ie just to see).
22
23If -a option is given, we use Module::CoreList to run all packages,
24which gives some interesting results.
25
26-v and -V trigger 2 levels of verbosity.
27
28=cut
29
30BEGIN {
31 if ($ENV{PERL_CORE}) {
32 chdir('t') if -d 't';
33 @INC = ('.', '../lib');
34 } else {
35 unshift @INC, 't';
36 push @INC, "../../t";
37 }
38 require Config;
39 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
40 print "1..0 # Skip -- Perl configured without B module\n";
41 exit 0;
42 }
43}
44
45use Getopt::Std;
46use Carp;
47use Test::More tests => ( 1 * !!$Config::Config{useithreads}
48 + 2 * ($] > 5.009)
49 + 272);
50
51require_ok("B::Concise");
52
53my $testpkgs = {
54
55 Digest::MD5 => [qw/ ! import /],
56
57 B => [qw/ ! class clearsym compile_stats debug objsym parents
58 peekop savesym timing_info walkoptree_exec
59 walkoptree_slow walksymtable /],
60
61 Data::Dumper => [qw/ bootstrap Dumpxs /],
62};
63
64############
65
66B::Concise::compile('-nobanner'); # set a silent default
67getopts('vaV', \my %opts) or
68 die <<EODIE;
69
70usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
71 tests ability to discern XS funcs using Digest::MD5 package
72 -v : runs verbosely
73 -V : more verbosity
74 -a : runs all modules in CoreList
75 <args> : additional modules are loaded and tested
76 (will report failures, since no XS funcs are known aprior)
77
78EODIE
79 ;
80
81if (%opts) {
82 require Data::Dumper;
83 Data::Dumper->import('Dumper');
84 $Data::Dumper::Sortkeys = 1;
85}
86my @argpkgs = @ARGV;
87
88foreach $pkg (sort(keys %$testpkgs), @argpkgs) {
89 test_pkg($pkg, $testpkgs->{$pkg});
90}
91
92corecheck() if $opts{a};
93
94############
95
96sub test_pkg {
97 my ($pkg_name, $xslist) = @_;
98 require_ok($pkg_name);
99
100 unless (ref $xslist eq 'ARRAY') {
101 warn "no XS/non-XS function list given, assuming empty XS list";
102 $xslist = [''];
103 }
104
105 my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
106 $assumeXS = 1 if $xslist->[0] eq '!';
107
108 # build %stash: keys are func-names, vals: 1 if XS, 0 if not
109 my (%stash) = map
110 ( ($_ => $assumeXS)
111 => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
112 => grep !/__ANON__/ # but not anon subs
113 => keys %{$pkg_name.'::'} # from symbol table
114 ));
115
116 # now invert according to supplied list
117 $stash{$_} = int ! $assumeXS foreach @$xslist;
118
119 # and cleanup cruft (easier than preventing)
120 delete @stash{'!',''};
121
122 if (%opts) {
123 diag("xslist: " => Dumper($xslist));
124 diag("$pkg_name stash: " => Dumper(\%stash));
125 }
126
127 foreach $func_name (reverse sort keys %stash) {
128 $DB::single = 1 if $func_name =~ /AUTOLOAD/;
129 checkXS("${pkg_name}::$func_name", $stash{$func_name});
130 }
131}
132
133sub checkXS {
134 my ($func_name, $wantXS) = @_;
135
136 my ($buf, $err) = render($func_name);
137 if ($wantXS) {
138 like($buf, qr/\Q$func_name is XS code/,
139 "XS code:\t $func_name");
140 } else {
141 unlike($buf, qr/\Q$func_name is XS code/,
142 "perl code:\t $func_name");
143 }
144 #returns like or unlike, whichever was called
145}
146
147sub render {
148 my ($func_name) = @_;
149
150 B::Concise::reset_sequence();
151 B::Concise::walk_output(\my $buf);
152
153 my $walker = B::Concise::compile($func_name);
154 eval { $walker->() };
155 diag("err: $@ $buf") if $@;
156 diag("verbose: $buf") if $opts{V};
157
158 return ($buf, $@);
159}
160
161sub corecheck {
162 eval { require Module::CoreList };
163 if ($@) {
164 warn "Module::CoreList not available on $]\n";
165 return;
166 }
167 my $mods = $Module::CoreList::version{'5.009001'}; # $]}; # undef ??
168 print Dumper($mods);
169
170 foreach my $pkgnm (sort keys %$mods) {
171 test_pkg($pkgnm);
172 }
173}
174
175__END__