This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Callbacks for named captures (%+ and %-)
[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 + 276   # B::Deparse, B
121                           + 595 + 190   # POSIX, IO::Socket
122                           - 20);                # fudge
123
124 require_ok("B::Concise");
125
126 my %matchers = 
127     ( constant  => qr{ (?-x: is a constant sub, optimized to a \w+)
128                       |(?-x: exists in stash, but has no START) }x,
129       XS        => qr/ is XS code/,
130       perl      => qr/ (next|db)state/,
131       noSTART   => qr/ exists in stash, but has no START/,
132 );
133
134 my $testpkgs = {
135     # packages to test, with expected types for named funcs
136
137     Digest::MD5 => { perl => [qw/ import /],
138                      dflt => 'XS' },
139
140     Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
141                       dflt => 'perl' },
142     B => { 
143         dflt => 'constant',             # all but 47/297
144         skip => [ 'regex_padav' ],      # threaded only
145         perl => [qw(
146                     walksymtable walkoptree_slow walkoptree_exec
147                     timing_info savesym peekop parents objsym debug
148                     compile_stats clearsym class
149                     )],
150         XS => [qw(
151                   warnhook walkoptree_debug walkoptree threadsv_names
152                   svref_2object sv_yes sv_undef sv_no save_BEGINs
153                   regex_padav ppname perlstring opnumber minus_c
154                   main_start main_root main_cv init_av inc_gv hash
155                   formfeed end_av dowarn diehook defstash curstash
156                   cstring comppadlist check_av cchar cast_I32 bootstrap
157                   begin_av amagic_generation sub_generation address
158                   ), $] > 5.009 ? ('unitcheck_av') : ()],
159     },
160
161     B::Deparse => { dflt => 'perl',     # 235 functions
162
163         XS => [qw( svref_2object perlstring opnumber main_start
164                    main_root main_cv )],
165
166         constant => [qw/ ASSIGN CVf_LOCKED CVf_LVALUE
167                      CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
168                      OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
169                      OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
170                      OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
171                      OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
172                      OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
173                      OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
174                      OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
175                      OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
176                      PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
177                      PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
178                      POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
179                      SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
180                      /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE')],
181                  },
182
183     POSIX => { dflt => 'constant',                      # all but 252/589
184                skip => [qw/ _POSIX_JOB_CONTROL /],      # platform varying
185                perl => [qw/ import croak AUTOLOAD /],
186
187                XS => [qw/ write wctomb wcstombs uname tzset tzname
188                       ttyname tmpnam times tcsetpgrp tcsendbreak
189                       tcgetpgrp tcflush tcflow tcdrain tanh tan
190                       sysconf strxfrm strtoul strtol strtod
191                       strftime strcoll sinh sigsuspend sigprocmask
192                       sigpending sigaction setuid setsid setpgid
193                       setlocale setgid read pipe pause pathconf
194                       open nice modf mktime mkfifo mbtowc mbstowcs
195                       mblen lseek log10 localeconv ldexp lchown
196                       isxdigit isupper isspace ispunct isprint
197                       islower isgraph isdigit iscntrl isalpha
198                       isalnum int_macro_int getcwd frexp fpathconf
199                       fmod floor dup2 dup difftime cuserid ctime
200                       ctermid cosh constant close clock ceil
201                       bootstrap atan asin asctime acos access abort
202                       _exit
203                       /],
204                },
205
206     IO::Socket => { dflt => 'constant',         # 157/190
207
208                     perl => [qw/ timeout socktype sockopt sockname
209                              socketpair socket sockdomain sockaddr_un
210                              sockaddr_in shutdown setsockopt send
211                              register_domain recv protocol peername
212                              new listen import getsockopt croak
213                              connected connect configure confess close
214                              carp bind atmark accept
215                              /, $] > 5.009 ? ('blocking') : () ],
216
217                     XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
218                            sockatmark sockaddr_family pack_sockaddr_un
219                            pack_sockaddr_in inet_ntoa inet_aton
220                            /],
221                 },
222 };
223
224 ############
225
226 B::Concise::compile('-nobanner');       # set a silent default
227 getopts('vaVcr:', \my %opts) or
228     die <<EODIE;
229
230 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
231     tests ability to discern XS funcs using Digest::MD5 package
232     -v  : runs verbosely
233     -V  : more verbosity
234     -a  : runs all modules in CoreList
235     -c  : writes test corrections as a Data::Dumper expression
236     -r <file>   : reads file of tests, as written by -c
237     <args>      : additional modules are loaded and tested
238         (will report failures, since no XS funcs are known apriori)
239
240 EODIE
241     ;
242
243 if (%opts) {
244     require Data::Dumper;
245     Data::Dumper->import('Dumper');
246     $Data::Dumper::Sortkeys = 1;
247 }
248 my @argpkgs = @ARGV;
249 my %report;
250
251 if ($opts{r}) {
252     my $refpkgs = require "$opts{r}";
253     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
254 }
255
256 unless ($opts{a}) {
257     unless (@argpkgs) {
258         foreach $pkg (sort keys %$testpkgs) {
259             test_pkg($pkg, $testpkgs->{$pkg});
260         }
261     } else {
262         foreach $pkg (@argpkgs) {
263             test_pkg($pkg, $testpkgs->{$pkg});
264         }
265     }
266 } else {
267     corecheck();
268 }
269 ############
270
271 sub test_pkg {
272     my ($pkg, $fntypes) = @_;
273     require_ok($pkg);
274
275     # build %stash: keys are func-names, vals filled in below
276     my (%stash) = map
277         ( ($_ => 0)
278           => ( grep exists &{"$pkg\::$_"}       # grab CODE symbols
279                => grep !/__ANON__/              # but not anon subs
280                => keys %{$pkg.'::'}             # from symbol table
281                ));
282
283     for my $type (keys %matchers) {
284         foreach my $fn (@{$fntypes->{$type}}) {
285             carp "$fn can only be one of $type, $stash{$fn}\n"
286                 if $stash{$fn};
287             $stash{$fn} = $type;
288         }
289     }
290     # set default type for un-named functions
291     my $dflt = $fntypes->{dflt} || 'perl';
292     for my $k (keys %stash) {
293         $stash{$k} = $dflt unless $stash{$k};
294     }
295     $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
296
297     if ($opts{v}) {
298         diag("fntypes: " => Dumper($fntypes));
299         diag("$pkg stash: " => Dumper(\%stash));
300     }
301     foreach my $fn (reverse sort keys %stash) {
302         next if $stash{$fn} eq 'skip';
303         my $res = checkXS("${pkg}::$fn", $stash{$fn});
304         if ($res ne '1') {
305             push @{$report{$pkg}{$res}}, $fn;
306         }
307     }
308 }
309
310 sub checkXS {
311     my ($func_name, $want) = @_;
312
313     croak "unknown type $want: $func_name\n"
314         unless defined $matchers{$want};
315
316     my ($buf, $err) = render($func_name);
317     my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
318
319     unless ($res) {
320         # test failed. return type that would give success
321         for my $m (keys %matchers) {
322             return $m if $buf =~ $matchers{$m};
323         }
324     }
325     $res;
326 }
327
328 sub render {
329     my ($func_name) = @_;
330
331     B::Concise::reset_sequence();
332     B::Concise::walk_output(\my $buf);
333
334     my $walker = B::Concise::compile($func_name);
335     eval { $walker->() };
336     diag("err: $@ $buf") if $@;
337     diag("verbose: $buf") if $opts{V};
338
339     return ($buf, $@);
340 }
341
342 sub corecheck {
343     eval { require Module::CoreList };
344     if ($@) {
345         warn "Module::CoreList not available on $]\n";
346         return;
347     }
348     my $mods = $Module::CoreList::version{'5.009002'};
349     $mods = [ sort keys %$mods ];
350     print Dumper($mods);
351
352     foreach my $pkgnm (@$mods) {
353         test_pkg($pkgnm);
354     }
355 }
356
357 END {
358     if ($opts{c}) {
359         $Data::Dumper::Indent = 1;
360         print "Corrections: ", Dumper(\%report);
361
362         foreach my $pkg (sort keys %report) {
363             for my $type (keys %matchers) {
364                 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
365                     if @{$report{$pkg}{$type}};
366             }
367         }
368     }
369 }
370
371 __END__