More accurate line numbers in messages

Message-ID: <20010712041411.A3467@pjcj.net>

(With prototyping and multiplicity tweaks.)

p4raw-id: //depot/perl@11305

5 files changed, 113 insertions, 2 deletions

diff --git a/dump.c b/dump.c
index f23ac7babc..c2f7746b8e 100644
--- a/dump.c
+++ b/dump.c
@@ -392,7 +392,20 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
 	PerlIO_printf(file, "DONE\n");
     if (o->op_targ) {
 	if (o->op_type == OP_NULL)
+	{
 	    Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
+	    if (o->op_targ == OP_NEXTSTATE)
+	    {
+		if (CopLINE(cCOPo))
+		    Perl_dump_indent(aTHX_ level, file, "LINE = %d\n",CopLINE(cCOPo));
+		if (CopSTASHPV(cCOPo))
+		    Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
+				     CopSTASHPV(cCOPo));
+		if (cCOPo->cop_label)
+		    Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
+				     cCOPo->cop_label);
+	    }
+	}
 	else
 	    Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
     }
diff --git a/embed.h b/embed.h
index cb9eb6c0fd..0a12dcda6b 100644
--- a/embed.h
+++ b/embed.h
@@ -1177,6 +1177,7 @@
 #define stdize_locale		S_stdize_locale
 #endif
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#define closest_cop		S_closest_cop
 #define mess_alloc		S_mess_alloc
 #  if defined(LEAKTEST)
 #define xstat			S_xstat
@@ -2677,6 +2678,7 @@
 #define stdize_locale(a)	S_stdize_locale(aTHX_ a)
 #endif
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#define closest_cop(a,b)	S_closest_cop(aTHX_ a,b)
 #define mess_alloc()		S_mess_alloc(aTHX)
 #  if defined(LEAKTEST)
 #define xstat(a)		S_xstat(aTHX_ a)
@@ -5201,6 +5203,8 @@
 #define stdize_locale		S_stdize_locale
 #endif
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#define S_closest_cop		CPerlObj::S_closest_cop
+#define closest_cop		S_closest_cop
 #define S_mess_alloc		CPerlObj::S_mess_alloc
 #define mess_alloc		S_mess_alloc
 #  if defined(LEAKTEST)
diff --git a/embed.pl b/embed.pl
index 82ebfd2d8f..ee21f3efb6 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2593,6 +2593,7 @@ s	|char*	|stdize_locale	|char* locs
 #endif
 
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+s	|COP*	|closest_cop	|COP *cop|OP *o
 s	|SV*	|mess_alloc
 #  if defined(LEAKTEST)
 s	|void	|xstat		|int
diff --git a/t/lib/warnings/util b/t/lib/warnings/util
index e82d6a6617..4e960c1ea1 100644
--- a/t/lib/warnings/util
+++ b/t/lib/warnings/util
@@ -106,3 +106,53 @@ no warnings 'portable' ;
    $a =  oct "0047777777777" ;
 EXPECT
 Octal number > 037777777777 non-portable at - line 5.
+########
+# util.c
+use warnings;
+$x = 1;
+if ($x) {
+    print $y;
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 5.
+Use of uninitialized value in print at - line 5.
+########
+# util.c
+use warnings;
+$x = 1;
+if ($x) {
+    $x++;
+    print $y;
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 6.
+Use of uninitialized value in print at - line 6.
+########
+# util.c
+use warnings;
+$x = 0;
+if ($x) {
+    print "1\n";
+} elsif (!$x) {
+    print $y;
+} else {
+    print "0\n";
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 7.
+Use of uninitialized value in print at - line 7.
+########
+# util.c
+use warnings;
+$x = 0;
+if ($x) {
+    print "1\n";
+} elsif (!$x) {
+    $x++;
+    print $y;
+} else {
+    print "0\n";
+}
+EXPECT
+Name "main::y" used only once: possible typo at - line 8.
+Use of uninitialized value in print at - line 8.
diff --git a/util.c b/util.c
index b72a8f2fef..e01e836cd1 100644
--- a/util.c
+++ b/util.c
@@ -1003,17 +1003,60 @@ Perl_mess(pTHX_ const char *pat, ...)
     return retval;
 }
 
+STATIC COP*
+S_closest_cop(pTHX_ COP *cop, OP *o)
+{
+    /* Look for PL_op starting from o.  cop is the last COP we've seen. */
+
+    if (!o || o == PL_op) return cop;
+
+    if (o->op_flags & OPf_KIDS) {
+	OP *kid;
+	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+	{
+	    COP *new_cop;
+
+	    /* If the OP_NEXTSTATE has been optimised away we can still use it
+	     * the get the file and line number. */
+
+	    if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
+		cop = (COP *)kid;
+
+	    /* Keep searching, and return when we've found something. */
+
+	    new_cop = closest_cop(cop, kid);
+	    if (new_cop) return new_cop;
+	}
+    }
+
+    /* Nothing found. */
+
+    return 0;
+}
+
 SV *
 Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
     SV *sv = mess_alloc();
     static char dgd[] = " during global destruction.\n";
+    COP *cop;
 
     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
-	if (CopLINE(PL_curcop))
+
+	/*
+	 * Try and find the file and line for PL_op.  This will usually be
+	 * PL_curcop, but it might be a cop that has been optimised away.  We
+	 * can try to find such a cop by searching through the optree starting
+	 * from the sibling of PL_curcop.
+	 */
+
+	cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
+	if (!cop) cop = PL_curcop;
+
+	if (CopLINE(cop))
 	    Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
-			   CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+			   CopFILE(cop), (IV)CopLINE(cop));
 	if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
 	    bool line_mode = (RsSIMPLE(PL_rs) &&
 			      SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');