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