cpan/B-Debug/Debug.pm

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