Fix B and ByteLoader to cope with cop_warnings no longer being an SV.

p4raw-id: //depot/perl@27786

5 files changed, 68 insertions, 11 deletions

diff --git a/bytecode.pl b/bytecode.pl
index 11e148cda7..f0763ddf83 100644
--- a/bytecode.pl
+++ b/bytecode.pl
@@ -14,7 +14,8 @@ my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
 
 # Nullsv *must* come first in the following so that the condition
 # ($$sv == 0) can continue to be used to test (sv == Nullsv).
-my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE);
+my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no
+		   (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD);
 
 my (%alias_from, $from, $tos);
 while (($from, $tos) = each %alias_to) {
@@ -496,7 +497,7 @@ cop_seq		cCOP->cop_seq				U32
 cop_arybase	cCOP					I32		x
 cop_line	cCOP->cop_line				line_t
 cop_io		cCOP->cop_io				svindex
-cop_warnings	cCOP->cop_warnings			svindex
+cop_warnings	cCOP					svindex		x
 main_start	PL_main_start				opindex
 main_root	PL_main_root				opindex
 main_cv		*(SV**)&PL_main_cv			svindex
diff --git a/ext/B/B.xs b/ext/B/B.xs
index d1a3d7a3fa..d8ec4e31ad 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -247,6 +247,47 @@ make_sv_object(pTHX_ SV *arg, SV *sv)
 }
 
 static SV *
+make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
+{
+    const char *type = 0;
+    dMY_CXT;
+    IV iv = sizeof(specialsv_list)/sizeof(SV*);
+
+    /* Counting down is deliberate. Before the split between make_sv_object
+       and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
+       were both 0, so you could never get a B::SPECIAL for pWARN_STD  */
+
+    while (iv--) {
+	if ((SV*)warnings == specialsv_list[iv]) {
+	    type = "B::SPECIAL";
+	    break;
+	}
+    }
+    if (type) {
+	sv_setiv(newSVrv(arg, type), iv);
+    } else {
+	/* B assumes that warnings are a regular SV. Seems easier to keep it
+	   happy by making them into a regular SV.  */
+	SV *temp = newSVpvn((char *)(warnings + 1), *warnings);
+	SV *target;
+
+	type = svclassnames[SvTYPE(temp)];
+	target = newSVrv(arg, type);
+	iv = PTR2IV(temp);
+	sv_setiv(target, iv);
+
+	/* Need to keep our "temp" around as long as the target exists.
+	   Simplest way seems to be to hang it from magic, and let that clear
+	   it up.  No vtable, so won't actually get in the way of anything.  */
+	sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
+	/* magic object has had its reference count increased, so we must drop
+	   our reference.  */
+	SvREFCNT_dec(temp);
+    }
+    return arg;
+}
+
+static SV *
 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
 {
     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
@@ -510,9 +551,9 @@ BOOT:
     specialsv_list[1] = &PL_sv_undef;
     specialsv_list[2] = &PL_sv_yes;
     specialsv_list[3] = &PL_sv_no;
-    specialsv_list[4] = pWARN_ALL;
-    specialsv_list[5] = pWARN_NONE;
-    specialsv_list[6] = pWARN_STD;
+    specialsv_list[4] = (SV *) pWARN_ALL;
+    specialsv_list[5] = (SV *) pWARN_NONE;
+    specialsv_list[6] = (SV *) pWARN_STD;
 #if PERL_VERSION <= 8
 #  define CVf_ASSERTION	0
 #endif
@@ -1059,7 +1100,6 @@ LOOP_lastop(o)
 #define COP_cop_seq(o)	o->cop_seq
 #define COP_arybase(o)	CopARYBASE_get(o)
 #define COP_line(o)	CopLINE(o)
-#define COP_warnings(o)	o->cop_warnings
 #define COP_io(o)	o->cop_io
 
 MODULE = B	PACKAGE = B::COP		PREFIX = COP_
@@ -1097,9 +1137,12 @@ U32
 COP_line(o)
 	B::COP	o
 
-B::SV
+void
 COP_warnings(o)
 	B::COP	o
+	PPCODE:
+	ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
+	XSRETURN(1);
 
 B::SV
 COP_io(o)
diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm
index bd130fe540..3e73a1f5cf 100644
--- a/ext/B/B/Asmdata.pm
+++ b/ext/B/B/Asmdata.pm
@@ -19,7 +19,7 @@ use Exporter;
 our(%insn_data, @insn_name, @optype, @specialsv_name);
 
 @optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
-@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE);
+@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD);
 
 # XXX insn_data is initialised this way because with a large
 # %insn_data = (foo => [...], bar => [...], ...) initialiser
diff --git a/ext/ByteLoader/bytecode.h b/ext/ByteLoader/bytecode.h
index 13f851040e..7ba0236313 100644
--- a/ext/ByteLoader/bytecode.h
+++ b/ext/ByteLoader/bytecode.h
@@ -349,6 +349,18 @@ typedef char *pvindex;
 
 #define BSET_xhv_name(hv, name)	hv_name_set((HV*)hv, name, strlen(name), 0)
 #define BSET_cop_arybase(c, b) CopARYBASE_set(c, b)
+#define BSET_cop_warnings(c, w) \
+	STMT_START {							\
+	    if (specialWARN((STRLEN *)w)) {				\
+		c->cop_warnings = (STRLEN *)w;				\
+	    } else {							\
+		STRLEN len;						\
+		const char *const p = SvPV_const(w, len);		\
+		c->cop_warnings =					\
+		    Perl_new_warnings_bitfield(aTHX_ NULL, p, len);	\
+		SvREFCNT_dec(w);					\
+	    }								\
+	} STMT_END
 
 /* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about
  * what version of Perl it's being called under, it should do a 'use 5.006_001' or
diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c
index 8c8279819d..c8543f7ffe 100644
--- a/ext/ByteLoader/byterun.c
+++ b/ext/ByteLoader/byterun.c
@@ -63,8 +63,9 @@ byterun(pTHX_ register struct byteloader_state *bstate)
     specialsv_list[1] = &PL_sv_undef;
     specialsv_list[2] = &PL_sv_yes;
     specialsv_list[3] = &PL_sv_no;
-    specialsv_list[4] = pWARN_ALL;
-    specialsv_list[5] = pWARN_NONE;
+    specialsv_list[4] = (SV*)pWARN_ALL;
+    specialsv_list[5] = (SV*)pWARN_NONE;
+    specialsv_list[6] = (SV*)pWARN_STD;
 
     while ((insn = BGET_FGETC()) != EOF) {
 	switch (insn) {
@@ -985,7 +986,7 @@ byterun(pTHX_ register struct byteloader_state *bstate)
 	    {
 		svindex arg;
 		BGET_svindex(arg);
-		cCOP->cop_warnings = arg;
+		BSET_cop_warnings(cCOP, arg);
 		break;
 	    }
 	  case INSN_MAIN_START:		/* 132 */