ext/B/B/Debug.pm

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