patch to provide more informative names for evals and anonymous

subroutines (from Ilya Zakharevich)

p4raw-id: //depot/perl@4975

3 files changed, 72 insertions, 14 deletions

diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm
index 33f679363a..94b6aa6e78 100644
--- a/lib/Dumpvalue.pm
+++ b/lib/Dumpvalue.pm
@@ -347,16 +347,30 @@ sub dumpglob {
   }
 }
 
+sub CvGV_name {
+  my $self = shift;
+  my $in = shift;
+  return if $self->{skipCvGV};	# Backdoor to avoid problems if XS broken...
+  $in = \&$in;			# Hard reference...
+  eval {require Devel::Peek; 1} or return;
+  my $gv = Devel::Peek::CvGV($in) or return;
+  *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
 sub dumpsub {
   my $self = shift;
   my ($off,$sub) = @_;
+  my $ini = $sub;
+  my $s;
   $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
-  my $subref = \&$sub;
-  my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
-    || ($self->{subdump} && ($sub = $self->findsubs("$subref"))
-	&& $DB::sub{$sub});
+  my $subref = defined $1 ? \&$sub : \&$ini;
+  my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+    || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
+    || ($self->{subdump} && ($s = $self->findsubs("$subref"))
+	&& $DB::sub{$s});
+  $s = $sub unless defined $s;
   $place = '???' unless defined $place;
-  print( (' ' x $off) .  "&$sub in $place\n" );
+  print( (' ' x $off) .  "&$s in $place\n" );
 }
 
 sub findsubs {
diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl
index f473c45bd3..c72781801b 100644
--- a/lib/dumpvar.pl
+++ b/lib/dumpvar.pl
@@ -312,14 +312,27 @@ sub dumpglob {
     }
 }
 
+sub CvGV_name_or_bust {
+  my $in = shift;
+  return if $skipCvGV;		# Backdoor to avoid problems if XS broken...
+  $in = \&$in;			# Hard reference...
+  eval {require Devel::Peek; 1} or return;
+  my $gv = Devel::Peek::CvGV($in) or return;
+  *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
 sub dumpsub {
     my ($off,$sub) = @_;
+    my $ini = $sub;
+    my $s;
     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
-    my $subref = \&$sub;
-    my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
-      || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
+    my $subref = defined $1 ? \&$sub : \&$ini;
+    my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+      || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
+      || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
     $place = '???' unless defined $place;
-    print( (' ' x $off) .  "&$sub in $place\n" );
+    $s = $sub unless defined $s;
+    print( (' ' x $off) .  "&$s in $place\n" );
 }
 
 sub findsubs {
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index aff5c687e7..de75bd7d86 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2,7 +2,7 @@ package DB;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 
-$VERSION = 1.04041;
+$VERSION = 1.05;
 $header = "perl5db.pl version $VERSION";
 
 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
@@ -597,13 +597,21 @@ EOP
 			  }
 		      };
 		    $cmd =~ s/^l\s+-\s*$/-/;
-		    $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
+		    $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
+			$evalarg = $2;
+			my ($s) = &eval;
+			print($OUT "Error: $@\n"), next CMD if $@;
+			$s = CvGV_name($s);
+			print($OUT "Interpreted as: $1 $s\n");
+			$cmd = "$1 $s";
+		    };
+		    $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
 			$subname = $1;
 			$subname =~ s/\'/::/;
 			$subname = $package."::".$subname 
 			  unless $subname =~ /::/;
 			$subname = "main".$subname if substr($subname,0,2) eq "::";
-			@pieces = split(/:/,find_sub($subname));
+			@pieces = split(/:/,find_sub($subname) || $sub{$subname});
 			$subrange = pop @pieces;
 			$file = join(':', @pieces);
 			if ($file ne $filename) {
@@ -784,7 +792,7 @@ EOP
 			$postponed{$subname} = $break 
 			  ? "break +0 if $cond" : "compile";
 			next CMD; };
-		    $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
+		    $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
 			$subname = $1;
 			$cond = $2 || '1';
 			$subname =~ s/\'/::/;
@@ -1813,6 +1821,7 @@ B<l> I<min>B<+>I<incr>	List I<incr>+1 lines starting at I<min>.
 B<l> I<min>B<->I<max>	List lines I<min> through I<max>.
 B<l> I<line>		List single I<line>.
 B<l> I<subname>	List first window of lines from subroutine.
+B<l> I<$var>	List first window of lines from subroutine referenced by I<$var>.
 B<l>		List next window of lines.
 B<->		List previous window of lines.
 B<w> [I<line>]	List window around I<line>.
@@ -1835,6 +1844,7 @@ B<b> [I<line>] [I<condition>]
 		I<condition> breaks if it evaluates to true, defaults to '1'.
 B<b> I<subname> [I<condition>]
 		Set breakpoint at first line of subroutine.
+B<b> I<$var>	Set breakpoint at first line of subroutine referenced by I<$var>.
 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
 B<b> B<postpone> I<subname> [I<condition>]
 		Set breakpoint at first line of subroutine after 
@@ -2063,10 +2073,31 @@ sub signalLevel {
   $signalLevel;
 }
 
+sub CvGV_name {
+  my $in = shift;
+  my $name = CvGV_name_or_bust($in);
+  defined $name ? $name : $in;
+}
+
+sub CvGV_name_or_bust {
+  my $in = shift;
+  return if $skipCvGV;		# Backdoor to avoid problems if XS broken...
+  $in = \&$in;			# Hard reference...
+  eval {require Devel::Peek; 1} or return;
+  my $gv = Devel::Peek::CvGV($in) or return;
+  *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
 sub find_sub {
   my $subr = shift;
-  return unless defined &$subr;
   $sub{$subr} or do {
+    return unless defined &$subr;
+    my $name = CvGV_name_or_bust($subr);
+    my $data;
+    $data = $sub{$name} if defined $name;
+    return $data if defined $data;
+
+    # Old stupid way...
     $subr = \&$subr;		# Hard reference
     my $s;
     for (keys %sub) {