lib/B/RecDeparse.pm

   1 package B::RecDeparse;
   2
   3 use 5.008_001;
   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.10
  21
  22 =cut
  23
  24 our $VERSION = '0.10';
  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>
  53
  54     my $brd = B::RecDeparse->new(
  55      deparse => \@B__Deparse_opts,
  56      level   => $level,
  57     );
  58
  59 The L<B::RecDeparse> object constructor.
  60 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.
  61 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.
  62
  63 =cut
  64
  65 use constant {
  66  # p31268 made pp_entersub call single_delim
  67  FOOL_SINGLE_DELIM =>
  68      ("$]" >= 5.009_005)
  69   || ("$]" <  5.009 and "$]" >= 5.008_009)
  70   || ($Config{perl_patchlevel} && $Config{perl_patchlevel} >= 31268)
  71 };
  72
  73 sub _parse_args {
  74  if (@_ % 2) {
  75   require Carp;
  76   Carp::croak('Optional arguments must be passed as key/value pairs');
  77  }
  78  my %args = @_;
  79
  80  my $deparse = $args{deparse};
  81  if (defined $deparse) {
  82   if (!ref $deparse) {
  83    $deparse = [ $deparse ];
  84   } elsif (ref $deparse ne 'ARRAY') {
  85    $deparse = [ ];
  86   }
  87  } else {
  88   $deparse = [ ];
  89  }
  90
  91  my $level = $args{level};
  92  $level    = -1  unless defined $level;
  93  $level    = int $level;
  94
  95  return $deparse, $level;
  96 }
  97
  98 sub new {
  99  my $class = shift;
 100  $class = ref($class) || $class || __PACKAGE__;
 101
 102  my ($deparse, $level) = _parse_args(@_);
 103
 104  my $self = bless $class->SUPER::new(@$deparse), $class;
 105
 106  $self->{brd_level} = $level;
 107
 108  return $self;
 109 }
 110
 111 sub _recurse {
 112  return $_[0]->{brd_level} < 0 || $_[0]->{brd_cur} < $_[0]->{brd_level}
 113 }
 114
 115 sub compile {
 116  my @args = @_;
 117
 118  my $bd = B::Deparse->new();
 119  my ($deparse, $level) = _parse_args(@args);
 120
 121  my $compiler = $bd->coderef2text(B::Deparse::compile(@$deparse));
 122  $compiler =~ s/
 123   ['"]? B::Deparse ['"]? \s* -> \s* (new) \s* \( ([^\)]*) \)
 124  /B::RecDeparse->$1(deparse => [ $2 ], level => $level)/gx;
 125  $compiler = eval 'sub ' . $compiler;
 126  die if $@;
 127
 128  return $compiler;
 129 }
 130
 131 sub init {
 132  my $self = shift;
 133
 134  $self->{brd_cur}  = 0;
 135  $self->{brd_sub}  = 0;
 136  $self->{brd_seen} = { };
 137
 138  $self->SUPER::init(@_);
 139 }
 140
 141 my $key = $; . __PACKAGE__ . $;;
 142
 143 if (FOOL_SINGLE_DELIM) {
 144  my $oldsd = *B::Deparse::single_delim{CODE};
 145
 146  no warnings 'redefine';
 147  *B::Deparse::single_delim = sub {
 148   my $body = $_[2];
 149
 150   if ((caller 1)[0] eq __PACKAGE__ and $body =~ s/^$key//) {
 151    return $body;
 152   } else {
 153    $oldsd->(@_);
 154   }
 155  }
 156 }
 157
 158 sub deparse_sub {
 159  my $self = shift;
 160  my $cv   = $_[0];
 161
 162  my $name;
 163  unless ($cv->CvFLAGS & B::CVf_ANON()) {
 164   $name = $cv->GV->SAFENAME;
 165  }
 166
 167  local $self->{brd_seen}->{$name} = 1 if defined $name;
 168  return $self->SUPER::deparse_sub(@_);
 169 }
 170
 171 sub pp_entersub {
 172  my $self = shift;
 173
 174  my $body = do {
 175   local $self->{brd_sub} = 1;
 176   $self->SUPER::pp_entersub(@_);
 177  };
 178
 179  $body =~ s/^&\s*(\w)/$1/ if $self->_recurse;
 180
 181  return $body;
 182 }
 183
 184 sub pp_refgen {
 185  my $self = shift;
 186
 187  return do {
 188   local $self->{brd_sub} = 0;
 189   $self->SUPER::pp_refgen(@_);
 190  }
 191 }
 192
 193 sub pp_srefgen {
 194  my $self = shift;
 195
 196  return do {
 197   local $self->{brd_sub} = 0;
 198   $self->SUPER::pp_srefgen(@_);
 199  }
 200 }
 201
 202 sub pp_gv {
 203  my $self = shift;
 204
 205  my $gv   = $self->gv_or_padgv($_[0]);
 206  my $cv   = $gv->FLAGS & B::SVf_ROK ? $gv->RV : undef;
 207  my $name = $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME;
 208  $cv    ||= $gv->CV;
 209  my $seen = $self->{brd_seen};
 210
 211  my $body;
 212  if (!$self->{brd_sub} or !$self->_recurse or $seen->{$name} or !$$cv
 213      or !$cv->isa('B::CV') or $cv->ROOT->isa('B::NULL')) {
 214   $body = $self->SUPER::pp_gv(@_);
 215  } else {
 216   $body = do {
 217    local @{$self}{qw<brd_sub brd_cur>} = (0, $self->{brd_cur} + 1);
 218    local $seen->{$name} = 1;
 219    'sub ' . $self->indent($self->deparse_sub($cv));
 220   };
 221
 222   if (FOOL_SINGLE_DELIM) {
 223    $body = $key . $body;
 224   } else {
 225    $body .= '->';
 226   }
 227  }
 228
 229  return $body;
 230 }
 231
 232 =pod
 233
 234 The following functions and methods from L<B::Deparse> are reimplemented by this module :
 235
 236 =over 4
 237
 238 =item *
 239
 240 C<compile>
 241
 242 =item *
 243
 244 C<init>
 245
 246 =item *
 247
 248 C<deparse_sub>
 249
 250 =item *
 251
 252 C<pp_entersub>
 253
 254 =item *
 255
 256 C<pp_refgen>
 257
 258 =item *
 259
 260 C<pp_srefgen>
 261
 262 =item *
 263
 264 C<pp_gv>
 265
 266 =back
 267
 268 Otherwise, L<B::RecDeparse> inherits all methods from L<B::Deparse>.
 269
 270 =head1 EXPORT
 271
 272 An object-oriented module shouldn't export any function, and so does this one.
 273
 274 =head1 DEPENDENCIES
 275
 276 L<perl> 5.8.1.
 277
 278 L<Carp> (standard since perl 5), L<Config> (since perl 5.00307) and L<B::Deparse> (since perl 5.005).
 279
 280 =head1 AUTHOR
 281
 282 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 283
 284 You can contact me by mail or on C<irc.perl.org> (vincent).
 285
 286 =head1 BUGS
 287
 288 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>.
 289 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 290
 291 =head1 SUPPORT
 292
 293 You can find documentation for this module with the perldoc command.
 294
 295     perldoc B::RecDeparse
 296
 297 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/B-RecDeparse>.
 298
 299 =head1 COPYRIGHT & LICENSE
 300
 301 Copyright 2008,2009,2010,2011,2013,2014,2015 Vincent Pit, all rights reserved.
 302
 303 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 304
 305 =cut
 306
 307 1; # End of B::RecDeparse