This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Deparse.pm bugfix
[perl5.git] / ext / B / t / concise-xs.t
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,
8 perl, or optimized constant subs, we test against a few core packages
9 which have a stable API, and which have functions of all 3 types.
10
11 =head1 WHAT IS TESTED
12
13 5 core packages are tested; Digest::MD5, B, B::Deparse, Data::Dumper,
14 and POSIX.  These have a mix of the 3 expected implementation types;
15 perl, XS, and constant (optimized constant subs).
16
17 %$testpkgs specifies what packages are tested; each package is loaded,
18 and the stash is scanned for the function-names in that package.
19
20 Each value in %$testpkgs is a hash-of-lists (HoL) whose keys are
21 implementation-types and values are lists of function-names of that type.
22
23 To keep these HoLs smaller and more managable, they may carry an
24 additional 'dflt' => $impl_Type, which means that unnamed functions
25 are expected to be of that default implementation type.  Those unnamed
26 functions are known from the scan of the package stash.
27
28 =head1 HOW THEY'RE TESTED
29
30 Each function is 'rendered' by B::Concise, and result is matched
31 against regexs for each possible implementation-type.  For some
32 packages, some functions may be unimplemented on some platforms.
33
34 To slay this maintenance dragon, the regexs used in like() match
35 against renderings which indicate that there is no implementation.
36
37 If a function is implemented differently on different platforms, the
38 test for that function will fail on one of those platforms.  These
39 specific functions can be skipped by a 'skip' => [ @list ] to the HoL
40 mentioned previously.  See usage for skip in B's HoL, which avoids
41 testing a function which doesnt exist on non-threaded builds.
42
43 =head1 OPTIONS AND ARGUMENTS
44
45 C<-v> and C<-V> trigger 2 levels of verbosity.
46
47 C<-a> uses Module::CoreList to run all core packages through the test, which
48 gives some interesting results.
49
50 C<-c> causes the expected XS/non-XS results to be marked with
51 corrections, which are then reported at program END, in a form that's
52 readily cut-and-pastable into this file.
53
54
55 C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
56 results accordingly.  The file is 'required', so @INC settings apply.
57
58 If module-names are given as args, those packages are run through the
59 test harness; this is handy for collecting further items to test, and
60 may be useful otherwise (ie just to see).
61
62 =head1 EXAMPLES
63
64 =over 4
65
66 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
67
68 Tests Storable.pm for XS/non-XS routines, writes findings (along with
69 test results) to stdout.  You could edit results to produce a test
70 file, as in next example
71
72 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
73
74 Loads file, and uses it to set expectations, and run tests
75
76 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
77
78 Gets module list from Module::Corelist, and runs them all through the
79 test.  Since -c is used, this generates corrections, which are saved
80 in a file, which is edited down to produce ../all-xs
81
82 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
83
84 This runs the tests specified in the file created in previous example.
85 -c is used again, and stdout verifies that all the expected results
86 given by -r ../all-xs are now seen.
87
88 Looking at ../foo2, you'll see 34 occurrences of the following error:
89
90 # err: Can't use an undefined value as a SCALAR reference at
91 # lib/B/Concise.pm line 634, <DATA> line 1.
92
93 =back
94
95 =cut
96
97 BEGIN {
98     if ($ENV{PERL_CORE}) {
99         chdir('t') if -d 't';
100         @INC = ('.', '../lib');
101     } else {
102         unshift @INC, 't';
103         push @INC, "../../t";
104     }
105     require Config;
106     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
107         print "1..0 # Skip -- Perl configured without B module\n";
108         exit 0;
109     }
110     unless ($Config::Config{useperlio}) {
111         print "1..0 # Skip -- Perl configured without perlio\n";
112         exit 0;
113     }
114 }
115
116 use Getopt::Std;
117 use Carp;
118 use Test::More tests => ( # per-pkg tests (function ct + require_ok)
119                           40 + 16       # Data::Dumper, Digest::MD5
120                           + 517 + 236   # B::Deparse, B
121                           + 595 + 190   # POSIX, IO::Socket
122                           + 3 * ($] > 5.009)
123                           + 16 * ($] >= 5.009003)
124                           - 22);        # fudge
125
126 require_ok("B::Concise");
127
128 my %matchers = 
129     ( constant  => qr{ (?-x: is a constant sub, optimized to a \w+)
130                       |(?-x: exists in stash, but has no START) }x,
131       XS        => qr/ is XS code/,
132       perl      => qr/ (next|db)state/,
133       noSTART   => qr/ exists in stash, but has no START/,
134 );
135
136 my $testpkgs = {
137     # packages to test, with expected types for named funcs
138
139     Digest::MD5 => { perl => [qw/ import /],
140                      dflt => 'XS' },
141
142     Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
143                       dflt => 'perl' },
144     B => { 
145         dflt => 'constant',             # all but 47/274
146         skip => [ 'regex_padav' ],      # threaded only
147         perl => [qw(
148                     walksymtable walkoptree_slow walkoptree_exec
149                     timing_info savesym peekop parents objsym debug
150                     compile_stats clearsym class
151                     )],
152         XS => [qw(
153                   warnhook walkoptree_debug walkoptree threadsv_names
154                   svref_2object sv_yes sv_undef sv_no save_BEGINs
155                   regex_padav ppname perlstring opnumber minus_c
156                   main_start main_root main_cv init_av inc_gv hash
157                   formfeed end_av dowarn diehook defstash curstash
158                   cstring comppadlist check_av cchar cast_I32 bootstrap
159                   begin_av amagic_generation sub_generation address
160                   unitcheck_av
161                   )],
162     },
163
164     B::Deparse => { dflt => 'perl',     # 235 functions
165
166         XS => [qw( svref_2object perlstring opnumber main_start
167                    main_root main_cv )],
168
169         constant => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
170                      CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
171                      OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
172                      OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
173                      OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
174                      OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
175                      OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
176                      OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
177                      OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
178                      OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
179                      PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
180                      PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
181                      POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
182                      SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
183                      /],
184                  },
185
186     POSIX => { dflt => 'constant',                      # all but 252/589
187                skip => [qw/ _POSIX_JOB_CONTROL /],      # platform varying
188                perl => [qw/ import croak AUTOLOAD /],
189
190                XS => [qw/ write wctomb wcstombs uname tzset tzname
191                       ttyname tmpnam times tcsetpgrp tcsendbreak
192                       tcgetpgrp tcflush tcflow tcdrain tanh tan
193                       sysconf strxfrm strtoul strtol strtod
194                       strftime strcoll sinh sigsuspend sigprocmask
195                       sigpending sigaction setuid setsid setpgid
196                       setlocale setgid read pipe pause pathconf
197                       open nice modf mktime mkfifo mbtowc mbstowcs
198                       mblen lseek log10 localeconv ldexp lchown
199                       isxdigit isupper isspace ispunct isprint
200                       islower isgraph isdigit iscntrl isalpha
201                       isalnum int_macro_int getcwd frexp fpathconf
202                       fmod floor dup2 dup difftime cuserid ctime
203                       ctermid cosh constant close clock ceil
204                       bootstrap atan asin asctime acos access abort
205                       _exit
206                       /],
207                },
208
209     IO::Socket => { dflt => 'constant',         # 157/190
210
211                     perl => [qw/ timeout socktype sockopt sockname
212                              socketpair socket sockdomain sockaddr_un
213                              sockaddr_in shutdown setsockopt send
214                              register_domain recv protocol peername
215                              new listen import getsockopt croak
216                              connected connect configure confess close
217                              carp bind atmark accept blocking
218                              /],
219
220                     XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
221                            sockatmark sockaddr_family pack_sockaddr_un
222                            pack_sockaddr_in inet_ntoa inet_aton
223                            /],
224                 },
225 };
226
227 ############
228
229 B::Concise::compile('-nobanner');       # set a silent default
230 getopts('vaVcr:', \my %opts) or
231     die <<EODIE;
232
233 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
234     tests ability to discern XS funcs using Digest::MD5 package
235     -v  : runs verbosely
236     -V  : more verbosity
237     -a  : runs all modules in CoreList
238     -c  : writes test corrections as a Data::Dumper expression
239     -r <file>   : reads file of tests, as written by -c
240     <args>      : additional modules are loaded and tested
241         (will report failures, since no XS funcs are known apriori)
242
243 EODIE
244     ;
245
246 if (%opts) {
247     require Data::Dumper;
248     Data::Dumper->import('Dumper');
249     $Data::Dumper::Sortkeys = 1;
250 }
251 my @argpkgs = @ARGV;
252 my %report;
253
254 if ($opts{r}) {
255     my $refpkgs = require "$opts{r}";
256     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
257 }
258
259 unless ($opts{a}) {
260     unless (@argpkgs) {
261         foreach $pkg (sort keys %$testpkgs) {
262             test_pkg($pkg, $testpkgs->{$pkg});
263         }
264     } else {
265         foreach $pkg (@argpkgs) {
266             test_pkg($pkg, $testpkgs->{$pkg});
267         }
268     }
269 } else {
270     corecheck();
271 }
272 ############
273
274 sub test_pkg {
275     my ($pkg, $fntypes) = @_;
276     require_ok($pkg);
277
278     # build %stash: keys are func-names, vals filled in below
279     my (%stash) = map
280         ( ($_ => 0)
281           => ( grep exists &{"$pkg\::$_"}       # grab CODE symbols
282                => grep !/__ANON__/              # but not anon subs
283                => keys %{$pkg.'::'}             # from symbol table
284                ));
285
286     for my $type (keys %matchers) {
287         foreach my $fn (@{$fntypes->{$type}}) {
288             carp "$fn can only be one of $type, $stash{$fn}\n"
289                 if $stash{$fn};
290             $stash{$fn} = $type;
291         }
292     }
293     # set default type for un-named functions
294     my $dflt = $fntypes->{dflt} || 'perl';
295     for my $k (keys %stash) {
296         $stash{$k} = $dflt unless $stash{$k};
297     }
298     $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
299
300     if ($opts{v}) {
301         diag("fntypes: " => Dumper($fntypes));
302         diag("$pkg stash: " => Dumper(\%stash));
303     }
304     foreach my $fn (reverse sort keys %stash) {
305         next if $stash{$fn} eq 'skip';
306         my $res = checkXS("${pkg}::$fn", $stash{$fn});
307         if ($res ne '1') {
308             push @{$report{$pkg}{$res}}, $fn;
309         }
310     }
311 }
312
313 sub checkXS {
314     my ($func_name, $want) = @_;
315
316     croak "unknown type $want: $func_name\n"
317         unless defined $matchers{$want};
318
319     my ($buf, $err) = render($func_name);
320     my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
321
322     unless ($res) {
323         # test failed. return type that would give success
324         for my $m (keys %matchers) {
325             return $m if $buf =~ $matchers{$m};
326         }
327     }
328     $res;
329 }
330
331 sub render {
332     my ($func_name) = @_;
333
334     B::Concise::reset_sequence();
335     B::Concise::walk_output(\my $buf);
336
337     my $walker = B::Concise::compile($func_name);
338     eval { $walker->() };
339     diag("err: $@ $buf") if $@;
340     diag("verbose: $buf") if $opts{V};
341
342     return ($buf, $@);
343 }
344
345 sub corecheck {
346     eval { require Module::CoreList };
347     if ($@) {
348         warn "Module::CoreList not available on $]\n";
349         return;
350     }
351     my $mods = $Module::CoreList::version{'5.009002'};
352     $mods = [ sort keys %$mods ];
353     print Dumper($mods);
354
355     foreach my $pkgnm (@$mods) {
356         test_pkg($pkgnm);
357     }
358 }
359
360 END {
361     if ($opts{c}) {
362         $Data::Dumper::Indent = 1;
363         print "Corrections: ", Dumper(\%report);
364
365         foreach my $pkg (sort keys %report) {
366             for my $type (keys %matchers) {
367                 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
368                     if @{$report{$pkg}{$type}};
369             }
370         }
371     }
372 }
373
374 __END__