ext/B/B/Debug.pm

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