ext/B/t/b.t See if B works
ext/B/t/bytecode.t See whether B::Bytecode works
ext/B/t/concise.t See whether B::Concise works
+ext/B/t/concise-xs.t See whether B::Concise recognizes XS functions
ext/B/t/debug.t See if B::Debug works
ext/B/t/deparse.t See if B::Deparse works
ext/B/TESTS Compiler backend test data
use Exporter (); # use #5
-our $VERSION = "0.65";
+our $VERSION = "0.66";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
}
sub concise_subref {
- my($order, $coderef) = @_;
+ my($order, $coderef, $name) = @_;
my $codeobj = svref_2object($coderef);
- return concise_stashref(@_)
+ return concise_stashref(@_)
unless ref $codeobj eq 'B::CV';
- concise_cv_obj($order, $codeobj);
+ concise_cv_obj($order, $codeobj, $name);
}
sub concise_stashref {
# This should have been called concise_subref, but it was exported
# under this name in versions before 0.56
-sub concise_cv { concise_subref(@_); }
+*concise_cv = \&concise_subref;
sub concise_cv_obj {
- my ($order, $cv) = @_;
+ my ($order, $cv, $name) = @_;
+ # name is either a string, or a CODE ref (copy of $cv arg??)
+
$curcv = $cv;
- die "err: coderef has no START\n" if class($cv->START) eq "NULL";
+ if ($cv->XSUB) {
+ print $walkHandle "$name is XS code\n";
+ return;
+ }
+ if (class($cv->START) eq "NULL") {
+ no strict 'refs';
+ if (ref $name eq 'CODE') {
+ print $walkHandle "coderef $name has no START\n";
+ }
+ elsif (exists &$name) {
+ print $walkHandle "subroutine $name exists\n";
+ }
+ else {
+ print $walkHandle "$name not in symbol table\n";
+ }
+ return;
+ }
sequence($cv->START);
if ($order eq "exec") {
walk_exec($cv->START);
- } elsif ($order eq "basic") {
- walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
+ }
+ elsif ($order eq "basic") {
+ # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
+ my $root = $cv->ROOT;
+ unless (ref $root eq 'B::NULL') {
+ walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
+ } else {
+ print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
+ }
} else {
print $walkHandle tree($cv->ROOT, 0);
}
my($name, $order, @cv_s) = @_;
my $i = 1;
if ($name eq "BEGIN") {
- splice(@cv_s, 0, 7); # skip 7 BEGIN blocks in this file
+ splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
} elsif ($name eq "CHECK") {
pop @cv_s; # skip the CHECK block that calls us
}
for my $cv (@cv_s) {
print $walkHandle "$name $i:\n";
$i++;
- concise_cv_obj($order, $cv);
+ concise_cv_obj($order, $cv, $name);
}
}
sub compileOpts {
# set rendering state from options and args
- my @options = grep(/^-/, @_);
- my @args = grep(!/^-/, @_);
+ my (@options,@args);
+ if (@_) {
+ @options = grep(/^-/, @_);
+ @args = grep(!/^-/, @_);
+ }
for my $o (@options) {
# mode/order
if ($o eq "-basic") {
if ($objname eq "BEGIN") {
concise_specials("BEGIN", $order,
- B::begin_av->isa("B::AV") ?
- B::begin_av->ARRAY : ());
+ B::begin_av->isa("B::AV") ?
+ B::begin_av->ARRAY : ());
} elsif ($objname eq "INIT") {
concise_specials("INIT", $order,
- B::init_av->isa("B::AV") ?
- B::init_av->ARRAY : ());
+ B::init_av->isa("B::AV") ?
+ B::init_av->ARRAY : ());
} elsif ($objname eq "CHECK") {
concise_specials("CHECK", $order,
- B::check_av->isa("B::AV") ?
- B::check_av->ARRAY : ());
+ B::check_av->isa("B::AV") ?
+ B::check_av->ARRAY : ());
} elsif ($objname eq "END") {
concise_specials("END", $order,
- B::end_av->isa("B::AV") ?
- B::end_av->ARRAY : ());
+ B::end_av->isa("B::AV") ?
+ B::end_av->ARRAY : ());
}
else {
# convert function names to subrefs
$objname = "main::" . $objname unless $objname =~ /::/;
print $walkHandle "$objname:\n";
no strict 'refs';
- die "err: unknown function ($objname)\n"
- unless *{$objname}{CODE};
+ unless (exists &$objname) {
+ print $walkHandle "err: unknown function ($objname)\n";
+ return;
+ }
$objref = \&$objname;
}
- concise_subref($order, $objref);
+ concise_subref($order, $objref, $objname);
}
}
if (!@args or $do_main) {
walk_topdown($kid, $sub, $level + 1);
}
}
- if (class($op) eq "PMOP") {
+ elsif (class($op) eq "PMOP") {
my $maybe_root = $op->pmreplroot;
if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
# It really is the root of the replacement, not something
--- /dev/null
+#!./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 or
+perl, we test against 2 (currently) core packages which have lots of
+XS functions; B and Digest::MD5. They're listed in %$testpkgs, along
+with a list of functions that are (or are not) XS. For brevity, you
+can specify the shorter list; if they're non-xs routines, start list
+with a '!'. Data::Dumper is also tested, partly to prove the non-!
+usage.
+
+We demand-load each package, scan its stash for function names, and
+mark them as XS/not-XS according to the list given for each package.
+Then we test B::Concise's report on each.
+
+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).
+
+If -a option is given, we use Module::CoreList to run all packages,
+which gives some interesting results.
+
+-v and -V trigger 2 levels of verbosity.
+
+=cut
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ push @INC, "../../t";
+ }
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+}
+
+use Getopt::Std;
+use Carp;
+use Test::More tests => ( 1 * !!$Config::Config{useithreads}
+ + 2 * ($] > 5.009)
+ + 272);
+
+require_ok("B::Concise");
+
+my $testpkgs = {
+
+ Digest::MD5 => [qw/ ! import /],
+
+ B => [qw/ ! class clearsym compile_stats debug objsym parents
+ peekop savesym timing_info walkoptree_exec
+ walkoptree_slow walksymtable /],
+
+ Data::Dumper => [qw/ bootstrap Dumpxs /],
+};
+
+############
+
+B::Concise::compile('-nobanner'); # set a silent default
+getopts('vaV', \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
+ <args> : additional modules are loaded and tested
+ (will report failures, since no XS funcs are known aprior)
+
+EODIE
+ ;
+
+if (%opts) {
+ require Data::Dumper;
+ Data::Dumper->import('Dumper');
+ $Data::Dumper::Sortkeys = 1;
+}
+my @argpkgs = @ARGV;
+
+foreach $pkg (sort(keys %$testpkgs), @argpkgs) {
+ test_pkg($pkg, $testpkgs->{$pkg});
+}
+
+corecheck() if $opts{a};
+
+############
+
+sub test_pkg {
+ my ($pkg_name, $xslist) = @_;
+ require_ok($pkg_name);
+
+ unless (ref $xslist eq 'ARRAY') {
+ warn "no XS/non-XS function list given, assuming empty XS list";
+ $xslist = [''];
+ }
+
+ my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
+ $assumeXS = 1 if $xslist->[0] eq '!';
+
+ # build %stash: keys are func-names, vals: 1 if XS, 0 if not
+ my (%stash) = map
+ ( ($_ => $assumeXS)
+ => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
+ => grep !/__ANON__/ # but not anon subs
+ => keys %{$pkg_name.'::'} # from symbol table
+ ));
+
+ # now invert according to supplied list
+ $stash{$_} = int ! $assumeXS foreach @$xslist;
+
+ # and cleanup cruft (easier than preventing)
+ delete @stash{'!',''};
+
+ if (%opts) {
+ diag("xslist: " => Dumper($xslist));
+ diag("$pkg_name stash: " => Dumper(\%stash));
+ }
+
+ foreach $func_name (reverse sort keys %stash) {
+ $DB::single = 1 if $func_name =~ /AUTOLOAD/;
+ checkXS("${pkg_name}::$func_name", $stash{$func_name});
+ }
+}
+
+sub checkXS {
+ my ($func_name, $wantXS) = @_;
+
+ my ($buf, $err) = render($func_name);
+ if ($wantXS) {
+ like($buf, qr/\Q$func_name is XS code/,
+ "XS code:\t $func_name");
+ } else {
+ unlike($buf, qr/\Q$func_name is XS code/,
+ "perl code:\t $func_name");
+ }
+ #returns like or unlike, whichever was called
+}
+
+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.009001'}; # $]}; # undef ??
+ print Dumper($mods);
+
+ foreach my $pkgnm (sort keys %$mods) {
+ test_pkg($pkgnm);
+ }
+}
+
+__END__
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
- require 'test.pl';
+ require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More
+ sub diag { print "# @_\n" } # but this is still handy
+
}
-plan tests => 142;
+plan tests => 147;
require_ok("B::Concise");
prog => q{$a=$b && print q/foo/},
stderr => 1,
);
-
+#diag($out);
like($out, qr/print/, "'-exec' option output has print opcode");
######## API tests v.60
eval { set_style (@stylespec) };
like ($@, qr/expecting 3 style-format args/,
- "set_style rejects bad style-format args");
+ "set_style rejects bad style-format args");
#### for content with doc'd options
our($a, $b);
my $func = sub{ $a = $b+42 }; # canonical example asub
+sub render {
+ walk_output(\my $out);
+ eval { B::Concise::compile(@_)->() };
+ # diag "rendering $@\n";
+ return ($out, $@) if wantarray;
+ return $out;
+}
+
SKIP: {
# tests output to GLOB, using perlio feature directly
skip "no perlio on this build", 122
-base10 -bigendian -littleendian
);
foreach $opt (@options) {
- walk_output(\my $out);
- my $treegen = B::Concise::compile($opt, $func);
- $treegen->();
- #print "foo:$out\n";
+ ($out) = render($opt, $func);
isnt($out, '', "got output with option $opt");
}
$treegen->();
ok($buf, "walk_output to GLOB, output seen");
- ## Test B::Concise::compile error checking
+ ## test B::Concise::compile error checking
# call compile on non-CODE ref items
if (0) {
eval { B::Concise::compile('-basic', $ref)->() };
like ($@, qr/^err: not a coderef: $typ/,
"compile detects $typ-ref where expecting subref");
- # is($out,'', "no output when errd"); # announcement prints
+ is($out,'', "no output when errd"); # announcement prints
}
}
# in debugger, it should look like:
# 1 CODE(0x84840cc)
# -> &CODE(0x84840cc) in ???
- sub nosuchfunc;
- eval { B::Concise::compile('-basic', \&nosuchfunc)->() };
- like ($@, qr/^err: coderef has no START/,
- "compile detects CODE-ref w/o actual code");
-
- foreach my $opt (qw( -concise -exec )) {
- eval { B::Concise::compile($opt,'non_existent_function')->() };
- like ($@, qr/unknown function \(main::non_existent_function\)/,
- "'$opt' reports non-existent-function properly");
+
+ my ($res,$err);
+ TODO: {
+ local $TODO = "\tdoes this handling make sense ?";
+
+ sub declared_only;
+ ($res,$err) = render('-basic', \&declared_only);
+ like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
+ "'sub decl_only' seen as having no START");
+
+ sub defd_empty {};
+ ($res,$err) = render('-basic', \&defd_empty);
+ is(scalar split(/\n/, $res), 3,
+ "'sub defd_empty {}' seen as 3 liner");
+
+ is(1, $res =~ /leavesub/ && $res =~ /nextstate/,
+ "'sub defd_empty {}' seen as 2 ops: leavesub,nextstate");
+
+ ($res,$err) = render('-basic', \¬_even_declared);
+ like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
+ "'\¬_even_declared' seen as having no START");
+
+ {
+ package Bar;
+ our $AUTOLOAD = 'garbage';
+ sub AUTOLOAD { print "# in AUTOLOAD: $AUTOLOAD\n" }
+ }
+ ($res,$err) = render('-basic', Bar::auto_func);
+ like ($res, qr/unknown function \(Bar::auto_func\)/,
+ "Bar::auto_func seen as unknown function");
+
+ ($res,$err) = render('-basic', \&Bar::auto_func);
+ like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
+ "'\&Bar::auto_func' seen as having no START");
+
+ ($res,$err) = render('-basic', \&Bar::AUTOLOAD);
+ like ($res, qr/called Bar::AUTOLOAD/, "found body of Bar::AUTOLOAD");
+
}
+ ($res,$err) = render('-basic', Foo::bar);
+ like ($res, qr/unknown function \(Foo::bar\)/,
+ "BC::compile detects fn-name as unknown function");
# v.62 tests
projects / p5sagit/p5-mst-13.2.git / commitdiff