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 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