[perl5.git] / ext / B / t / concise-xs.t

#!./perl

# 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)

=head1 SYNOPSIS

To verify that B::Concise properly reports whether functions are XS,
perl, or optimized constant subs, we test against a few core packages
which have a stable API, and which have functions of all 3 types.

=head1 WHAT IS TESTED

5 core packages are tested; Digest::MD5, B, B::Deparse, Data::Dumper,
and POSIX.  These have a mix of the 3 expected implementation types;
perl, XS, and constant (optimized constant subs).

%$testpkgs specifies what packages are tested; each package is loaded,
and the stash is scanned for the function-names in that package.

Each value in %$testpkgs is a hash-of-lists (HoL) whose keys are
implementation-types and values are lists of function-names of that type.

To keep these HoLs smaller and more managable, they may carry an
additional 'dflt' => $impl_Type, which means that unnamed functions
are expected to be of that default implementation type.  Those unnamed
functions are known from the scan of the package stash.

=head1 HOW THEY'RE TESTED

Each function is 'rendered' by B::Concise, and result is matched
against regexs for each possible implementation-type.  For some
packages, some functions may be unimplemented on some platforms.

To slay this maintenance dragon, the regexs used in like() match
against renderings which indicate that there is no implementation.

If a function is implemented differently on different platforms, the
test for that function will fail on one of those platforms.  These
specific functions can be skipped by a 'skip' => [ @list ] to the HoL
mentioned previously.  See usage for skip in B's HoL, which avoids
testing a function which doesnt exist on non-threaded builds.

=head1 OPTIONS AND ARGUMENTS

C<-v> and C<-V> trigger 2 levels of verbosity.

C<-a> uses Module::CoreList to run all core packages through the test, which
gives some interesting results.

C<-c> causes the expected XS/non-XS results to be marked with
corrections, which are then reported at program END, in a form that's
readily cut-and-pastable into this file.


C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
results accordingly.  The file is 'required', so @INC settings apply.

If module-names are given as args, those packages are run through the
test harness; this is handy for collecting further items to test, and
may be useful otherwise (ie just to see).

=head1 EXAMPLES

=over 4

=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable

Tests Storable.pm for XS/non-XS routines, writes findings (along with
test results) to stdout.  You could edit results to produce a test
file, as in next example

=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable

Loads file, and uses it to set expectations, and run tests

=item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2

Gets module list from Module::Corelist, and runs them all through the
test.  Since -c is used, this generates corrections, which are saved
in a file, which is edited down to produce ../all-xs

=item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2

This runs the tests specified in the file created in previous example.
-c is used again, and stdout verifies that all the expected results
given by -r ../all-xs are now seen.

Looking at ../foo2, you'll see 34 occurrences of the following error:

# err: Can't use an undefined value as a SCALAR reference at
# lib/B/Concise.pm line 634, <DATA> line 1.

=back

=cut

BEGIN {
    unshift @INC, 't';
    require Config;
    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
    unless ($Config::Config{useperlio}) {
        print "1..0 # Skip -- Perl configured without perlio\n";
        exit 0;
    }
}

use Getopt::Std;
use Carp;
use Test::More 'no_plan';

require_ok("B::Concise");

my %matchers = 
    ( constant	=> qr{ (?-x: is a constant sub, optimized to a \w+)
		      |(?-x: exists in stash, but has no START) }x,
      XS	=> qr/ is XS code/,
      perl	=> qr/ (next|db)state/,
      noSTART	=> qr/ exists in stash, but has no START/,
);

my $testpkgs = {
    # packages to test, with expected types for named funcs

    Digest::MD5 => { perl => [qw/ import /],
		     dflt => 'XS' },

    Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
		      dflt => 'perl' },
    B => { 
	dflt => 'constant',		# all but 47/297
	skip => [ 'regex_padav' ],	# threaded only
	perl => [qw(
		    walksymtable walkoptree_slow walkoptree_exec
		    timing_info savesym peekop parents objsym debug
		    compile_stats clearsym class
		    )],
	XS => [qw(
		  warnhook walkoptree_debug walkoptree threadsv_names
		  svref_2object sv_yes sv_undef sv_no save_BEGINs
		  regex_padav ppname perlstring opnumber minus_c
		  main_start main_root main_cv init_av inc_gv hash
		  formfeed end_av dowarn diehook defstash curstash
		  cstring comppadlist check_av cchar cast_I32 bootstrap
		  begin_av amagic_generation sub_generation address
		  ), $] > 5.009 ? ('unitcheck_av') : ()],
    },

    B::Deparse => { dflt => 'perl',	# 236 functions

	XS => [qw( svref_2object perlstring opnumber main_start
		   main_root main_cv )],

	constant => [qw/ ASSIGN CVf_LVALUE
		     CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
		     OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
		     OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
		     OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE OPpCONST_NOVER
		     OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
		     OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
		     OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
		     OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY
		     OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH
		     PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL
		     PMf_KEEP PMf_NONDESTRUCT
		     PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
		     POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
		     SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
		     /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'),
		    'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
		    ],
		 },

    POSIX => { dflt => 'constant',			# all but 252/589
	       skip => [qw/ _POSIX_JOB_CONTROL /,	# platform varying
			# Might be XS or imported from Fcntl, depending on your
			# perl version:
			qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /,
			# Might be XS or AUTOLOADed, depending on your perl
			# version:
			qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
			    WSTOPSIG WTERMSIG/,
		       'int_macro_int', # Removed in POSIX 1.16
		       ],
	       perl => [qw/ import croak AUTOLOAD /],

	       XS => [qw/ write wctomb wcstombs uname tzset tzname
		      ttyname tmpnam times tcsetpgrp tcsendbreak
		      tcgetpgrp tcflush tcflow tcdrain tanh tan
		      sysconf strxfrm strtoul strtol strtod
		      strftime strcoll sinh sigsuspend sigprocmask
		      sigpending sigaction setuid setsid setpgid
		      setlocale setgid read pipe pause pathconf
		      open nice modf mktime mkfifo mbtowc mbstowcs
		      mblen lseek log10 localeconv ldexp lchown
		      isxdigit isupper isspace ispunct isprint
		      islower isgraph isdigit iscntrl isalpha
		      isalnum getcwd frexp fpathconf
		      fmod floor dup2 dup difftime cuserid ctime
		      ctermid cosh constant close clock ceil
		      bootstrap atan asin asctime acos access abort
		      _exit
		      /],
	       },

    IO::Socket => { dflt => 'constant',		# 157/190

		    perl => [qw/ timeout socktype sockopt sockname
			     socketpair socket sockdomain sockaddr_un
			     sockaddr_in shutdown setsockopt send
			     register_domain recv protocol peername
			     new listen import getsockopt croak
			     connected connect configure confess close
			     carp bind atmark accept sockaddr_in6
			     /, $] > 5.009 ? ('blocking') : () ],

		    XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
			   sockatmark sockaddr_family pack_sockaddr_un
			   pack_sockaddr_in inet_ntoa inet_aton
			   unpack_sockaddr_in6 pack_sockaddr_in6
			   /],
            # skip inet_ntop and inet_pton as they're not exported by default
		},
};

############

B::Concise::compile('-nobanner');	# set a silent default
getopts('vaVcr:', \my %opts) or
    die <<EODIE;

usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
    tests ability to discern XS funcs using Digest::MD5 package
    -v	: runs verbosely
    -V	: more verbosity
    -a	: runs all modules in CoreList
    -c  : writes test corrections as a Data::Dumper expression
    -r <file>	: reads file of tests, as written by -c
    <args>	: additional modules are loaded and tested
    	(will report failures, since no XS funcs are known apriori)

EODIE
    ;

if (%opts) {
    require Data::Dumper;
    Data::Dumper->import('Dumper');
    $Data::Dumper::Sortkeys = 1;
}
my @argpkgs = @ARGV;
my %report;

if ($opts{r}) {
    my $refpkgs = require "$opts{r}";
    $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
}

unless ($opts{a}) {
    unless (@argpkgs) {
	foreach $pkg (sort keys %$testpkgs) {
	    test_pkg($pkg, $testpkgs->{$pkg});
	}
    } else {
	foreach $pkg (@argpkgs) {
	    test_pkg($pkg, $testpkgs->{$pkg});
	}
    }
} else {
    corecheck();
}
############

sub test_pkg {
    my ($pkg, $fntypes) = @_;
    require_ok($pkg);

    # build %stash: keys are func-names, vals filled in below
    my (%stash) = map
	( ($_ => 0)
	  => ( grep exists &{"$pkg\::$_"}	# grab CODE symbols
	       => grep !/__ANON__/		# but not anon subs
	       => keys %{$pkg.'::'}		# from symbol table
	       ));

    for my $type (keys %matchers) {
	foreach my $fn (@{$fntypes->{$type}}) {
	    carp "$fn can only be one of $type, $stash{$fn}\n"
		if $stash{$fn};
	    $stash{$fn} = $type;
	}
    }
    # set default type for un-named functions
    my $dflt = $fntypes->{dflt} || 'perl';
    for my $k (keys %stash) {
	$stash{$k} = $dflt unless $stash{$k};
    }
    $stash{$_} = 'skip' foreach @{$fntypes->{skip}};

    if ($opts{v}) {
	diag("fntypes: " => Dumper($fntypes));
	diag("$pkg stash: " => Dumper(\%stash));
    }
    foreach my $fn (reverse sort keys %stash) {
	next if $stash{$fn} eq 'skip';
	my $res = checkXS("${pkg}::$fn", $stash{$fn});
	if ($res ne '1') {
	    push @{$report{$pkg}{$res}}, $fn;
	}
    }
}

sub checkXS {
    my ($func_name, $want) = @_;

    croak "unknown type $want: $func_name\n"
	unless defined $matchers{$want};

    my ($buf, $err) = render($func_name);
    my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");

    unless ($res) {
	# test failed. return type that would give success
	for my $m (keys %matchers) {
	    return $m if $buf =~ $matchers{$m};
	}
    }
    $res;
}

sub render {
    my ($func_name) = @_;

    B::Concise::reset_sequence();
    B::Concise::walk_output(\my $buf);

    my $walker = B::Concise::compile($func_name);
    eval { $walker->() };
    diag("err: $@ $buf") if $@;
    diag("verbose: $buf") if $opts{V};

    return ($buf, $@);
}

sub corecheck {
    eval { require Module::CoreList };
    if ($@) {
	warn "Module::CoreList not available on $]\n";
	return;
    }
    my $mods = $Module::CoreList::version{'5.009002'};
    $mods = [ sort keys %$mods ];
    print Dumper($mods);

    foreach my $pkgnm (@$mods) {
	test_pkg($pkgnm);
    }
}

END {
    if ($opts{c}) {
	$Data::Dumper::Indent = 1;
	print "Corrections: ", Dumper(\%report);

	foreach my $pkg (sort keys %report) {
	    for my $type (keys %matchers) {
		print "$pkg: $type: @{$report{$pkg}{$type}}\n"
		    if @{$report{$pkg}{$type}};
	    }
	}
    }
}

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