]> git.vpit.fr Git - perl/modules/B-RecDeparse.git/blob - lib/B/RecDeparse.pm
Teach this module about perl 5.21.4
[perl/modules/B-RecDeparse.git] / 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.08
21
22 =cut
23
24 our $VERSION = '0.08';
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_gv {
194  my $self = shift;
195
196  my $gv   = $self->gv_or_padgv($_[0]);
197  my $cv   = $gv->FLAGS & B::SVf_ROK ? $gv->RV : undef;
198  my $name = $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME;
199  $cv    ||= $gv->CV;
200  my $seen = $self->{brd_seen};
201
202  my $body;
203  if (!$self->{brd_sub} or !$self->_recurse or $seen->{$name} or !$$cv
204      or !$cv->isa('B::CV') or $cv->ROOT->isa('B::NULL')) {
205   $body = $self->SUPER::pp_gv(@_);
206  } else {
207   $body = do {
208    local @{$self}{qw<brd_sub brd_cur>} = (0, $self->{brd_cur} + 1);
209    local $seen->{$name} = 1;
210    'sub ' . $self->indent($self->deparse_sub($cv));
211   };
212
213   if (FOOL_SINGLE_DELIM) {
214    $body = $key . $body;
215   } else {
216    $body .= '->';
217   }
218  }
219
220  return $body;
221 }
222
223 =pod
224
225 The following functions and methods from L<B::Deparse> are reimplemented by this module :
226
227 =over 4
228
229 =item *
230
231 C<compile>
232
233 =item *
234
235 C<init>
236
237 =item *
238
239 C<deparse_sub>
240
241 =item *
242
243 C<pp_entersub>
244
245 =item *
246
247 C<pp_refgen>
248
249 =item *
250
251 C<pp_gv>
252
253 =back
254
255 Otherwise, L<B::RecDeparse> inherits all methods from L<B::Deparse>.
256
257 =head1 EXPORT
258
259 An object-oriented module shouldn't export any function, and so does this one.
260
261 =head1 DEPENDENCIES
262
263 L<perl> 5.8.1.
264
265 L<Carp> (standard since perl 5), L<Config> (since perl 5.00307) and L<B::Deparse> (since perl 5.005).
266
267 =head1 AUTHOR
268
269 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
270
271 You can contact me by mail or on C<irc.perl.org> (vincent).
272
273 =head1 BUGS
274
275 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>.
276 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
277
278 =head1 SUPPORT
279
280 You can find documentation for this module with the perldoc command.
281
282     perldoc B::RecDeparse
283
284 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/B-RecDeparse>.
285
286 =head1 COPYRIGHT & LICENSE
287
288 Copyright 2008,2009,2010,2011,2013 Vincent Pit, all rights reserved.
289
290 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
291
292 =cut
293
294 1; # End of B::RecDeparse