ext/B/B/Debug.pm

   1 package B::Debug;
   2 use strict;
   3 use B qw(peekop class walkoptree walkoptree_exec
   4          main_start main_root cstring sv_undef);
   5 use B::Asmdata qw(@specialsv_name);
   6
   7 my %done_gv;
   8
   9 sub B::OP::debug {
  10     my ($op) = @_;
  11     printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
  12 %s (0x%lx)
  13         op_next         0x%x
  14         op_sibling      0x%x
  15         op_ppaddr       %s
  16         op_targ         %d
  17         op_type         %d
  18         op_seq          %d
  19         op_flags        %d
  20         op_private      %d
  21 EOT
  22 }
  23
  24 sub B::UNOP::debug {
  25     my ($op) = @_;
  26     $op->B::OP::debug();
  27     printf "\top_first\t0x%x\n", ${$op->first};
  28 }
  29
  30 sub B::BINOP::debug {
  31     my ($op) = @_;
  32     $op->B::UNOP::debug();
  33     printf "\top_last\t\t0x%x\n", ${$op->last};
  34 }
  35
  36 sub B::LOGOP::debug {
  37     my ($op) = @_;
  38     $op->B::UNOP::debug();
  39     printf "\top_other\t0x%x\n", ${$op->other};
  40 }
  41
  42 sub B::LISTOP::debug {
  43     my ($op) = @_;
  44     $op->B::BINOP::debug();
  45     printf "\top_children\t%d\n", $op->children;
  46 }
  47
  48 sub B::PMOP::debug {
  49     my ($op) = @_;
  50     $op->B::LISTOP::debug();
  51     printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
  52     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
  53     printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
  54     printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
  55     printf "\top_pmflags\t0x%x\n", $op->pmflags;
  56     $op->pmreplroot->debug;
  57 }
  58
  59 sub B::COP::debug {
  60     my ($op) = @_;
  61     $op->B::OP::debug();
  62     printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase, $op->line, ${$op->warnings};
  63         cop_label       %s
  64         cop_stashpv     %s
  65         cop_file        %s
  66         cop_seq         %d
  67         cop_arybase     %d
  68         cop_line        %d
  69         cop_warnings    0x%x
  70 EOT
  71 }
  72
  73 sub B::SVOP::debug {
  74     my ($op) = @_;
  75     $op->B::OP::debug();
  76     printf "\top_sv\t\t0x%x\n", ${$op->sv};
  77     $op->sv->debug;
  78 }
  79
  80 sub B::PVOP::debug {
  81     my ($op) = @_;
  82     $op->B::OP::debug();
  83     printf "\top_pv\t\t0x%x\n", $op->pv;
  84 }
  85
  86 sub B::PADOP::debug {
  87     my ($op) = @_;
  88     $op->B::OP::debug();
  89     printf "\top_padix\t\t%ld\n", $op->padix;
  90 }
  91
  92 sub B::CVOP::debug {
  93     my ($op) = @_;
  94     $op->B::OP::debug();
  95     printf "\top_cv\t\t0x%x\n", ${$op->cv};
  96 }
  97
  98 sub B::NULL::debug {
  99     my ($sv) = @_;
 100     if ($$sv == ${sv_undef()}) {
 101         print "&sv_undef\n";
 102     } else {
 103         printf "NULL (0x%x)\n", $$sv;
 104     }
 105 }
 106
 107 sub B::SV::debug {
 108     my ($sv) = @_;
 109     if (!$$sv) {
 110         print class($sv), " = NULL\n";
 111         return;
 112     }
 113     printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
 114 %s (0x%x)
 115         REFCNT          %d
 116         FLAGS           0x%x
 117 EOT
 118 }
 119
 120 sub B::PV::debug {
 121     my ($sv) = @_;
 122     $sv->B::SV::debug();
 123     my $pv = $sv->PV();
 124     printf <<'EOT', cstring($pv), length($pv);
 125         xpv_pv          %s
 126         xpv_cur         %d
 127 EOT
 128 }
 129
 130 sub B::IV::debug {
 131     my ($sv) = @_;
 132     $sv->B::SV::debug();
 133     printf "\txiv_iv\t\t%d\n", $sv->IV;
 134 }
 135
 136 sub B::NV::debug {
 137     my ($sv) = @_;
 138     $sv->B::IV::debug();
 139     printf "\txnv_nv\t\t%s\n", $sv->NV;
 140 }
 141
 142 sub B::PVIV::debug {
 143     my ($sv) = @_;
 144     $sv->B::PV::debug();
 145     printf "\txiv_iv\t\t%d\n", $sv->IV;
 146 }
 147
 148 sub B::PVNV::debug {
 149     my ($sv) = @_;
 150     $sv->B::PVIV::debug();
 151     printf "\txnv_nv\t\t%s\n", $sv->NV;
 152 }
 153
 154 sub B::PVLV::debug {
 155     my ($sv) = @_;
 156     $sv->B::PVNV::debug();
 157     printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
 158     printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
 159     printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
 160 }
 161
 162 sub B::BM::debug {
 163     my ($sv) = @_;
 164     $sv->B::PVNV::debug();
 165     printf "\txbm_useful\t%d\n", $sv->USEFUL;
 166     printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
 167     printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
 168 }
 169
 170 sub B::CV::debug {
 171     my ($sv) = @_;
 172     $sv->B::PVNV::debug();
 173     my ($stash) = $sv->STASH;
 174     my ($start) = $sv->START;
 175     my ($root) = $sv->ROOT;
 176     my ($padlist) = $sv->PADLIST;
 177     my ($file) = $sv->FILE;
 178     my ($gv) = $sv->GV;
 179     printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
 180         STASH           0x%x
 181         START           0x%x
 182         ROOT            0x%x
 183         GV              0x%x
 184         FILE            %s
 185         DEPTH           %d
 186         PADLIST         0x%x
 187         OUTSIDE         0x%x
 188 EOT
 189     $start->debug if $start;
 190     $root->debug if $root;
 191     $gv->debug if $gv;
 192     $padlist->debug if $padlist;
 193 }
 194
 195 sub B::AV::debug {
 196     my ($av) = @_;
 197     $av->B::SV::debug;
 198     my(@array) = $av->ARRAY;
 199     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
 200     printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;
 201         FILL            %d
 202         MAX             %d
 203         OFF             %d
 204         AvFLAGS         %d
 205 EOT
 206 }
 207
 208 sub B::GV::debug {
 209     my ($gv) = @_;
 210     if ($done_gv{$$gv}++) {
 211         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME;
 212         return;
 213     }
 214     my ($sv) = $gv->SV;
 215     my ($av) = $gv->AV;
 216     my ($cv) = $gv->CV;
 217     $gv->B::SV::debug;
 218     printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
 219         NAME            %s
 220         STASH           %s (0x%x)
 221         SV              0x%x
 222         GvREFCNT        %d
 223         FORM            0x%x
 224         AV              0x%x
 225         HV              0x%x
 226         EGV             0x%x
 227         CV              0x%x
 228         CVGEN           %d
 229         LINE            %d
 230         FILE            %s
 231         GvFLAGS         0x%x
 232 EOT
 233     $sv->debug if $sv;
 234     $av->debug if $av;
 235     $cv->debug if $cv;
 236 }
 237
 238 sub B::SPECIAL::debug {
 239     my $sv = shift;
 240     print $specialsv_name[$$sv], "\n";
 241 }
 242
 243 sub compile {
 244     my $order = shift;
 245     B::clearsym();
 246     if ($order && $order eq "exec") {
 247         return sub { walkoptree_exec(main_start, "debug") }
 248     } else {
 249         return sub { walkoptree(main_root, "debug") }
 250     }
 251 }
 252
 253 1;
 254
 255 __END__
 256
 257 =head1 NAME
 258
 259 B::Debug - Walk Perl syntax tree, printing debug info about ops
 260
 261 =head1 SYNOPSIS
 262
 263         perl -MO=Debug[,OPTIONS] foo.pl
 264
 265 =head1 DESCRIPTION
 266
 267 See F<ext/B/README>.
 268
 269 =head1 AUTHOR
 270
 271 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 272
 273 =cut