ext/B/B/Lint/Debug.pm

   1 package B::Lint::Debug;
   2
   3 =head1 NAME
   4
   5 B::Lint::Debug - Adds debugging stringification to B::
   6
   7 =head1 DESCRIPTION
   8
   9 This module injects stringification to a B::OP*/B::SPECIAL. This
  10 should not be loaded unless you're debugging.
  11
  12 =cut
  13
  14 package B::SPECIAL;
  15 use overload '""' => sub {
  16     my $self = shift @_;
  17     "SPECIAL($$self)";
  18 };
  19
  20 package B::OP;
  21 use overload '""' => sub {
  22     my $self  = shift @_;
  23     my $class = ref $self;
  24     $class =~ s/\AB:://xms;
  25     my $name = $self->name;
  26     "$class($name)";
  27 };
  28
  29 package B::SVOP;
  30 use overload '""' => sub {
  31     my $self  = shift @_;
  32     my $class = ref $self;
  33     $class =~ s/\AB:://xms;
  34     my $name = $self->name;
  35     "$class($name," . $self->sv . "," . $self->gv . ")";
  36 };
  37
  38 package B::SPECIAL;
  39 sub DESTROY { }
  40 our $AUTOLOAD;
  41
  42 sub AUTOLOAD {
  43     my $cx = 0;
  44     print "AUTOLOAD $AUTOLOAD\n";
  45
  46     package DB;
  47     while ( my @stuff = caller $cx ) {
  48
  49         print "$cx: [@DB::args] [@stuff]\n";
  50         if ( ref $DB::args[0] ) {
  51             if ( $DB::args[0]->can('padix') ) {
  52                 print "    PADIX: " . $DB::args[0]->padix . "\n";
  53             }
  54             if ( $DB::args[0]->can('targ') ) {
  55                 print "    TARG: " . $DB::args[0]->targ . "\n";
  56                 for ( B::Lint::cv()->PADLIST->ARRAY ) {
  57                     print +( $_->ARRAY )[ $DB::args[0]->targ ] . "\n";
  58                 }
  59             }
  60         }
  61         ++$cx;
  62     }
  63 }
  64
  65 1;