lib/B/RecDeparse.pm

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