ext/B/B/Debug.pm

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