From: Nicholas Clark <nick@ccl4.org>
Date: Tue, 2 Dec 2008 16:20:01 +0000 (+0000)
Subject: Followup to change 34979. Tests are good, m'kay. Particularly when they
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=83fca67e98dfae0d928a42dd87ba57ec05eeb359;p=p5sagit%2Fp5-mst-13.2.git

Followup to change 34979. Tests are good, m'kay. Particularly when they
show you that something you thought worked doesn't.
Sadly it's not possible to trivially make it work, so for now they're
todo_skip().

p4raw-id: //depot/perl@34981
---

diff --git a/perl.h b/perl.h
index e9c3611..1338483 100644
--- a/perl.h
+++ b/perl.h
@@ -5347,7 +5347,9 @@ typedef struct am_table_short AMTS;
 #define PERLDBf_NAMEANON	0x200	/* Informative names for anon subs */
 #define PERLDBf_SAVESRC  	0x400	/* Save source lines into @{"_<$filename"} */
 #define PERLDBf_SAVESRC_NOSUBS	0x800	/* Including evals that generate no subrouties */
+#if 0 /* Not yet working. */
 #define PERLDBf_SAVESRC_INVALID	0x1000	/* Save source that did not compile */
+#endif
 
 #define PERLDB_SUB	(PL_perldb && (PL_perldb & PERLDBf_SUB))
 #define PERLDB_LINE	(PL_perldb && (PL_perldb & PERLDBf_LINE))
@@ -5361,7 +5363,9 @@ typedef struct am_table_short AMTS;
 #define PERLDB_NAMEANON	(PL_perldb && (PL_perldb & PERLDBf_NAMEANON))
 #define PERLDB_SAVESRC 	(PL_perldb && (PL_perldb & PERLDBf_SAVESRC))
 #define PERLDB_SAVESRC_NOSUBS	(PL_perldb && (PL_perldb & PERLDBf_SAVESRC_NOSUBS))
+#if 0 /* Not yet working. */
 #define PERLDB_SAVESRC_INVALID	(PL_perldb && (PL_perldb & PERLDBf_SAVESRC_INVALID))
+#endif
 
 #ifdef USE_LOCALE_NUMERIC
 
diff --git a/pp_ctl.c b/pp_ctl.c
index a3b0b0f..803ca05 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3733,7 +3733,16 @@ PP(pp_entereval)
     if (ok ? (was != PL_breakable_sub_gen /* Some subs defined here. */
 	      ? (PERLDB_LINE || PERLDB_SAVESRC)
 	      :  PERLDB_SAVESRC_NOSUBS)
-	: PERLDB_SAVESRC_INVALID) {
+	: 0 /* PERLDB_SAVESRC_INVALID */
+	/* Much that I'd like to think that it was this trivial to add this
+	   feature, it's not, due to
+	       lex_end();
+	       LEAVE;
+	   in S_doeval() for the failure case. So really we want a more
+	   sophisticated way of (optionally) clearing the source code.
+	   Particularly as the current way is buggy, as a syntactically
+	   invalid eval string can still define a subroutine that is retained,
+	   and the user may wish to breakpoint. */) {
 	/* Just need to change the string in our writable scratch buffer that
 	   will be used at scope exit to delete this eval's "file" name, to
 	   something safe. The key names are of the form "_<(eval 1)" upwards,
diff --git a/t/comp/retainedlines.t b/t/comp/retainedlines.t
index 41c279e..b0f999f 100644
--- a/t/comp/retainedlines.t
+++ b/t/comp/retainedlines.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use strict;
 
-plan (tests => 21);
+plan (tests => 55);
 
 $^P = 0xA;
 
@@ -19,17 +19,9 @@ my @before = grep { /eval/ } keys %::;
 is (@before, 0, "No evals");
 
 my %seen;
-my $name = 'foo';
-
-for my $sep (' ', "\0") {
 
-    my $prog = "sub $name {
-    'Perl${sep}Rules'
-};
-1;
-";
-
-    eval $prog or die;
+sub check_retained_lines {
+    my ($prog, $name) = @_;
     # Is there a more efficient way to write this?
     my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';');
 
@@ -39,19 +31,57 @@ for my $sep (' ', "\0") {
 
     my @got_lines = @{$::{$keys[0]}};
 
-    is (@got_lines, @expect_lines, "Right number of lines for " . ord $sep);
+    is (@got_lines, @expect_lines, "Right number of lines for $name");
 
     for (0..$#expect_lines) {
 	is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct");
     }
     $seen{$keys[0]}++;
+}
+
+my $name = 'foo';
+
+for my $sep (' ', "\0") {
+
+    my $prog = "sub $name {
+    'Perl${sep}Rules'
+};
+1;
+";
+
+    eval $prog or die;
+    check_retained_lines($prog, ord $sep);
     $name++;
 }
 
-is (eval '1 + 1', 2, 'String eval works');
+foreach my $flags (0x0, 0x800, 0x1000, 0x1800) {
+    local $^P = $^P | $flags;
+    # This is easier if we accept that the guts eval will add a trailing \n
+    # for us
+    my $prog = "1 + 1 + 1\n";
+    my $fail = "1 + \n";
+
+    is (eval $prog, 3, 'String eval works');
+    if ($flags & 0x800) {
+	check_retained_lines($prog, sprintf "%#X", $^P);
+    } else {
+	my @after = grep { /eval/ } keys %::;
+
+	is (@after, 0 + keys %seen,
+	    "evals that don't define subroutines are correctly cleaned up");
+    }
 
-my @after = grep { /eval/ } keys %::;
+    is (eval $fail, undef, 'Failed string eval fails');
 
-is (@after, 0 + keys %seen,
-    "evals that don't define subroutines are correctly cleaned up");
+    if ($flags & 0x1000) {
+    TODO: {
+	    todo_skip "Can't yet retain lines for evals with syntax errors", 6;
+	    check_retained_lines($fail, sprintf "%#X", $^P);
+	}
+    } else {
+	my @after = grep { /eval/ } keys %::;
 
+	is (@after, 0 + keys %seen,
+	    "evals that fail are correctly cleaned up");
+    }
+}