From: Jim Cromie Date: Sat, 21 May 2005 09:24:24 +0000 (-0600) Subject: Re: [patch] teach B::Concise to see XS code X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c0939ceec1b3e902edf1d9a47f8540b3ab3f7d61;p=p5sagit%2Fp5-mst-13.2.git Re: [patch] teach B::Concise to see XS code Message-ID: <428F52A8.20702@divsol.com> p4raw-id: //depot/perl@24653 --- diff --git a/MANIFEST b/MANIFEST index b304f9a..191c242 100644 --- a/MANIFEST +++ b/MANIFEST @@ -112,6 +112,7 @@ ext/B/t/bblock.t See if B::Bblock works 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 diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 0c4a010..2129046 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp 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 @@ -132,12 +132,12 @@ sub walk_output { # updates $walkHandle } 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 { @@ -156,17 +156,42 @@ 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); } @@ -193,14 +218,14 @@ sub concise_specials { 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); } } @@ -217,8 +242,11 @@ my @tree_decorations = 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") { @@ -278,20 +306,20 @@ sub compile { 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 @@ -304,11 +332,13 @@ sub compile { $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) { @@ -394,7 +424,7 @@ sub walk_topdown { 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 diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t new file mode 100644 index 0000000..a464087 --- /dev/null +++ b/ext/B/t/concise-xs.t @@ -0,0 +1,175 @@ +#!./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 < : 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__ diff --git a/ext/B/t/concise.t b/ext/B/t/concise.t index 1a25112..55a813d 100644 --- a/ext/B/t/concise.t +++ b/ext/B/t/concise.t @@ -13,10 +13,12 @@ BEGIN { 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"); @@ -43,7 +45,7 @@ $out = runperl( 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 @@ -120,13 +122,21 @@ is ($@, '', "set_style accepts 3 style-format args"); 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 @@ -139,10 +149,7 @@ SKIP: { -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"); } @@ -163,7 +170,7 @@ SKIP: { $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) { @@ -175,7 +182,7 @@ SKIP: { 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 } } @@ -183,16 +190,48 @@ SKIP: { # 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