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