cpan/B-Debug/Debug.pm

   1 package B::Debug;
   2
   3 our $VERSION = '1.23';
   4
   5 use strict;
   6 require 5.006;
   7 use B qw(peekop class walkoptree walkoptree_exec
   8          main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
   9 use Config;
  10 my (@optype, @specialsv_name);
  11 require B;
  12 if ($] < 5.009) {
  13   require B::Asmdata;
  14   B::Asmdata->import (qw(@optype @specialsv_name));
  15 } else {
  16   B->import (qw(@optype @specialsv_name));
  17 }
  18
  19 if ($] < 5.006002) {
  20   eval q|sub B::GV::SAFENAME {
  21     my $name = (shift())->NAME;
  22     # The regex below corresponds to the isCONTROLVAR macro from toke.c
  23     $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e;
  24     return $name;
  25   }|;
  26 }
  27
  28 my ($have_B_Flags, $have_B_Flags_extra);
  29 if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
  30   eval { require B::Flags and $have_B_Flags++ };
  31   $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03';
  32 }
  33 my %done_gv;
  34
  35 sub _printop {
  36   my $op = shift;
  37   my $addr = ${$op} ? $op->ppaddr : '';
  38   $addr =~ s/^PL_ppaddr// if $addr;
  39   if (${$op}) {
  40     return sprintf "0x%08x %6s %s", ${$op}, class($op), $addr;
  41   } else {
  42     return sprintf "0x%x %6s %s", ${$op}, '', $addr;
  43   }
  44 }
  45
  46 sub B::OP::debug {
  47     my ($op) = @_;
  48     printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
  49 %s (0x%lx)
  50         op_ppaddr       %s
  51         op_next         %s
  52         op_sibling      %s
  53         op_targ         %d
  54         op_type         %d      %s
  55 EOT
  56     if ($] > 5.009) {
  57         printf <<'EOT', $op->opt;
  58         op_opt          %d
  59 EOT
  60     } else {
  61         printf <<'EOT', $op->seq;
  62         op_seq          %d
  63 EOT
  64     }
  65     if ($have_B_Flags) {
  66         printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
  67         op_flags        %d      %s
  68         op_private      %d      %s
  69 EOT
  70     } else {
  71         printf <<'EOT', $op->flags, $op->private;
  72         op_flags        %d
  73         op_private      %d
  74 EOT
  75     }
  76 }
  77
  78 sub B::UNOP::debug {
  79     my ($op) = @_;
  80     $op->B::OP::debug();
  81     printf "\top_first\t%s\n", _printop($op->first);
  82 }
  83
  84 sub B::BINOP::debug {
  85     my ($op) = @_;
  86     $op->B::UNOP::debug();
  87     printf "\top_last \t%s\n", _printop($op->last);
  88 }
  89
  90 sub B::LOOP::debug {
  91     my ($op) = @_;
  92     $op->B::BINOP::debug();
  93     printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
  94         op_redoop       %s
  95         op_nextop       %s
  96         op_lastop       %s
  97 EOT
  98 }
  99
 100 sub B::LOGOP::debug {
 101     my ($op) = @_;
 102     $op->B::UNOP::debug();
 103     printf "\top_other\t%s\n", _printop($op->other);
 104 }
 105
 106 sub B::LISTOP::debug {
 107     my ($op) = @_;
 108     $op->B::BINOP::debug();
 109     printf "\top_children\t%d\n", $op->children;
 110 }
 111
 112 sub B::PMOP::debug {
 113     my ($op) = @_;
 114     $op->B::LISTOP::debug();
 115     printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
 116     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
 117     printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
 118     if ($Config{'useithreads'}) {
 119       printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
 120       printf "\top_pmoffset\t%d\n", $op->pmoffset;
 121     } else {
 122       printf "\top_pmstash\t%s\n", cstring($op->pmstash);
 123     }
 124     printf "\top_precomp\t%s\n", cstring($op->precomp);
 125     printf "\top_pmflags\t0x%x\n", $op->pmflags;
 126     printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
 127     printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
 128     printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
 129     $op->pmreplroot->debug if $] < 5.008;
 130 }
 131
 132 sub B::COP::debug {
 133     my ($op) = @_;
 134     $op->B::OP::debug();
 135     my $warnings = ref $op->warnings ? ${$op->warnings} : 0;
 136     printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings;
 137         cop_label       "%s"
 138         cop_stashpv     "%s"
 139         cop_file        "%s"
 140         cop_seq         %d
 141         cop_arybase     %d
 142         cop_line        %d
 143         cop_warnings    0x%x
 144 EOT
 145   if ($] > 5.008 and $] < 5.011) {
 146     my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
 147     printf("    cop_io          %s\n", cstring($cop_io));
 148   }
 149 }
 150
 151 sub B::SVOP::debug {
 152     my ($op) = @_;
 153     $op->B::OP::debug();
 154     printf "\top_sv\t\t0x%x\n", ${$op->sv};
 155     $op->sv->debug;
 156 }
 157
 158 sub B::METHOP::debug {
 159     my ($op) = @_;
 160     $op->B::OP::debug();
 161     if (${$op->first})  {
 162       printf "\top_first\t0x%x\n", ${$op->first};
 163       $op->first->debug;
 164     } else {
 165       printf "\top_meth_sv\t0x%x\n", ${$op->meth_sv};
 166       $op->meth_sv->debug;
 167     }
 168 }
 169
 170 sub B::PVOP::debug {
 171     my ($op) = @_;
 172     $op->B::OP::debug();
 173     printf "\top_pv\t\t%s\n", cstring($op->pv);
 174 }
 175
 176 sub B::PADOP::debug {
 177     my ($op) = @_;
 178     $op->B::OP::debug();
 179     printf "\top_padix\t%ld\n", $op->padix;
 180 }
 181
 182 sub B::NULL::debug {
 183     my ($sv) = @_;
 184     if ($$sv == ${sv_undef()}) {
 185         print "&sv_undef\n";
 186     } else {
 187         printf "NULL (0x%x)\n", $$sv;
 188     }
 189 }
 190
 191 sub B::SV::debug {
 192     my ($sv) = @_;
 193     if (!$$sv) {
 194         print class($sv), " = NULL\n";
 195         return;
 196     }
 197     printf <<'EOT', class($sv), $$sv, $sv->REFCNT;
 198 %s (0x%x)
 199         REFCNT          %d
 200 EOT
 201     printf "\tFLAGS\t\t0x%x", $sv->FLAGS;
 202     if ($have_B_Flags) {
 203       printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv;
 204     }
 205     print "\n";
 206 }
 207
 208 sub B::RV::debug {
 209     my ($rv) = @_;
 210     B::SV::debug($rv);
 211     printf <<'EOT', ${$rv->RV};
 212         RV              0x%x
 213 EOT
 214     $rv->RV->debug;
 215 }
 216
 217 sub B::PV::debug {
 218     my ($sv) = @_;
 219     $sv->B::SV::debug();
 220     my $pv = $sv->PV();
 221     printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN;
 222         xpv_pv          %s
 223         xpv_cur         %d
 224         xpv_len         %d
 225 EOT
 226 }
 227
 228 sub B::IV::debug {
 229     my ($sv) = @_;
 230     $sv->B::SV::debug();
 231     printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
 232 }
 233
 234 sub B::NV::debug {
 235     my ($sv) = @_;
 236     $sv->B::IV::debug();
 237     printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
 238 }
 239
 240 sub B::PVIV::debug {
 241     my ($sv) = @_;
 242     $sv->B::PV::debug();
 243     printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
 244 }
 245
 246 sub B::PVNV::debug {
 247     my ($sv) = @_;
 248     $sv->B::PVIV::debug();
 249     printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
 250 }
 251
 252 sub B::PVLV::debug {
 253     my ($sv) = @_;
 254     $sv->B::PVNV::debug();
 255     printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
 256     printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
 257     printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
 258 }
 259
 260 sub B::BM::debug {
 261     my ($sv) = @_;
 262     $sv->B::PVNV::debug();
 263     printf "\txbm_useful\t%d\n", $sv->USEFUL;
 264     printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
 265     printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
 266 }
 267
 268 sub B::CV::debug {
 269     my ($sv) = @_;
 270     $sv->B::PVNV::debug();
 271     my ($stash) = $sv->STASH;
 272     my ($start) = $sv->START;
 273     my ($root)  = $sv->ROOT;
 274     my ($padlist) = $sv->PADLIST;
 275     my ($file) = $sv->FILE;
 276     my ($gv) = $sv->GV;
 277     printf <<'EOT', $$stash, $$start, $$root;
 278         STASH           0x%x
 279         START           0x%x
 280         ROOT            0x%x
 281 EOT
 282     if ( $]>5.017 && ($sv->FLAGS & 0x40000)) { #lexsub
 283       printf("\tNAME\t%%s\n", $sv->NAME);
 284     } else {
 285       printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME);
 286     }
 287     printf <<'EOT', $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
 288         FILE            %s
 289         DEPTH           %d
 290         PADLIST         0x%x
 291         OUTSIDE         0x%x
 292 EOT
 293     printf("\tOUTSIDE_SEQ\t%d\n", $sv->OUTSIDE_SEQ) if $] > 5.007;
 294     if ($have_B_Flags) {
 295       my $SVt_PVCV = $] < 5.010 ? 12 : 13;
 296       printf("\tCvFLAGS\t0x%x\t%s\n", $sv->CvFLAGS,
 297              $have_B_Flags_extra ? $sv->flagspv($SVt_PVCV) : $sv->flagspv);
 298     } else {
 299       printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS);
 300     }
 301     $start->debug if $start;
 302     $root->debug if $root;
 303     $gv->debug if $gv;
 304     $padlist->debug if $padlist;
 305 }
 306
 307 sub B::AV::debug {
 308     my ($av) = @_;
 309     $av->B::SV::debug;
 310     _array_debug($av);
 311 }
 312
 313 sub _array_debug {
 314     my ($av) = @_;
 315     # tied arrays may leave out FETCHSIZE
 316     my (@array) = eval { $av->ARRAY; };
 317     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
 318     my $fill = eval { scalar(@array) };
 319     if ($Config{'useithreads'} && class($av) ne 'PADLIST') {
 320       printf <<'EOT', $fill, $av->MAX, $av->OFF;
 321         FILL            %d
 322         MAX             %d
 323         OFF             %d
 324 EOT
 325     } else {
 326       printf <<'EOT', $fill, $av->MAX;
 327         FILL            %d
 328         MAX             %d
 329 EOT
 330     }
 331     if ($] < 5.009) {
 332       if ($have_B_Flags) {
 333         printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
 334                $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
 335       } else {
 336         printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
 337       }
 338     }
 339 }
 340
 341 sub B::GV::debug {
 342     my ($gv) = @_;
 343     if ($done_gv{$$gv}++) {
 344         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
 345         return;
 346     }
 347     my $sv = $gv->SV;
 348     my $av = $gv->AV;
 349     my $cv = $gv->CV;
 350     $gv->B::SV::debug;
 351     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;
 352         NAME            %s
 353         STASH           %s (0x%x)
 354         SV              0x%x
 355         GvREFCNT        %d
 356         FORM            0x%x
 357         AV              0x%x
 358         HV              0x%x
 359         EGV             0x%x
 360         CV              0x%x
 361         CVGEN           %d
 362         LINE            %d
 363         FILE            %s
 364 EOT
 365     if ($have_B_Flags) {
 366       my $SVt_PVGV = $] < 5.010 ? 13 : 9;
 367       printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
 368              $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
 369     } else {
 370       printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
 371     }
 372     $sv->debug if $sv;
 373     $av->debug if $av;
 374     $cv->debug if $cv;
 375 }
 376
 377 sub B::SPECIAL::debug {
 378     my $sv = shift;
 379     my $i = ref $sv ? $$sv : 0;
 380     print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
 381 }
 382
 383 sub B::PADLIST::debug {
 384     my ($padlist) = @_;
 385     printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT;
 386 %s (0x%x)
 387         REFCNT          %d
 388 EOT
 389     _array_debug($padlist);
 390 }
 391
 392 sub compile {
 393     my $order = shift;
 394     B::clearsym();
 395     $DB::single = 1 if defined &DB::DB;
 396     if ($order && $order eq "exec") {
 397         return sub { walkoptree_exec(main_start, "debug") }
 398     } else {
 399         return sub { walkoptree(main_root, "debug") }
 400     }
 401 }
 402
 403 1;
 404
 405 __END__
 406
 407 =head1 NAME
 408
 409 B::Debug - Walk Perl syntax tree, printing debug info about ops
 410
 411 =head1 SYNOPSIS
 412
 413         perl -MO=Debug foo.pl
 414         perl -MO=Debug,-exec foo.pl
 415
 416 =head1 DESCRIPTION
 417
 418 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
 419
 420 =head1 OPTIONS
 421
 422 With option -exec, walks tree in execute order,
 423 otherwise in basic order.
 424
 425 =head1 AUTHOR
 426
 427 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 428 Reini Urban C<rurban@cpan.org>
 429
 430 =head1 LICENSE
 431
 432 Copyright (c) 1996, 1997 Malcolm Beattie
 433 Copyright (c) 2008, 2010, 2013, 2014 Reini Urban
 434
 435         This program is free software; you can redistribute it and/or modify
 436         it under the terms of either:
 437
 438         a) the GNU General Public License as published by the Free
 439         Software Foundation; either version 1, or (at your option) any
 440         later version, or
 441
 442         b) the "Artistic License" which comes with this kit.
 443
 444     This program is distributed in the hope that it will be useful,
 445     but WITHOUT ANY WARRANTY; without even the implied warranty of
 446     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
 447     the GNU General Public License or the Artistic License for more details.
 448
 449     You should have received a copy of the Artistic License with this kit,
 450     in the file named "Artistic".  If not, you can get one from the Perl
 451     distribution. You should also have received a copy of the GNU General
 452     Public License, in the file named "Copying". If not, you can get one
 453     from the Perl distribution or else write to the Free Software Foundation,
 454     Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 455
 456 =cut
 457