lib/B/RecDeparse.pm

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