cpan/B-Debug/Debug.pm

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