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 If module-names are given as args, those packages are run through the
20 test harness; this is handy for collecting further items to test, and
21 may be useful otherwise (ie just to see).
23 If -a option is given, we use Module::CoreList to run all packages,
24 which gives some interesting results.
26 -v and -V trigger 2 levels of verbosity.
31 if ($ENV{PERL_CORE}) {
33 @INC = ('.', '../lib');
39 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
40 print "1..0 # Skip -- Perl configured without B module\n";
47 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
51 require_ok("B::Concise");
55 Digest::MD5 => [qw/ ! import /],
57 B => [qw/ ! class clearsym compile_stats debug objsym parents
58 peekop savesym timing_info walkoptree_exec
59 walkoptree_slow walksymtable /],
61 Data::Dumper => [qw/ bootstrap Dumpxs /],
66 B::Concise::compile('-nobanner'); # set a silent default
67 getopts('vaV', \my %opts) or
70 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
71 tests ability to discern XS funcs using Digest::MD5 package
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)
83 Data::Dumper->import('Dumper');
84 $Data::Dumper::Sortkeys = 1;
88 foreach $pkg (sort(keys %$testpkgs), @argpkgs) {
89 test_pkg($pkg, $testpkgs->{$pkg});
92 corecheck() if $opts{a};
97 my ($pkg_name, $xslist) = @_;
98 require_ok($pkg_name);
100 unless (ref $xslist eq 'ARRAY') {
101 warn "no XS/non-XS function list given, assuming empty XS list";
105 my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
106 $assumeXS = 1 if $xslist->[0] eq '!';
108 # build %stash: keys are func-names, vals: 1 if XS, 0 if not
111 => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
112 => grep !/__ANON__/ # but not anon subs
113 => keys %{$pkg_name.'::'} # from symbol table
116 # now invert according to supplied list
117 $stash{$_} = int ! $assumeXS foreach @$xslist;
119 # and cleanup cruft (easier than preventing)
120 delete @stash{'!',''};
123 diag("xslist: " => Dumper($xslist));
124 diag("$pkg_name stash: " => Dumper(\%stash));
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});
134 my ($func_name, $wantXS) = @_;
136 my ($buf, $err) = render($func_name);
138 like($buf, qr/\Q$func_name is XS code/,
139 "XS code:\t $func_name");
141 unlike($buf, qr/\Q$func_name is XS code/,
142 "perl code:\t $func_name");
144 #returns like or unlike, whichever was called
148 my ($func_name) = @_;
150 B::Concise::reset_sequence();
151 B::Concise::walk_output(\my $buf);
153 my $walker = B::Concise::compile($func_name);
154 eval { $walker->() };
155 diag("err: $@ $buf") if $@;
156 diag("verbose: $buf") if $opts{V};
162 eval { require Module::CoreList };
164 warn "Module::CoreList not available on $]\n";
167 my $mods = $Module::CoreList::version{'5.009001'}; # $]}; # undef ??
170 foreach my $pkgnm (sort keys %$mods) {