(perl #124203) fix a similar problem with DB::lsub
authorTony Cook <tony@develop-help.com>
Thu, 28 Feb 2019 00:53:19 +0000 (11:53 +1100)
committerTony Cook <tony@develop-help.com>
Thu, 7 Mar 2019 23:36:13 +0000 (10:36 +1100)
MANIFEST
lib/perl5db.pl
lib/perl5db.t
lib/perl5db/t/rt-124203b [new file with mode: 0644]

index 09eaa75..4cf40a8 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4654,6 +4654,7 @@ lib/perl5db/t/rt-104168           Tests for the Perl debugger
 lib/perl5db/t/rt-120174                Tests for the Perl debugger
 lib/perl5db/t/rt-121509-restart-after-chdir            Tests for the Perl debugger
 lib/perl5db/t/rt-124203                Test threads in the Perl debugger
+lib/perl5db/t/rt-124203b       Test threads in the Perl debugger
 lib/perl5db/t/rt-61222         Tests for the Perl debugger
 lib/perl5db/t/rt-66110         Tests for the Perl debugger
 lib/perl5db/t/source-cmd-test.perldb           Tests for the Perl debugger
index be2367c..e8a29da 100644 (file)
@@ -4281,25 +4281,6 @@ sub DB::sub {
 
 sub lsub : lvalue {
 
-    no strict 'refs';
-
-    # lock ourselves under threads
-    lock($DBGR);
-
-    # 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).
-    my ( $al, $ret, @ret ) = "";
-    if ($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' ) {
-        $al = " for $$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
@@ -4317,12 +4298,32 @@ sub lsub : lvalue {
     # stack for us.
     local $single = $single & 1;
 
-    # If we've gotten really deeply recursed, turn on the flag that will
-    # make us stop with the 'deep recursion' message.
-    $single |= 4 if $stack_depth == $deep;
+    no strict 'refs';
+    {
+        # lock ourselves under threads
+        lock($DBGR);
+
+        # 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).
+        my ( $al, $ret, @ret ) = "";
+        if ($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' ) {
+            $al = " for $$sub";
+        }
 
-    # If frame messages are on ...
-    _print_frame_message($al);
+        # If we've gotten really deeply recursed, turn on the flag that will
+        # make us stop with the 'deep recursion' message.
+        $single |= 4 if $stack_depth == $deep;
+
+        # If frame messages are on ...
+        _print_frame_message($al);
+    }
 
     # call the original lvalue sub.
     &$sub;
index cbfe077..450f4d0 100644 (file)
@@ -2917,6 +2917,21 @@ SKIP:
     $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran");
 
     $wrapper->output_like(qr/Finished/, "[perl #124203] debugger didn't deadlock");
+
+    $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                'c',
+                'q',
+            ],
+            prog => '../lib/perl5db/t/rt-124203b',
+        }
+    );
+
+    $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran (lvalue)");
+
+    $wrapper->output_like(qr/Finished One/, "[perl #124203] debugger didn't deadlock (lvalue)");
 }
 
 done_testing();
diff --git a/lib/perl5db/t/rt-124203b b/lib/perl5db/t/rt-124203b
new file mode 100644 (file)
index 0000000..a599621
--- /dev/null
@@ -0,0 +1,13 @@
+use threads;
+print "PID $$\n";
+my $x;
+sub sub1 {
+  print("In the thread\n");
+}
+sub foo:lvalue {
+  my $thr = threads->create(\&sub1);
+  $thr->join;
+  $x;
+}
+foo() = "One";
+print "Finished $x\n";