From: Vincent Pit <vince@profvince.com>
Date: Sun, 25 Jul 2010 20:41:03 +0000 (+0200)
Subject: Don't deparse recursively into recursive subroutines
X-Git-Tag: rt63842~7
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=a9236ccc57c9b10c1bd1a28c0138be223461efe3;p=perl%2Fmodules%2FB-RecDeparse.git

Don't deparse recursively into recursive subroutines
---

diff --git a/MANIFEST b/MANIFEST
index b1fddd7..a2af981 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -13,6 +13,7 @@ t/12-level.t
 t/13-prototypes.t
 t/14-refs.t
 t/15-pkg.t
+t/16-recurse.t
 t/20-compile.t
 t/21-single_delim.t
 t/91-pod.t
diff --git a/lib/B/RecDeparse.pm b/lib/B/RecDeparse.pm
index 4f7b636..c5c5fa9 100644
--- a/lib/B/RecDeparse.pm
+++ b/lib/B/RecDeparse.pm
@@ -5,6 +5,8 @@ use 5.008;
 use strict;
 use warnings;
 
+use B ();
+
 use Config;
 
 use base qw/B::Deparse/;
@@ -114,8 +116,9 @@ sub compile {
 sub init {
  my $self = shift;
 
- $self->{brd_cur} = 0;
- $self->{brd_sub} = 0;
+ $self->{brd_cur}  = 0;
+ $self->{brd_sub}  = 0;
+ $self->{brd_seen} = { };
 
  $self->SUPER::init(@_);
 }
@@ -137,6 +140,19 @@ if (FOOL_SINGLE_DELIM) {
  }
 }
 
+sub deparse_sub {
+ my $self = shift;
+ my $cv   = $_[0];
+
+ my $name;
+ unless ($cv->CvFLAGS & B::CVf_ANON()) {
+  $name = $cv->GV->SAFENAME;
+ }
+
+ local $self->{brd_seen}->{$name} = 1 if defined $name;
+ return $self->SUPER::deparse_sub(@_);
+}
+
 sub pp_entersub {
  my $self = shift;
 
@@ -162,14 +178,17 @@ sub pp_refgen {
 sub pp_gv {
  my $self = shift;
 
+ my $gv   = $self->gv_or_padgv($_[0]);
+ my $name = $gv->NAME;
+ my $seen = $self->{brd_seen};
+
  my $body;
- if ($self->{brd_sub} <= 0 || !$self->_recurse) {
+ if ($self->{brd_sub} <= 0 || !$self->_recurse || $seen->{$name}) {
   $body = $self->SUPER::pp_gv(@_);
  } else {
-  my $gv = $self->gv_or_padgv($_[0]);
-
   $body = do {
    local @{$self}{qw/brd_sub brd_cur/} = (0, $self->{brd_cur} + 1);
+   local $seen->{$name} = 1;
    'sub ' . $self->indent($self->deparse_sub($gv->CV));
   };
 
@@ -187,6 +206,8 @@ sub pp_gv {
 
 =head2 C<init>
 
+=head2 C<deparse_sub>
+
 =head2 C<pp_entersub>
 
 =head2 C<pp_refgen>
diff --git a/t/16-recurse.t b/t/16-recurse.t
new file mode 100644
index 0000000..e0f7c03
--- /dev/null
+++ b/t/16-recurse.t
@@ -0,0 +1,82 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3 * 2 * 5;
+
+use B::RecDeparse;
+
+my @brds = map [ B::RecDeparse->new(level => $_), $_ ], 0, 1, 2, 5, -1;
+
+sub fact {
+ my $n = shift;
+
+ if ($n > 0) {
+  $n * fact($n - 1);
+ } else {
+  return 0;
+ }
+}
+
+my $exp_fact = <<'EXP';
+if ($n > 0) {
+  $n * fact($n - 1);
+}
+else {
+  return 0;
+}
+EXP
+
+sub foo { bar($_[0] + 1) }
+
+sub bar { foo($_[0] - 1) }
+
+my $exp_foo0 = <<'EXP';
+bar($_[0] + 1);
+EXP
+
+my $exp_foo1 = <<'EXP';
+sub {
+  foo($_[0] - 1);
+}->($_[0] + 1);
+EXP
+
+my $exp_bar0 = <<'EXP';
+foo($_[0] - 1);
+EXP
+
+my $exp_bar1 = <<'EXP';
+sub {
+  bar($_[0] + 1);
+}->($_[0] - 1);
+EXP
+
+my @tests = (
+ [ \&fact, [ $exp_fact            ], 'fact' ],
+ [ \&foo,  [ $exp_foo0, $exp_foo1 ], 'foo'  ],
+ [ \&bar,  [ $exp_bar0, $exp_bar1 ], 'bar'  ],
+);
+
+for (@tests) {
+ my ($code, $exps, $desc) = @$_;
+
+ s/^\s*//mg, s/\s*$//mg, $_ = qr/\Q$_\E/ for @$exps;
+
+ for my $i (0 .. $#brds) {
+  my ($brd, $level) = @{$brds[$i]};
+
+  my $exp = $exps->[$i];
+  $exp    = $exps->[-1] unless defined $exp;
+
+  my $body = eval {
+   $brd->coderef2text($code);
+  };
+  is $@, '', "deparsing $desc at level $level doesn't croak";
+
+  s/^\s*//mg, s/\s*$//mg for $body;
+
+  like $body, qr/^\{ [^{}]* $exp [^{}]* \}$/x,
+                                    "deparsing $desc at level $level correctly";
+ }
+}