You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
193 lines
5.3 KiB
193 lines
5.3 KiB
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 |
|
|
|
|