B::RecDeparse - Deparse recursively into subroutines.

    perl -MO=RecDeparse,deparse,[@B__Deparse_opts],level,-1 [ -e '...' | bleh.pl ]

    # Or as a module :
    use B::RecDeparse;

    my $brd = B::RecDeparse->new(deparse => [ @b__deparse_opts ], level => $level);
    my $code = $brd->coderef2text(sub { ... });

    perldoc B::RecDeparse

package B::RecDeparse;

use 5.008001;

use strict;
use warnings;

use B ();

use Config;

use base qw<B::Deparse>;

our $VERSION = '0.05';

use constant {
 # p31268 made pp_entersub call single_delim
 FOOL_SINGLE_DELIM =>
     ($^V ge v5.9.5)
  || ($^V lt v5.9.0 and $^V ge v5.8.9)
  || ($Config{perl_patchlevel} && $Config{perl_patchlevel} >= 31268)
};

sub _parse_args {
 if (@_ % 2) {
  require Carp;
  Carp::croak('Optional arguments must be passed as key/value pairs');
 }
 my %args = @_;

 my $deparse = $args{deparse};
 if (defined $deparse) {
  if (!ref $deparse) {
   $deparse = [ $deparse ];
  } elsif (ref $deparse ne 'ARRAY') {
   $deparse = [ ];
  }
 } else {
  $deparse = [ ];
 }

 my $level = $args{level};
 $level    = -1  unless defined $level;
 $level    = int $level;

 return $deparse, $level;
}

sub new {
 my $class = shift;
 $class = ref($class) || $class || __PACKAGE__;

 my ($deparse, $level) = _parse_args(@_);

 my $self = bless $class->SUPER::new(@$deparse), $class;

 $self->{brd_level} = $level;

 return $self;
}

sub _recurse {
 return $_[0]->{brd_level} < 0 || $_[0]->{brd_cur} < $_[0]->{brd_level}
}

sub compile {
 my @args = @_;

 my $bd = B::Deparse->new();
 my ($deparse, $level) = _parse_args(@args);

 my $compiler = $bd->coderef2text(B::Deparse::compile(@$deparse));
 $compiler =~ s/
    ['"]? B::Deparse ['"]? \s* -> \s* (new) \s* \( ([^\)]*) \)
  /B::RecDeparse->$1(deparse => [ $2 ], level => $level)/gx;
 $compiler = eval 'sub ' . $compiler;
 die if $@;

 return $compiler;
}

sub init {
 my $self = shift;

 $self->{brd_cur}  = 0;
 $self->{brd_sub}  = 0;
 $self->{brd_seen} = { };

 $self->SUPER::init(@_);
}

my $key = $; . __PACKAGE__ . $;;

if (FOOL_SINGLE_DELIM) {
 my $oldsd = *B::Deparse::single_delim{CODE};

 no warnings 'redefine';
 *B::Deparse::single_delim = sub {
  my $body = $_[2];

  if ((caller 1)[0] eq __PACKAGE__ and $body =~ s/^$key//) {
   return $body;
  } else {
   $oldsd->(@_);
  }
 }
}

sub deparse_sub {
 my $self = shift;
 my $cv   = $_[0];

 my $name;
 unless ($cv->CvFLAGS & B::CVf_ANON()) {
  $name = $cv->GV->SAFENAME;
 }

 local $self->{brd_seen}->{$name} = 1 if defined $name;
 return $self->SUPER::deparse_sub(@_);
}

sub pp_entersub {
 my $self = shift;

 my $body = do {
  local $self->{brd_sub} = 1;
  $self->SUPER::pp_entersub(@_);
 };

 $body =~ s/^&\s*(\w)/$1/ if $self->_recurse;

 return $body;
}

sub pp_refgen {
 my $self = shift;

 return do {
  local $self->{brd_sub} = 0;
  $self->SUPER::pp_refgen(@_);
 }
}

sub pp_gv {
 my $self = shift;

 my $gv   = $self->gv_or_padgv($_[0]);
 my $name = $gv->NAME;
 my $cv   = $gv->CV;
 my $seen = $self->{brd_seen};

 my $body;
 if (!$self->{brd_sub} or !$self->_recurse or $seen->{$name} or !$$cv
     or !$cv->isa('B::CV') or $cv->ROOT->isa('B::NULL')) {
  $body = $self->SUPER::pp_gv(@_);
 } else {
  $body = do {
   local @{$self}{qw<brd_sub brd_cur>} = (0, $self->{brd_cur} + 1);
   local $seen->{$name} = 1;
   'sub ' . $self->indent($self->deparse_sub($gv->CV));
  };

  if (FOOL_SINGLE_DELIM) {
   $body = $key . $body;
  } else {
   $body .= '->';
  }
 }

 return $body;
}

1; # End of B::RecDeparse