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";
87 unless ($Config::Config{useperlio}) {
88 print "1..0 # Skip -- Perl configured without perlio\n";
95 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
97 + 14 * ($] >= 5.009003)
100 require_ok("B::Concise");
104 Digest::MD5 => [qw/ ! import /],
106 B => [qw/ ! class clearsym compile_stats debug objsym parents
107 peekop savesym timing_info walkoptree_exec
108 walkoptree_slow walksymtable /],
110 Data::Dumper => [qw/ bootstrap Dumpxs /],
112 B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
113 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
114 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
115 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
116 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
117 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
118 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
119 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
120 OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
121 OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
122 PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
123 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
124 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
125 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
126 main_root main_start opnumber perlstring
133 B::Concise::compile('-nobanner'); # set a silent default
134 getopts('vaVcr:', \my %opts) or
137 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
138 tests ability to discern XS funcs using Digest::MD5 package
141 -a : runs all modules in CoreList
142 -c : writes test corrections as a Data::Dumper expression
143 -r <file> : reads file of tests, as written by -c
144 <args> : additional modules are loaded and tested
145 (will report failures, since no XS funcs are known aprior)
151 require Data::Dumper;
152 Data::Dumper->import('Dumper');
153 $Data::Dumper::Sortkeys = 1;
159 my $refpkgs = require "$opts{r}";
160 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
165 foreach $pkg (sort keys %$testpkgs) {
166 test_pkg($pkg, $testpkgs->{$pkg});
169 foreach $pkg (@argpkgs) {
170 test_pkg($pkg, $testpkgs->{$pkg});
179 my ($pkg_name, $xslist) = @_;
180 require_ok($pkg_name);
182 unless (ref $xslist eq 'ARRAY') {
183 warn "no XS/non-XS function list given, assuming empty XS list";
187 my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
188 $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!';
190 # build %stash: keys are func-names, vals: 1 if XS, 0 if not
193 => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
194 => grep !/__ANON__/ # but not anon subs
195 => keys %{$pkg_name.'::'} # from symbol table
198 # now invert according to supplied list
199 $stash{$_} = int ! $assumeXS foreach @$xslist;
201 # and cleanup cruft (easier than preventing)
202 delete @stash{'!',''};
205 diag("xslist: " => Dumper($xslist));
206 diag("$pkg_name stash: " => Dumper(\%stash));
209 foreach $func_name (reverse sort keys %stash) {
210 my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
212 $stash{$func_name} ^= 1;
217 $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
221 my ($func_name, $wantXS) = @_;
223 my ($buf, $err) = render($func_name);
225 like($buf, qr/\Q$func_name is XS code/,
226 "XS code:\t $func_name");
228 unlike($buf, qr/\Q$func_name is XS code/,
229 "perl code:\t $func_name");
231 #returns like or unlike, whichever was called
235 my ($func_name) = @_;
237 B::Concise::reset_sequence();
238 B::Concise::walk_output(\my $buf);
240 my $walker = B::Concise::compile($func_name);
241 eval { $walker->() };
242 diag("err: $@ $buf") if $@;
243 diag("verbose: $buf") if $opts{V};
250 eval { require Module::CoreList };
252 warn "Module::CoreList not available on $]\n";
255 my $mods = $Module::CoreList::version{'5.009002'};
256 $mods = [ sort keys %$mods ];
259 foreach my $pkgnm (@$mods) {
266 # print "Corrections: ", Dumper(\%report);
267 print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
268 print "\$VAR1 = {\n";
270 foreach my $pkg (sort keys %report) {
272 my $stash = $report{$pkg};
274 @xs = sort grep $stash->{$_} == 1, keys %$stash;
275 @perl = sort grep $stash->{$_} == 0, keys %$stash;
277 my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
278 print "\t$pkg => [qw/ @list /],\n";