lib/B/RecDeparse.pm

   1 package B::RecDeparse;
   2
   3 use 5.008001;
   4
   5 use strict;
   6 use warnings;
   7
   8 use B ();
   9
  10 use Config;
  11
  12 use base qw<B::Deparse>;
  13
  14 =head1 NAME
  15
  16 B::RecDeparse - Deparse recursively into subroutines.
  17
  18 =head1 VERSION
  19
  20 Version 0.07
  21
  22 =cut
  23
  24 our $VERSION = '0.07';
  25
  26 =head1 SYNOPSIS
  27
  28     perl -MO=RecDeparse,deparse,[@B__Deparse_opts],level,-1 [ -e '...' | bleh.pl ]
  29
  30     # Or as a module :
  31     use B::RecDeparse;
  32
  33     my $brd = B::RecDeparse->new(deparse => [ @b__deparse_opts ], level => $level);
  34     my $code = $brd->coderef2text(sub { ... });
  35
  36 =head1 DESCRIPTION
  37
  38 This module extends L<B::Deparse> by making it recursively replace subroutine calls encountered when deparsing.
  39
  40 Please refer to L<B::Deparse> documentation for what to do and how to do it.
  41 Besides the constructor syntax, everything should work the same for the two modules.
  42
  43 =head1 METHODS
  44
  45 =head2 C<< new < deparse => [ @B__Deparse_opts ], level => $level > >>
  46
  47 The L<B::RecDeparse> object constructor.
  48 You can specify the underlying L<B::Deparse> constructor arguments by passing a string or an array reference as the value of the C<deparse> key.
  49 The C<level> option expects an integer that specifies how many levels of recursions are allowed : C<-1> means infinite while C<0> means none and match L<B::Deparse> behaviour.
  50
  51 =cut
  52
  53 use constant {
  54  # p31268 made pp_entersub call single_delim
  55  FOOL_SINGLE_DELIM =>
  56      ($^V ge v5.9.5)
  57   || ($^V lt v5.9.0 and $^V ge v5.8.9)
  58   || ($Config{perl_patchlevel} && $Config{perl_patchlevel} >= 31268)
  59 };
  60
  61 sub _parse_args {
  62  if (@_ % 2) {
  63   require Carp;
  64   Carp::croak('Optional arguments must be passed as key/value pairs');
  65  }
  66  my %args = @_;
  67
  68  my $deparse = $args{deparse};
  69  if (defined $deparse) {
  70   if (!ref $deparse) {
  71    $deparse = [ $deparse ];
  72   } elsif (ref $deparse ne 'ARRAY') {
  73    $deparse = [ ];
  74   }
  75  } else {
  76   $deparse = [ ];
  77  }
  78
  79  my $level = $args{level};
  80  $level    = -1  unless defined $level;
  81  $level    = int $level;
  82
  83  return $deparse, $level;
  84 }
  85
  86 sub new {
  87  my $class = shift;
  88  $class = ref($class) || $class || __PACKAGE__;
  89
  90  my ($deparse, $level) = _parse_args(@_);
  91
  92  my $self = bless $class->SUPER::new(@$deparse), $class;
  93
  94  $self->{brd_level} = $level;
  95
  96  return $self;
  97 }
  98
  99 sub _recurse {
 100  return $_[0]->{brd_level} < 0 || $_[0]->{brd_cur} < $_[0]->{brd_level}
 101 }
 102
 103 sub compile {
 104  my @args = @_;
 105
 106  my $bd = B::Deparse->new();
 107  my ($deparse, $level) = _parse_args(@args);
 108
 109  my $compiler = $bd->coderef2text(B::Deparse::compile(@$deparse));
 110  $compiler =~ s/
 111   ['"]? B::Deparse ['"]? \s* -> \s* (new) \s* \( ([^\)]*) \)
 112  /B::RecDeparse->$1(deparse => [ $2 ], level => $level)/gx;
 113  $compiler = eval 'sub ' . $compiler;
 114  die if $@;
 115
 116  return $compiler;
 117 }
 118
 119 sub init {
 120  my $self = shift;
 121
 122  $self->{brd_cur}  = 0;
 123  $self->{brd_sub}  = 0;
 124  $self->{brd_seen} = { };
 125
 126  $self->SUPER::init(@_);
 127 }
 128
 129 my $key = $; . __PACKAGE__ . $;;
 130
 131 if (FOOL_SINGLE_DELIM) {
 132  my $oldsd = *B::Deparse::single_delim{CODE};
 133
 134  no warnings 'redefine';
 135  *B::Deparse::single_delim = sub {
 136   my $body = $_[2];
 137
 138   if ((caller 1)[0] eq __PACKAGE__ and $body =~ s/^$key//) {
 139    return $body;
 140   } else {
 141    $oldsd->(@_);
 142   }
 143  }
 144 }
 145
 146 sub deparse_sub {
 147  my $self = shift;
 148  my $cv   = $_[0];
 149
 150  my $name;
 151  unless ($cv->CvFLAGS & B::CVf_ANON()) {
 152   $name = $cv->GV->SAFENAME;
 153  }
 154
 155  local $self->{brd_seen}->{$name} = 1 if defined $name;
 156  return $self->SUPER::deparse_sub(@_);
 157 }
 158
 159 sub pp_entersub {
 160  my $self = shift;
 161
 162  my $body = do {
 163   local $self->{brd_sub} = 1;
 164   $self->SUPER::pp_entersub(@_);
 165  };
 166
 167  $body =~ s/^&\s*(\w)/$1/ if $self->_recurse;
 168
 169  return $body;
 170 }
 171
 172 sub pp_refgen {
 173  my $self = shift;
 174
 175  return do {
 176   local $self->{brd_sub} = 0;
 177   $self->SUPER::pp_refgen(@_);
 178  }
 179 }
 180
 181 sub pp_gv {
 182  my $self = shift;
 183
 184  my $gv   = $self->gv_or_padgv($_[0]);
 185  my $name = $gv->NAME;
 186  my $cv   = $gv->CV;
 187  my $seen = $self->{brd_seen};
 188
 189  my $body;
 190  if (!$self->{brd_sub} or !$self->_recurse or $seen->{$name} or !$$cv
 191      or !$cv->isa('B::CV') or $cv->ROOT->isa('B::NULL')) {
 192   $body = $self->SUPER::pp_gv(@_);
 193  } else {
 194   $body = do {
 195    local @{$self}{qw<brd_sub brd_cur>} = (0, $self->{brd_cur} + 1);
 196    local $seen->{$name} = 1;
 197    'sub ' . $self->indent($self->deparse_sub($gv->CV));
 198   };
 199
 200   if (FOOL_SINGLE_DELIM) {
 201    $body = $key . $body;
 202   } else {
 203    $body .= '->';
 204   }
 205  }
 206
 207  return $body;
 208 }
 209
 210 =head2 C<compile>
 211
 212 =head2 C<init>
 213
 214 =head2 C<deparse_sub>
 215
 216 =head2 C<pp_entersub>
 217
 218 =head2 C<pp_refgen>
 219
 220 =head2 C<pp_gv>
 221
 222 Functions and methods from L<B::Deparse> reimplemented by this module.
 223 Never call them directly.
 224
 225 Otherwise, L<B::RecDeparse> inherits all methods from L<B::Deparse>.
 226
 227 =head1 EXPORT
 228
 229 An object-oriented module shouldn't export any function, and so does this one.
 230
 231 =head1 DEPENDENCIES
 232
 233 L<perl> 5.8.1.
 234
 235 L<Carp> (standard since perl 5), L<Config> (since perl 5.00307) and L<B::Deparse> (since perl 5.005).
 236
 237 =head1 AUTHOR
 238
 239 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 240
 241 You can contact me by mail or on C<irc.perl.org> (vincent).
 242
 243 =head1 BUGS
 244
 245 Please report any bugs or feature requests to C<bug-b-recdeparse at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=B-RecDeparse>.
 246 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 247
 248 =head1 SUPPORT
 249
 250 You can find documentation for this module with the perldoc command.
 251
 252     perldoc B::RecDeparse
 253
 254 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/B-RecDeparse>.
 255
 256 =head1 COPYRIGHT & LICENSE
 257
 258 Copyright 2008,2009,2010,2011,2013 Vincent Pit, all rights reserved.
 259
 260 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 261
 262 =cut
 263
 264 1; # End of B::RecDeparse