ext/B/B/Terse.pm

   1 package B::Terse;
   2
   3 our $VERSION = '1.00';
   4
   5 use strict;
   6 use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow
   7          main_start main_root cstring svref_2object SVf_IVisUV);
   8 use B::Asmdata qw(@specialsv_name);
   9
  10 sub terse {
  11     my ($order, $cvref) = @_;
  12     my $cv = svref_2object($cvref);
  13     if ($order eq "exec") {
  14         walkoptree_exec($cv->START, "terse");
  15     } else {
  16         walkoptree_slow($cv->ROOT, "terse");
  17     }
  18 }
  19
  20 sub compile {
  21     my $order = @_ ? shift : "";
  22     my @options = @_;
  23     B::clearsym();
  24     if (@options) {
  25         return sub {
  26             my $objname;
  27             foreach $objname (@options) {
  28                 $objname = "main::$objname" unless $objname =~ /::/;
  29                 eval "terse(\$order, \\&$objname)";
  30                 die "terse($order, \\&$objname) failed: $@" if $@;
  31             }
  32         }
  33     } else {
  34         if ($order eq "exec") {
  35             return sub { walkoptree_exec(main_start, "terse") }
  36         } else {
  37             return sub { walkoptree_slow(main_root, "terse") }
  38         }
  39     }
  40 }
  41
  42 sub indent {
  43     my $level = @_ ? shift : 0;
  44     return "    " x $level;
  45 }
  46
  47 sub B::OP::terse {
  48     my ($op, $level) = @_;
  49     my $targ = $op->targ;
  50     $targ = ($targ > 0) ? " [$targ]" : "";
  51     print indent($level), peekop($op), $targ, "\n";
  52 }
  53
  54 sub B::SVOP::terse {
  55     my ($op, $level) = @_;
  56     print indent($level), peekop($op), "  ";
  57     $op->sv->terse(0);
  58 }
  59
  60 sub B::PADOP::terse {
  61     my ($op, $level) = @_;
  62     print indent($level), peekop($op), "  ", $op->padix, "\n";
  63 }
  64
  65 sub B::PMOP::terse {
  66     my ($op, $level) = @_;
  67     my $precomp = $op->precomp;
  68     print indent($level), peekop($op),
  69         defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
  70
  71 }
  72
  73 sub B::PVOP::terse {
  74     my ($op, $level) = @_;
  75     print indent($level), peekop($op), " ", cstring($op->pv), "\n";
  76 }
  77
  78 sub B::COP::terse {
  79     my ($op, $level) = @_;
  80     my $label = $op->label;
  81     if ($label) {
  82         $label = " label ".cstring($label);
  83     }
  84     print indent($level), peekop($op), $label || "", "\n";
  85 }
  86
  87 sub B::PV::terse {
  88     my ($sv, $level) = @_;
  89     print indent($level);
  90     printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
  91 }
  92
  93 sub B::AV::terse {
  94     my ($sv, $level) = @_;
  95     print indent($level);
  96     printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
  97 }
  98
  99 sub B::GV::terse {
 100     my ($gv, $level) = @_;
 101     my $stash = $gv->STASH->NAME;
 102     if ($stash eq "main") {
 103         $stash = "";
 104     } else {
 105         $stash = $stash . "::";
 106     }
 107     print indent($level);
 108     printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME;
 109 }
 110
 111 sub B::IV::terse {
 112     my ($sv, $level) = @_;
 113     print indent($level);
 114     my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d";
 115     printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value;
 116 }
 117
 118 sub B::NV::terse {
 119     my ($sv, $level) = @_;
 120     print indent($level);
 121     printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
 122 }
 123
 124 sub B::RV::terse {
 125     my ($rv, $level) = @_;
 126     print indent($level);
 127     printf "%s (0x%lx) %s\n", class($rv), $$rv, printref($rv);
 128 }
 129
 130 sub printref {
 131     my $rv = shift;
 132     my $rcl = class($rv->RV);
 133     if ($rcl eq 'PV') {
 134         return "\\" . cstring($rv->RV->$rcl);
 135     } elsif ($rcl eq 'NV') {
 136         return "\\" . $rv->RV->$rcl;
 137     } elsif ($rcl eq 'IV') {
 138         return sprintf "\\%" . ($rv->RV->FLAGS & SVf_IVisUV ? "u" : "d"),
 139             $rv->RV->int_value;
 140     } elsif ($rcl eq 'RV') {
 141         return "\\" . printref($rv->RV);
 142     }
 143 }
 144
 145 sub B::NULL::terse {
 146     my ($sv, $level) = @_;
 147     print indent($level);
 148     printf "%s (0x%lx)\n", class($sv), $$sv;
 149 }
 150
 151 sub B::SPECIAL::terse {
 152     my ($sv, $level) = @_;
 153     print indent($level);
 154     printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
 155 }
 156
 157 1;
 158
 159 __END__
 160
 161 =head1 NAME
 162
 163 B::Terse - Walk Perl syntax tree, printing terse info about ops
 164
 165 =head1 SYNOPSIS
 166
 167         perl -MO=Terse[,OPTIONS] foo.pl
 168
 169 =head1 DESCRIPTION
 170
 171 See F<ext/B/README>.
 172
 173 =head1 AUTHOR
 174
 175 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 176
 177 =cut