From b334474a337421c6643b872388245fb2c11bf995 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 30 Mar 2020 16:32:46 +1100
Subject: [PATCH] fix C<i $obj> where $obj is a lexical
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

the DB::eval function depends on the special behaviour of eval ""
within the DB package, which evaluates the string within the context
of the first non-DB sub or eval scope, working up the call stack.

The debugger refactor moved handling for the 'i' command from the
DB package to the DB::Obj package, so the eval in DB::eval was
working in the context of the DB::Obj::cmd_i function, not in the
calling scope.

Fixed by moving the handling for the i command back to DB.

Fixes #17661.

Signed-off-by: Petr Písař <ppisar@redhat.com>
---
 MANIFEST               |  1 +
 lib/perl5db.pl         | 65 +++++++++++++++++++++---------------------
 lib/perl5db.t          | 20 +++++++++++++
 lib/perl5db/t/gh-17661 | 14 +++++++++
 4 files changed, 68 insertions(+), 32 deletions(-)
 create mode 100644 lib/perl5db/t/gh-17661

diff --git a/MANIFEST b/MANIFEST
index 8c71995174..96af3618bd 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4808,6 +4808,7 @@ lib/perl5db/t/eval-line-bug	Tests for the Perl debugger
 lib/perl5db/t/fact		Tests for the Perl debugger
 lib/perl5db/t/filename-line-breakpoint		Tests for the Perl debugger
 lib/perl5db/t/gh-17660		Tests for the Perl debugger
+lib/perl5db/t/gh-17661		Tests for the Perl debugger
 lib/perl5db/t/load-modules	Tests for the Perl debugger
 lib/perl5db/t/lsub-n		Test script used by perl5db.t
 lib/perl5db/t/lvalue-bug	Tests for the Perl debugger
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 96e56d559f..b647d24fb8 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2512,6 +2512,37 @@ EOP
     return;
 }
 
+=head3 C<_DB__handle_i_command> - inheritance display
+
+Display the (nested) parentage of the module or object given.
+
+=cut
+
+sub _DB__handle_i_command {
+    my $self = shift;
+
+    my $line = $self->cmd_args;
+    require mro;
+    foreach my $isa ( split( /\s+/, $line ) ) {
+        $evalarg = "$isa";
+        # The &-call is here to ascertain the mutability of @_.
+        ($isa) = &DB::eval;
+        no strict 'refs';
+        print join(
+            ', ',
+            map {
+                "$_"
+                  . (
+                    defined( ${"$_\::VERSION"} )
+                    ? ' ' . ${"$_\::VERSION"}
+                    : undef )
+              } @{mro::get_linear_isa(ref($isa) || $isa)}
+        );
+        print "\n";
+    }
+    next CMD;
+}
+
 # 't' is type.
 # 'm' is method.
 # 'v' is the value (i.e: method name or subroutine ref).
@@ -2531,6 +2562,7 @@ BEGIN
     'W' => { t => 'm', v => '_handle_W_command', },
     'c' => { t => 's', v => \&_DB__handle_c_command, },
     'f' => { t => 's', v => \&_DB__handle_f_command, },
+    'i' => { t => 's', v => \&_DB__handle_i_command, },
     'm' => { t => 's', v => \&_DB__handle_m_command, },
     'n' => { t => 'm', v => '_handle_n_command', },
     'p' => { t => 'm', v => '_handle_p_command', },
@@ -2551,7 +2583,7 @@ BEGIN
         { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
         } qw(R rerun)),
     (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
-        qw(a A b B e E h i l L M o O v w W)),
+        qw(a A b B e E h l L M o O v w W)),
 );
 };
 
@@ -5468,37 +5500,6 @@ sub cmd_h {
     }
 } ## end sub cmd_h
 
-=head3 C<cmd_i> - inheritance display
-
-Display the (nested) parentage of the module or object given.
-
-=cut
-
-sub cmd_i {
-    my $cmd  = shift;
-    my $line = shift;
-
-    require mro;
-
-    foreach my $isa ( split( /\s+/, $line ) ) {
-        $evalarg = $isa;
-        # The &-call is here to ascertain the mutability of @_.
-        ($isa) = &DB::eval;
-        no strict 'refs';
-        print join(
-            ', ',
-            map {
-                "$_"
-                  . (
-                    defined( ${"$_\::VERSION"} )
-                    ? ' ' . ${"$_\::VERSION"}
-                    : undef )
-              } @{mro::get_linear_isa(ref($isa) || $isa)}
-        );
-        print "\n";
-    }
-} ## end sub cmd_i
-
 =head3 C<cmd_l> - list lines (command)
 
 Most of the command is taken up with transforming all the different line
diff --git a/lib/perl5db.t b/lib/perl5db.t
index 913a301d98..ffa659a215 100644
--- a/lib/perl5db.t
+++ b/lib/perl5db.t
@@ -2946,6 +2946,26 @@ SKIP:
        );
 }
 
+{
+    # gh #17661
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'c',
+                'i $obj',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/gh-17661',
+        }
+    );
+
+    $wrapper->output_like(
+        qr/C5, C1, C2, C3, C4/,
+        q/check for reasonable result/,
+       );
+}
+
 SKIP:
 {
     $Config{usethreads}
diff --git a/lib/perl5db/t/gh-17661 b/lib/perl5db/t/gh-17661
new file mode 100644
index 0000000000..0d85977b35
--- /dev/null
+++ b/lib/perl5db/t/gh-17661
@@ -0,0 +1,14 @@
+use v5.10.0;
+
+{ package C1; sub c1 { } our @ISA = qw(C2) }
+{ package C2; sub c2 { } our @ISA = qw(C3) }
+{ package C3; sub c3 { } our @ISA = qw(  ) }
+{ package C4; sub c4 { } our @ISA = qw(  ) }
+{ package C5; sub c5 { } our @ISA = qw(C1 C4) }
+
+my $obj = bless {}, 'C5';
+$main::global = bless {}, 'C5';
+
+$DB::single = 1;
+
+say "Done.";
-- 
2.25.4