3 # 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
7 To verify that B::Concise properly reports whether functions are XS or
8 perl, we test against 2 (currently) core packages which have lots of
9 XS functions: B and Digest::MD5. They're listed in %$testpkgs, along
10 with a list of functions that are (or are not) XS. For brevity, you
11 can specify the shorter list; if they're non-xs routines, start list
12 with a '!'. Data::Dumper is also tested, partly to prove the non-!
15 We demand-load each package, scan its stash for function names, and
16 mark them as XS/not-XS according to the list given for each package.
17 Then we test B::Concise's report on each.
19 =head1 OPTIONS AND ARGUMENTS
21 C<-v> and C<-V> trigger 2 levels of verbosity.
23 C<-a> uses Module::CoreList to run all core packages through the test, which
24 gives some interesting results.
26 C<-c> causes the expected XS/non-XS results to be marked with
27 corrections, which are then reported at program END, in a
28 Data::Dumper statement
30 C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
31 results accordingly. The file is 'required', so @INC settings apply.
33 If module-names are given as args, those packages are run through the
34 test harness; this is handy for collecting further items to test, and
35 may be useful otherwise (ie just to see).
39 All following examples avoid using PERL_CORE=1, since that changes @INC
43 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
45 Tests Storable.pm for XS/non-XS routines, writes findings (along with
46 test results) to stdout. You could edit results to produce a test
47 file, as in next example
49 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
51 Loads file, and uses it to set expectations, and run tests
53 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
55 Gets module list from Module::Corelist, and runs them all through the
56 test. Since -c is used, this generates corrections, which are saved
57 in a file, which is edited down to produce ../all-xs
59 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
61 This runs the tests specified in the file created in previous example.
62 -c is used again, and stdout verifies that all the expected results
63 given by -r ../all-xs are now seen.
65 Looking at ../foo2, you'll see 34 occurrences of the following error:
67 # err: Can't use an undefined value as a SCALAR reference at
68 # lib/B/Concise.pm line 634, <DATA> line 1.
75 if ($ENV{PERL_CORE}) {
77 @INC = ('.', '../lib');
83 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
84 print "1..0 # Skip -- Perl configured without B module\n";
91 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
95 require_ok("B::Concise");
99 Digest::MD5 => [qw/ ! import /],
101 B => [qw/ ! class clearsym compile_stats debug objsym parents
102 peekop savesym timing_info walkoptree_exec
103 walkoptree_slow walksymtable /],
105 Data::Dumper => [qw/ bootstrap Dumpxs /],
107 B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
108 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
109 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
110 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
111 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
112 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
113 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
114 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
115 OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
116 OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
117 PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
118 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
119 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
120 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
121 main_root main_start opnumber perlstring
128 B::Concise::compile('-nobanner'); # set a silent default
129 getopts('vaVcr:', \my %opts) or
132 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
133 tests ability to discern XS funcs using Digest::MD5 package
136 -a : runs all modules in CoreList
137 -c : writes test corrections as a Data::Dumper expression
138 -r <file> : reads file of tests, as written by -c
139 <args> : additional modules are loaded and tested
140 (will report failures, since no XS funcs are known aprior)
146 require Data::Dumper;
147 Data::Dumper->import('Dumper');
148 $Data::Dumper::Sortkeys = 1;
154 my $refpkgs = require "$opts{r}";
155 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
160 foreach $pkg (sort keys %$testpkgs) {
161 test_pkg($pkg, $testpkgs->{$pkg});
164 foreach $pkg (@argpkgs) {
165 test_pkg($pkg, $testpkgs->{$pkg});
174 my ($pkg_name, $xslist) = @_;
175 require_ok($pkg_name);
177 unless (ref $xslist eq 'ARRAY') {
178 warn "no XS/non-XS function list given, assuming empty XS list";
182 my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
183 $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!';
185 # build %stash: keys are func-names, vals: 1 if XS, 0 if not
188 => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
189 => grep !/__ANON__/ # but not anon subs
190 => keys %{$pkg_name.'::'} # from symbol table
193 # now invert according to supplied list
194 $stash{$_} = int ! $assumeXS foreach @$xslist;
196 # and cleanup cruft (easier than preventing)
197 delete @stash{'!',''};
200 diag("xslist: " => Dumper($xslist));
201 diag("$pkg_name stash: " => Dumper(\%stash));
204 foreach $func_name (reverse sort keys %stash) {
205 my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
207 $stash{$func_name} ^= 1;
212 $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
216 my ($func_name, $wantXS) = @_;
218 my ($buf, $err) = render($func_name);
220 like($buf, qr/\Q$func_name is XS code/,
221 "XS code:\t $func_name");
223 unlike($buf, qr/\Q$func_name is XS code/,
224 "perl code:\t $func_name");
226 #returns like or unlike, whichever was called
230 my ($func_name) = @_;
232 B::Concise::reset_sequence();
233 B::Concise::walk_output(\my $buf);
235 my $walker = B::Concise::compile($func_name);
236 eval { $walker->() };
237 diag("err: $@ $buf") if $@;
238 diag("verbose: $buf") if $opts{V};
245 eval { require Module::CoreList };
247 warn "Module::CoreList not available on $]\n";
250 my $mods = $Module::CoreList::version{'5.009002'};
251 $mods = [ sort keys %$mods ];
254 foreach my $pkgnm (@$mods) {
261 # print "Corrections: ", Dumper(\%report);
262 print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
263 print "\$VAR1 = {\n";
265 foreach my $pkg (sort keys %report) {
267 my $stash = $report{$pkg};
269 @xs = sort grep $stash->{$_} == 1, keys %$stash;
270 @perl = sort grep $stash->{$_} == 0, keys %$stash;
272 my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
273 print "\t$pkg => [qw/ @list /],\n";