perl5db.pl: b subname and c subname break on first executable line

This currently doesn't try to handle "b postpone subname" since that
internally has an offset function that doesn't really work
with this implementation.

This is a partial fix for #799

Author: tonycoz

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.80';
+$VERSION = '1.81';
 
 $header = "perl5db.pl version $VERSION";
 
@@ -2033,19 +2033,12 @@ sub _DB__handle_c_command {
             # Qualify it to the current package unless it's
             # already qualified.
             $subname = $package . "::" . $subname
-            unless $subname =~ /::/;
+              unless $subname =~ /::/;
 
-            # find_sub will return "file:line_number" corresponding
-            # to where the subroutine is defined; we call find_sub,
-            # break up the return value, and assign it in one
-            # operation.
-            ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
-
-            # Force the line number to be numeric.
-            $i = $i + 0;
+            my ($file, $line) = eval { subroutine_first_breakable_line($subname) };
 
             # If we got a line number, we found the sub.
-            if ($i) {
+            if ($line) {
 
                 # Switch all the debugger's internals around so
                 # we're actually working with that file.
@@ -2055,22 +2048,13 @@ sub _DB__handle_c_command {
                 # Mark that there's a breakpoint in this file.
                 $had_breakpoints{$filename} |= 1;
 
-                # Scan forward to the first executable line
-                # after the 'sub whatever' line.
-                $max = $#dbline;
-                my $_line_num = $i;
-                while ($dbline[$_line_num] == 0 && $_line_num< $max)
-                {
-                    $_line_num++;
-                }
-                $i = $_line_num;
-            } ## end if ($i)
-
-            # We didn't find a sub by that name.
+                $i = $line;
+            } ## end if ($line)
             else {
-                print $OUT "Subroutine $subname not found.\n";
+                print $OUT $@;
                 next CMD;
             }
+
         } ## end if ($subname =~ /\D/)
 
         # At this point, either the subname was all digits (an
@@ -5389,6 +5373,65 @@ sub subroutine_filename_lines {
     return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
 } ## end sub subroutine_filename_lines
 
+=head2 subroutine_first_breakable_line(subname)
+
+Attempts to find the filename and first breakable line by execution
+order for the subroutine specified by C<subname>.
+
+If this isn't possible, such as when debugging with C<miniperl>, finds
+the first breakable line by line order for the subroutine specified by
+C<subname>.
+
+Return the filename and breakable line number:
+
+  my ($file, $line) = subroutine_first_breakable_line(subname);
+
+Throws an error message if C<subname> cannot be found or is not
+breakable.
+
+=cut
+
+sub _first_breakable_via_B {
+    my ( $subname ) = @_;
+
+    my $cv = do {
+        no strict "refs";
+        *$subname{CODE};
+    };
+    ref $cv eq "CODE"
+      or return;
+
+    eval { require B; 1 }
+      or return;
+
+    my $bcv = B::svref_2object($cv);
+
+    $bcv->XSUB
+      and die "Cannot break on XSUB $subname\n";
+
+    for (my $op = $bcv->START; !$op->isa("B::NULL"); $op = $op->next) {
+        $op->name eq "dbstate"
+          and return ( $op->file, $op->line, $op->line );
+    }
+
+    return;
+}
+
+sub subroutine_first_breakable_line {
+    my ( $subname ) = @_;
+
+    my ($file, $line) = _first_breakable_via_B($subname);
+    unless ($file) {
+        # at the very least this allows miniperl to debug
+        ( $file, my ($s, $e) ) = subroutine_filename_lines($subname)
+          or die "Subroutine $subname not found.\n";
+
+        $line = breakable_line_in_filename($file, $s, $e);
+    }
+
+    return ($file, $line );
+}
+
 =head3 break_subroutine(subname) (API)
 
 Places a break on the first line possible in the specified subroutine. Uses
@@ -5401,16 +5444,14 @@ sub break_subroutine {
     my $subname = shift;
 
     # Get filename, start, and end.
-    my ( $file, $s, $e ) = subroutine_filename_lines($subname)
-      or die "Subroutine $subname not found.\n";
-
+    my ( $file, $line ) = subroutine_first_breakable_line($subname);
 
     # Null condition changes to '1' (always true).
     my $cond = @_ ? shift(@_) : 1;
 
     # Put a break the first place possible in the range of lines
     # that make up this subroutine.
-    break_on_filename_line_range( $file, $s, $e, $cond );
+    break_on_filename_line_range( $file, $line, $line, $cond );
 
     return;
 } ## end sub break_subroutine

lib/perl5db.t

@@ -3491,6 +3491,80 @@ EOS
     $wrapper->output_like(qr/\bOK\b/, "check the line is IOK");
 }
 
+{
+    # https://github.com/Perl/perl5/issues/799
+    my $prog = <<'EOS';
+sub problem {
+    $SIG{__DIE__} = sub {
+        die "<b problem> will set a break point here.\n";
+    };    # The break point _should_ be set here.
+    warn "This line will run even if you enter <c problem>.\n";
+}
+&problem;
+EOS
+
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                "b problem",
+                "c",
+                "q"
+            ],
+            prog => \$prog
+        }
+    );
+    $wrapper->contents_like(qr/The break point _should_/, "break at right place (b)");
+    $wrapper->output_unlike(qr/This line will run even if you enter <c problem>\./,
+                            "didn't run the wrong code (b)");
+
+    $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                "c problem",
+                "q"
+            ],
+            prog => \$prog
+        }
+    );
+    $wrapper->contents_like(qr/The break point _should_/, "break at right place (c)");
+    $wrapper->output_unlike(qr/This line will run even if you enter <c problem>\./,
+                            "didn't run the wrong code (c)");
+
+    $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                "c unknown",
+                "q"
+            ],
+            prog => \$prog
+        }
+    );
+    $wrapper->contents_like(qr/Subroutine main::unknown not found/, "fail to continue to unknown");
+    $wrapper->contents_unlike(qr/DB::subroutine_first_breakable_line/,
+                              "no backtrace for the error message");
+
+}
+
+{
+    my $wrapper = DebugWrap->new(
+        {
+            cmds =>
+            [
+                "b B::svref_2object",
+                "q"
+            ],
+            prog => \<<'EOS'
+use B;
+print "Hello\n";
+EOS
+        }
+    );
+    $wrapper->contents_like(qr/Cannot break on XSUB B::svref_2object/, "can't break on XSUB");
+}
+
 done_testing();
 
 END {