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