ext/B/B/Debug.pm

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