ext/B/B/Terse.pm

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