Add package name to location line like perl5db does. Line.pm no longe…

…r require package name in "info line" if it is the current package.

lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Line.pm

@@ -24,23 +24,28 @@ sub run($$)
     my $proc      = $self->{proc};
     my $frame     = $proc->{frame};
     my $filename  = $proc->filename();
-    my $line;
-    my $end_line  = undef;
+    my ($line, $first_arg, $end_line);
 
     my $arg_count = scalar @args;
     if ($arg_count == 0) {
 	$line = $frame->{line};
     } else {
-	if ($args[0] =~ /\d+/) {
-	    $line = $args[0];
+	$first_arg = $args[0];
+	if ($first_arg =~ /\d+/) {
+	    $line = $first_arg;
 	} else {
-	    my @matches = $proc->{dbgr}->subs($args[0]);
+	    my @matches = $proc->{dbgr}->subs($first_arg);
+	    unless (scalar(@matches)) {
+		# Try with current package name
+		$first_arg = $proc->{frame}{pkg} . '::' . $first_arg;
+		@matches = $proc->{dbgr}->subs($first_arg);
+	    }
 	    if (scalar(@matches) == 1) {
 		$filename = $matches[0][0];
 		$line     = $matches[0][1];
 		$end_line = $matches[0][2];
 	    } else {
-		$proc->msg("Expecting a line number or fully qualified function; got ${args[0]}");
+		$proc->msg("Expecting a line number or function; got ${args[0]}");
 		return;
 	    }
 	}

lib/Devel/Trepan/CmdProcessor/Location.pm

@@ -127,7 +127,9 @@ sub format_location($;$$$)
 
     my $loc = $self->source_location_info;
     my $suffix = ($event eq 'return' && defined($DB::_[0])) ? " $DB::_[0]" : '';
-    "${ev} (${loc})$suffix"
+    my $pkg = $self->{frame}{pkg};
+    $pkg .= '::' unless $pkg =~ /::/;
+    "${ev} $pkg(${loc})$suffix"
 }
 
 sub print_location($;$)

lib/Devel/Trepan/DB.pm

@@ -145,6 +145,7 @@ END {
         $DB::single = 1;
         DB::fake::at_exit();
     }
+    $DB::ready = 0;
 } 
 
 ####

t/20test-trace.t

@@ -11,7 +11,7 @@ my $opts = {
 	my @result = ();
 	for my $line (split("\n", $got_lines)) {
 	    $line =~ s/\((?:.*\/)?(.+\:\d+)\)/($1)/;
-	    last if (0 == index($line, '-- (Temp.pm:'));
+	    last if (0 == index($line, '-- File::Temp(Temp.pm:'));
 	    push @result, $line;
 	}
 

t/data/__FILE__.right

@@ -1,4 +1,4 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 Eval result display style is dumper.
 $DB::D[0] = "gcd.pl"

t/data/alias.right

@@ -1,4 +1,4 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 *** You must alias to a command name, and 'foo' isn't one.
 New alias 'yy' for command string 'step' created.

t/data/autolist.right

@@ -1,9 +1,9 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 basename is on.
 highlight is off.
 set auto list is on.
--- (gcd.pl:20)
+-- main::(gcd.pl:20)
 my ($a, $b) = @ARGV[0,1];
 gcd.pl [16-21]
  16    	}
@@ -12,15 +12,15 @@ gcd.pl [16-21]
  19    	    @ARGV == 2;
  20  ->	my ($a, $b) = @ARGV[0,1];
  21    	printf "The GCD of %d and %d is %d\n", $a, $b, gcd($a, $b);
--- (gcd.pl:21)
+-- main::(gcd.pl:21)
 printf "The GCD of %d and %d is %d\n", $a, $b, gcd($a, $b);
 gcd.pl [17-21]
  17    	
  18    	die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
  19    	    @ARGV == 2;
  20    	my ($a, $b) = @ARGV[0,1];
  21  ->	printf "The GCD of %d and %d is %d\n", $a, $b, gcd($a, $b);
--- (gcd.pl:9)
+-- main::(gcd.pl:9)
     my ($a, $b) = @_;
 gcd.pl [5-14]
   5    	# GCD. We assume positive numbers
@@ -34,7 +34,7 @@ gcd.pl [5-14]
  13    	    return undef if $a <= 0;
  14    	    return $a if ($a == 1) or ($b-$a == 0);
 set auto list is off.
--- (gcd.pl:11)
+-- main::(gcd.pl:11)
     ($a, $b) = ($b, $a) if ($a > $b);
--- (gcd.pl:13)
+-- main::(gcd.pl:13)
     return undef if $a <= 0;

t/data/break.right

@@ -1,4 +1,4 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 Breakpoint 1 set in gcd.pl at line 18
 Breakpoint 2 set in gcd.pl at line 9
@@ -14,5 +14,5 @@ Possible breakpoint line numbers:
 *** Line 10 of XXX not known to be a trace line.
 Use 'info file XXX brkpts' to see breakpoints I know about
 *** Subroutine gcd1 not found.
-x1 (gcd.pl:9)
+x1 main::(gcd.pl:9)
     my ($a, $b) = @_;

t/data/break2.right

@@ -1,4 +1,4 @@
--- (TCPPack.pm:9)
+-- TCPPack::(TCPPack.pm:9)
 our (@ISA, @EXPORT);
 Breakpoint 1 set in Exporter.pm at line 29
 Breakpoint 2 set in TCPPack.pm at line 20

t/data/cont.right

@@ -1,10 +1,10 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
--- (gcd.pl:20)
+-- main::(gcd.pl:20)
 my ($a, $b) = @ARGV[0,1];
--- (gcd.pl:21)
+-- main::(gcd.pl:21)
 printf "The GCD of %d and %d is %d\n", $a, $b, gcd($a, $b);
--- (gcd.pl:9)
+-- main::(gcd.pl:9)
     my ($a, $b) = @_;
-x1 (gcd.pl:9)
+x1 main::(gcd.pl:9)
     my ($a, $b) = @_;

t/data/debug.right

@@ -1,54 +1,54 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 basename is on.
 highlight is off.
 set auto eval is on.
 Eval result display style is dumper.
 $DB::D[0] = <undef>
--- ( (eval remapped 5)
+-- main::( (eval remapped 5)
 $DB::in_debugger=0;
--- (gcd.pl:9)
+-- main::(gcd.pl:9)
     my ($a, $b) = @_;
--- (gcd.pl:11)
+-- main::(gcd.pl:11)
     ($a, $b) = ($b, $a) if ($a > $b);
 $DB::D[0] = 1
 $DB::D[1] = 1
--- (gcd.pl:13)
+-- main::(gcd.pl:13)
     return undef if $a <= 0;
--- (gcd.pl:14)
+-- main::(gcd.pl:14)
     return $a if ($a == 1) or ($b-$a == 0);
 $DB::D[2] = 1
 Leaving nested debug level 1
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 $DB::D[3] = <undef>
--- ( (eval remapped 5)
+-- main::( (eval remapped 5)
 $DB::in_debugger=0;
--- (gcd.pl:9)
+-- main::(gcd.pl:9)
     my ($a, $b) = @_;
--- (gcd.pl:11)
+-- main::(gcd.pl:11)
     ($a, $b) = ($b, $a) if ($a > $b);
 $DB::D[3] = 1
 $DB::D[4] = 1
--- ( (eval remapped 5)
--- (gcd.pl:9)
+-- main::( (eval remapped 5)
+-- main::(gcd.pl:9)
     my ($a, $b) = @_;
--- (gcd.pl:11)
+-- main::(gcd.pl:11)
     ($a, $b) = ($b, $a) if ($a > $b);
 $DB::D[5] = 2
--- (gcd.pl:13)
+-- main::(gcd.pl:13)
     return undef if $a <= 0;
--- (gcd.pl:14)
+-- main::(gcd.pl:14)
     return $a if ($a == 1) or ($b-$a == 0);
 $DB::D[6] = 2
 Leaving nested debug level 2
--- (gcd.pl:11)
+-- main::(gcd.pl:11)
     ($a, $b) = ($b, $a) if ($a > $b);
--- (gcd.pl:13)
+-- main::(gcd.pl:13)
     return undef if $a <= 0;
--- (gcd.pl:14)
+-- main::(gcd.pl:14)
     return $a if ($a == 1) or ($b-$a == 0);
 $DB::D[7] = 1
 Leaving nested debug level 1
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 

t/data/display.right

@@ -1,14 +1,14 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 Display 1 set
 1: 3, 5
--- (gcd.pl:20)
+-- main::(gcd.pl:20)
 my ($a, $b) = @ARGV[0,1];
 *** Expecting an integer, got: a.
 *** No display number 2
--- (gcd.pl:21)
+-- main::(gcd.pl:21)
 printf "The GCD of %d and %d is %d\n", $a, $b, gcd($a, $b);
 Display 2 set
 2: 3 | 5
--- (gcd.pl:9)
+-- main::(gcd.pl:9)
     my ($a, $b) = @_;

t/data/dollar0.right

@@ -1,4 +1,4 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 Eval result display style is dumper.
 $DB::D[0] = 0

t/data/eval.right

@@ -1,4 +1,4 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 set auto eval is on.
 Eval result display style is dumper.
@@ -16,9 +16,9 @@ $DB::D[2] =
 $DB::D[3] = 2
 $DB::D[4] = 0
 $DB::D[5] = 7
-x1 (gcd.pl:9)
+x1 main::(gcd.pl:9)
     my ($a, $b) = @_;
--- (gcd.pl:11)
+-- main::(gcd.pl:11)
     ($a, $b) = ($b, $a) if ($a > $b);
 $DB::D[6] = 3
 $DB::D[7] = 5

t/data/eval2.right

@@ -1,6 +1,6 @@
 --
 ++
--- (eval.pl:1)
+-- main::(eval.pl:1)
 $var = '
 Eval result display style is dumper.
 set auto eval is on.
@@ -15,7 +15,7 @@ eval.pl [1-10]
   8    	    my @args = @_;
   9    	    print "ho\n";
  10    	    5;
--- (eval.pl:5)
+-- main::(eval.pl:5)
 eval $var;
 $DB::D[0] = 1
 eval.pl [1-10]
@@ -30,17 +30,17 @@ eval.pl [1-10]
   9    	    print "ho\n";
  10    	    5;
 $DB::D[1] = 1
--- ( (eval remapped 2)
--- ( (eval remapped 3)
+-- main::( (eval remapped 2)
+-- main::( (eval remapped 3)
 $x = 2;
--- ( (eval remapped 4)
+-- main::( (eval remapped 4)
 $y = 3;
--- (eval.pl:6)
+-- main::(eval.pl:6)
 $eval_sub='
--- (eval.pl:12)
+-- main::(eval.pl:12)
 eval $eval_sub;
--- (eval.pl:13)
+-- main::(eval.pl:13)
 $y = five();
--- ( (eval remapped 3)
+-- main::( (eval remapped 3)
 --> #0 @ = main::five() in file `(eval 1000)[eval.pl:12]' at line 3
     #1 file `eval.pl' at line 13

t/data/fin.right

@@ -1,8 +1,8 @@
--- (TCPPack.pm:9)
+-- TCPPack::(TCPPack.pm:9)
 our (@ISA, @EXPORT);
-x1 (TCPPack.pm:18)
+x1 TCPPack::(TCPPack.pm:18)
     my $msg = shift;
-<- (TCPPack.pm:37) TCPPack::pack_msg
+<- TCPPack::(TCPPack.pm:37) TCPPack::pack_msg
     ($buf, $msg) = unpack_msg(pack_msg($buf));
 Return value for TCPPack::pack_msg is: 0009Hi there!
 *** Can't run finish while inside a return. Step and try again.

t/data/fin2.right

@@ -1,10 +1,10 @@
 The GCD of 3 and 5 is 10
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
-x1 (gcd.pl:9)
+x1 main::(gcd.pl:9)
     my ($a, $b) = @_;
 *** We are not stopped at a return
-<- (gcd.pl:21) main::gcd
+<- main::(gcd.pl:21) main::gcd
 printf "The GCD of %d and %d is %d\n", $a, $b, gcd($a, $b);
 Return array value for main::gcd is:
 1

t/data/line.right

@@ -1,10 +1,10 @@
--- (gcd.pl:18)
+-- main::(gcd.pl:18)
 die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
 basename is on.
 Line 18, file gcd.pl
 COP address: 0x12345678.
 Line 19, file gcd.pl
 Line not showing as associated with code
 
-Expecting a line number or fully qualified function; got a
+Expecting a line number or function; got a
 Function main::gcd in file gcd.pl lines 8..16

t/data/list1.right

@@ -1,4 +1,4 @@
--- (test-require.pl:3)
+-- main::(test-require.pl:3)
 my $DIR = dirname(__FILE__);
 basename is on.
 highlight is off.
@@ -12,17 +12,17 @@ test-require.pl [1-9]
   7    	my $y = $x;
   8    	
   9    	
--- (test-require.pl:4)
+-- main::(test-require.pl:4)
 my $require_file = File::Spec->catfile($DIR, "test-module.pm");
--- (test-require.pl:5)
+-- main::(test-require.pl:5)
 require $require_file;
--- (test-module.pm:5)
+-- Test::Module(test-module.pm:5)
 my $x = 1;
--- (test-module.pm:6)
+-- Test::Module(test-module.pm:6)
 my $y = 2;
--- (test-require.pl:6)
+-- main::(test-require.pl:6)
 my $x = Test::Module::five();
--- (test-module.pm:3)
+-- Test::Module(test-module.pm:3)
     return 5;
 test-module.pm [1-6]
   1    	package Test::Module;
@@ -33,7 +33,7 @@ test-module.pm [1-6]
   6    	my $y = 2;
 *** Bad line range [7...16]; file "test-module.pm" has only 6 lines
 --> #1 file `test-require.pl' at line 6
-   (test-require.pl:6)
+   main::(test-require.pl:6)
 my $x = Test::Module::five();
 test-require.pl [2-9]
   2    	use File::Spec;

t/data/list2.right

@@ -1,4 +1,4 @@
--- (test-require.pl:3)
+-- main::(test-require.pl:3)
 my $DIR = dirname(__FILE__);
 basename is on.
 highlight is off.