cpan/B-Debug/Debug.pm

   1 package B::Debug;
   2
   3 our $VERSION = '1.11';
   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.11 2008-07-14 rurban
 352         avoid B::Flags in CORE tests not to crash on old XS in @INC
 353
 354   1.10 2008-06-28 rurban
 355         require 5.006; Test::More not possible in 5.00505
 356         our => my
 357
 358   1.09 2008-06-18 rurban
 359         minor META.yml syntax fix
 360         5.8.0 ending nextstate test failure: be more tolerant
 361         PREREQ_PM Test::More
 362
 363   1.08 2008-06-17 rurban
 364         support 5.00558 - 5.6.2
 365
 366   1.07 2008-06-16 rurban
 367         debug.t: fix strawberry perl quoting issue
 368
 369   1.06 2008-06-11 rurban
 370         added B::Flags output
 371         dual-life CPAN as B-Debug-1.06 and CORE
 372         protect scalar(@array) if tied arrays leave out FETCHSIZE
 373
 374   1.05_03 2008-04-16 rurban
 375         ithread fixes in B::AV
 376         B-C-1.04_??
 377
 378   B-C-1.04_09 2008-02-24 rurban
 379         support 5.8 (import Asmdata)
 380
 381   1.05_02 2008-02-21 rurban
 382         added _printop
 383         B-C-1.04_08 and CORE
 384
 385   1.05_01 2008-02-05 rurban
 386         5.10 fix for op->seq
 387         B-C-1.04_04
 388
 389 =head1 AUTHOR
 390
 391 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 392 Reini Urban C<rurban@cpan.org>
 393
 394 =head1 LICENSE
 395
 396 Copyright (c) 1996, 1997 Malcolm Beattie
 397 Copyright (c) 2008 Reini Urban
 398
 399         This program is free software; you can redistribute it and/or modify
 400         it under the terms of either:
 401
 402         a) the GNU General Public License as published by the Free
 403         Software Foundation; either version 1, or (at your option) any
 404         later version, or
 405
 406         b) the "Artistic License" which comes with this kit.
 407
 408     This program is distributed in the hope that it will be useful,
 409     but WITHOUT ANY WARRANTY; without even the implied warranty of
 410     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
 411     the GNU General Public License or the Artistic License for more details.
 412
 413     You should have received a copy of the Artistic License with this kit,
 414     in the file named "Artistic".  If not, you can get one from the Perl
 415     distribution. You should also have received a copy of the GNU General
 416     Public License, in the file named "Copying". If not, you can get one
 417     from the Perl distribution or else write to the Free Software Foundation,
 418     Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
 419
 420 =cut