lexical warnings update, ability to inspect bitmask in calling

scope, among other things (from Paul Marquess)

p4raw-id: //depot/perl@5170

1 files changed, 34 insertions, 23 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index 24fad37430..7c69e3526b 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1075,28 +1075,28 @@ S_dopoptolabel(pTHX_ char *label)
 	cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_FORMAT:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
 			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
@@ -1201,28 +1201,28 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 	cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_SUB:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_FORMAT:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_EVAL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
 			PL_op_name[PL_op->op_type]);
 	    break;
 	case CXt_NULL:
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+	    if (ckWARN(WARN_EXITING))
+		Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
 			PL_op_name[PL_op->op_type]);
 	    return -1;
 	case CXt_LOOP:
@@ -1347,9 +1347,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 		    SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
 		    sv_catpvn(err, prefix, sizeof(prefix)-1);
 		    sv_catpvn(err, message, msglen);
-		    if (ckWARN(WARN_UNSAFE)) {
+		    if (ckWARN(WARN_MISC)) {
 			STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
-			Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
+			Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
 		    }
 		}
 	    }
@@ -1456,7 +1456,7 @@ PP(pp_caller)
 
     if (MAXARG)
 	count = POPi;
-    EXTEND(SP, 7);
+    EXTEND(SP, 10);
     for (;;) {
 	/* we may be in a higher stacklevel, so dig down deeper */
 	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -1561,6 +1561,17 @@ PP(pp_caller)
      * use the global PL_hints) */
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
 			     HINT_PRIVATE_MASK)));
+    {
+	SV * mask ;
+	SV * old_warnings = cx->blk_oldcop->cop_warnings ;
+	if  (old_warnings == WARN_NONE || old_warnings == WARN_STD)
+            mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+        else if (old_warnings == WARN_ALL)
+            mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+        else
+            mask = newSVsv(old_warnings);
+        PUSHs(sv_2mortal(mask));
+    }
     RETURN;
 }