Fix up __FILE__ and __LINE__ when running eval.

rocky · Aug 5, 2012 · 08cb7fa · 08cb7fa
1 parent 5ae5c97
commit 08cb7fa
Show file tree

Hide file tree

Showing 7 changed files with 66 additions and 8 deletions.
diff --git a/MANIFEST b/MANIFEST
@@ -202,6 +202,7 @@ t/20test-dollar0.t
 t/20test-display.t
 t/20test-eval.t
 t/20test-fin.t
+t/20test-__FILE__.t
 t/20test-list1.t
 t/20test-list2.t
 t/20test-list3.t
@@ -215,6 +216,9 @@ t/20test-step.t
 t/20test-trace.t
 t/20test-trepanpl-opts.t
 t/20test-watch1.t
+t/data/__FILE__.cmd
+t/data/__FILE__.right
+t/data/alias.right
 t/data/alias.cmd
 t/data/alias.right
 t/data/autolist.cmd

diff --git a/lib/Devel/Trepan/CmdProcessor/Command/Debug.pm b/lib/Devel/Trepan/CmdProcessor/Command/Debug.pm
@@ -1,5 +1,5 @@
 # -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rockyb@rubyforge.net>
+# Copyright (C) 2011, 2012 Rocky Bernstein <rockb@cpan.org>
 use warnings; no warnings 'redefine';
 
 use rlib '../../../..';
@@ -63,8 +63,14 @@ sub run($$)
 	"\$^D |= DB::db_stop;\n" . 
 	"\$DB::in_debugger=0;\n" . 
 	$expr;
+
+    # Don't fix up __FILE__ and __LINE__ in this eval. 
+    # We want to see our debug (eval) with the string above.
+    $DB::fix_file_and_line = 0;
+
     # FIXME: 4 below is a magic fixup constant.
     $proc->eval($full_expr, $opts, 4);
+
 }
 
 unless (caller) {

diff --git a/lib/Devel/Trepan/DB/Eval.pm b/lib/Devel/Trepan/DB/Eval.pm
@@ -3,7 +3,7 @@
 package DB;
 use warnings; use strict;
 use English qw( -no_match_vars );
-use vars qw($eval_result @eval_result %eval_result
+use vars qw($eval_result @eval_result %eval_result $fix_file_and_line
             $eval_str $eval_opts $event $return_type );
 
 # This is the flag that says "a debugger is running, please call
@@ -21,6 +21,9 @@ BEGIN {
     $DB::eval_result = undef;   # Place for result if scalar;
     @DB::eval_result = ();      # place for result if array
     %DB::eval_result = ();      # place for result if hash.
+    $DB::fix_file_and_line = 1; # Should we fix __FILE__ and __LINE__ ? 
+                                # This value is reset after each eval.
+
 }    
 
 #
@@ -49,12 +52,18 @@ sub eval {
 	local $osingle = $DB::single;
 	local $od      = $DEBUGGING;
 
-	@res = eval "$user_context $eval_str;\n&DB::save\n"; # '\n' for nice recursive debug
+	# Make sure __FILE__ and __LINE__ are set correctly
+	my $eval_setup = $user_context;
+	my $position_str = "\n# line $DB::lineno \"$DB::filename\"\n";
+	$eval_setup .= $position_str if $DB::fix_file_and_line;
+
+	@res = eval "$eval_setup $eval_str;\n&DB::save\n"; # '\n' for nice recursive debug
 	_warnall($@) if $@;
 
         # Restore those old values.
         $DB::trace  = $otrace;
         $DB::single = $osingle;
+	$DB::fix_file_and_line = 1;
         $DEBUGGING  = $od;
     }
 }
@@ -82,19 +91,25 @@ sub eval_with_return {
 	local $osingle = $DB::single;
 	local $od      = $DEBUGGING;
 
+	# Make sure __FILE__ and __LINE__ are set correctly
+	my $eval_setup = $user_context;
+	my $position_str = "\n# line $DB::lineno \"$DB::filename\"\n";
+	$eval_setup .= $position_str if $DB::fix_file_and_line;
+
 	if ('$' eq $return_type) {
-	    eval "$user_context \$DB::eval_result=$eval_str\n";
+	    eval "$eval_setup \$DB::eval_result=$eval_str\n";
 	} elsif ('@' eq $return_type) {
-	    eval "$user_context \@DB::eval_result=$eval_str\n";
+	    eval "$eval_setup \@DB::eval_result=$eval_str\n";
 	} elsif ('%' eq $return_type) {
-	    eval "$user_context \%DB::eval_result=$eval_str\n";
+	    eval "$eval_setup \%DB::eval_result=$eval_str\n";
 	} else {
-	    $eval_result = eval "$user_context $eval_str";
+	    $eval_result = eval "$eval_setup $eval_str";
 	}
 
         # Restore those old values.
         $DB::trace  = $otrace;
         $DB::single = $osingle;
+	$DB::fix_file_and_line = 1;
         $DEBUGGING  = $od;
 
 	my $EVAL_ERROR_SAVE = $EVAL_ERROR;

diff --git a/t/20test-__FILE__.t b/t/20test-__FILE__.t
@@ -0,0 +1,26 @@
+#!/usr/bin/env perl
+use warnings; use strict;
+use rlib '.';
+use Helper;
+no warnings 'redefine';
+
+my $opts = {
+    filter => sub{
+	my ($got_lines, $correct_lines) = @_;
+	my @result = ();
+	for my $line (split("\n", $got_lines)) {
+	    if ($line =~ /['"].*gcd.pl["']/) {
+		$line =~ s/['"].*gcd.pl["']/"gcd.pl"/;
+	    }
+	    push @result, $line;
+	}
+	$got_lines = join("\n", @result) . "\n";
+	return ($got_lines, $correct_lines);
+    },
+    run_opts => " --basename --no-highlight -nx"
+};
+
+my $test_prog = File::Spec->catfile(dirname(__FILE__), qw(.. example gcd.pl));
+use Test::More;
+Helper::run_debugger("$test_prog 3 5", '__FILE__.cmd', undef, $opts);
+done_testing();
diff --git a/t/20test-dollar0.t b/t/20test-dollar0.t
@@ -19,7 +19,6 @@ my $opts = {
     run_opts => " --basename --no-highlight -nx"
 };
 
-
 my $test_prog = File::Spec->catfile(dirname(__FILE__), qw(.. example gcd.pl));
 use Test::More;
 Helper::run_debugger("$test_prog 3 5", 'dollar0.cmd', undef, $opts);

diff --git a/t/data/__FILE__.cmd b/t/data/__FILE__.cmd
@@ -0,0 +1,4 @@
+# Test that __FILE__ and __LINE__ are set properly in eval.
+eval __FILE__
+eval __LINE__
+q!
diff --git a/t/data/__FILE__.right b/t/data/__FILE__.right
@@ -0,0 +1,4 @@
+-- (gcd.pl:18)
+die sprintf "Need two integer arguments, got %d", scalar(@ARGV) unless 
+$DB::D[0] = "gcd.pl"
+$DB::D[1] = 18