Commit | Line | Data |
c0939cee |
1 | #!./perl |
2 | |
3 | # 2 purpose file: 1-test 2-demonstrate (via args, -v -a options) |
4 | |
5 | =head1 synopsis |
6 | |
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-! |
13 | usage. |
14 | |
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. |
18 | |
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). |
22 | |
23 | If -a option is given, we use Module::CoreList to run all packages, |
24 | which gives some interesting results. |
25 | |
26 | -v and -V trigger 2 levels of verbosity. |
27 | |
28 | =cut |
29 | |
30 | BEGIN { |
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 | |
45 | use Getopt::Std; |
46 | use Carp; |
47 | use Test::More tests => ( 1 * !!$Config::Config{useithreads} |
48 | + 2 * ($] > 5.009) |
49 | + 272); |
50 | |
51 | require_ok("B::Concise"); |
52 | |
53 | my $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 | |
66 | B::Concise::compile('-nobanner'); # set a silent default |
67 | getopts('vaV', \my %opts) or |
68 | die <<EODIE; |
69 | |
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 |
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 | |
78 | EODIE |
79 | ; |
80 | |
81 | if (%opts) { |
82 | require Data::Dumper; |
83 | Data::Dumper->import('Dumper'); |
84 | $Data::Dumper::Sortkeys = 1; |
85 | } |
86 | my @argpkgs = @ARGV; |
87 | |
88 | foreach $pkg (sort(keys %$testpkgs), @argpkgs) { |
89 | test_pkg($pkg, $testpkgs->{$pkg}); |
90 | } |
91 | |
92 | corecheck() if $opts{a}; |
93 | |
94 | ############ |
95 | |
96 | sub 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 | |
133 | sub 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 | |
147 | sub 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 | |
161 | sub 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__ |