From a71385d4b292a5f627c989a5450a7ec2ce51ecee Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 29 Jul 2025 22:37:13 +0200 Subject: [PATCH 1/3] perl5db: use a lexical copy of $DB::sub inside DB::sub When perl calls DB::sub in the debugger, it sets $DB::sub to the sub being called. If we trigger any other subs to get called somewhere inside DB::sub, this could cause DB::sub to be called again, overwriting the global. Perl won't call DB::sub for any sub calls within the DB namespace, but we could inadvertently trigger this via a sub override or magic, like overloads. Create a copy of the global value in a lexical to use inside the sub, to avoid it ever getting overwritten. --- lib/perl5db.pl | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 5a97174feb10..7216b03e64eb 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -4434,6 +4434,11 @@ sub _print_frame_message { sub DB::sub { my ( $al, $ret, @ret ) = ""; + # keep a lexical copy, rather than relying on the global. the global + # variable could be overwritten if something inside this sub triggers + # another sub call, running DB::sub again. overloads for example. + my $sub = $DB::sub; + # We stack the stack pointer and then increment it to protect us # from a situation that might unwind a whole bunch of call frames # at once. Localizing the stack pointer means that it will automatically @@ -4568,6 +4573,7 @@ sub DB::sub { } ## end sub _sub sub lsub : lvalue { + my $sub = $DB::sub; # We stack the stack pointer and then increment it to protect us # from a situation that might unwind a whole bunch of call frames From 02494a5da6d05d6af3d1ddf5a39c7158a81eb1a9 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 29 Jul 2025 22:43:52 +0200 Subject: [PATCH 2/3] perl5db: only check sub names for non-references DB::sub can be called by perl giving it either a name (if it can be determined) or a code ref. There is special handling for AUTOLOAD subs and threads::new. This could only be happen when given the name of the sub, so there is no need to do these checks if given a reference. Additionally, a reference could be an object, which could have overloads. Those overloads could fail or otherwise complicate the normal operation of DB::sub. Add a ref check to the sub given to DB::sub to avoid these issues. --- lib/perl5db.pl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 7216b03e64eb..55c82a7a40d9 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -4460,13 +4460,13 @@ sub DB::sub { # Whether or not the autoloader was running, a scalar to put the # sub's return value in (if needed), and an array to put the sub's # return value in (if needed). - if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { + if (!ref $sub && $sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { print "creating new thread\n"; } # If the last ten characters are '::AUTOLOAD', note we've traced # into AUTOLOAD for $sub. - if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { + if ( !ref $sub && length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { no strict 'refs'; $al = " for $$sub" if defined $$sub; } @@ -4601,13 +4601,13 @@ sub lsub : lvalue { # sub's return value in (if needed), and an array to put the sub's # return value in (if needed). my ( $al, $ret, @ret ) = ""; - if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { + if ( !ref $sub && $sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { print "creating new thread\n"; } # If the last ten characters are C'::AUTOLOAD', note we've traced # into AUTOLOAD for $sub. - if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { + if ( !ref $sub && length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { $al = " for $$sub"; } From a2b1ab5d3784e8f9c2765100ad6e8d830c9b1c40 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Tue, 29 Jul 2025 22:37:05 +0200 Subject: [PATCH 3/3] bump perl5db VERSION --- lib/perl5db.pl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 55c82a7a40d9..90edb868964a 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -532,7 +532,7 @@ BEGIN use vars qw($VERSION $header); # bump to X.XX in blead, only use X.XX_XX in maint -$VERSION = '1.82'; +$VERSION = '1.83'; $header = "perl5db.pl version $VERSION";