cpan/B-Debug/Debug.pm

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