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

p4raw-id: //depot/perl@27786

diff --git a/bytecode.pl b/bytecode.pl
index 11e148c..f0763dd 100644 (file)
--- 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 d1a3d7a..d8ec4e3 100644 (file)
--- 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 bd130fe..3e73a1f 100644 (file)
--- 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 13f8510..7ba0236 100644 (file)
--- 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 8c82798..c8543f7 100644 (file)
--- 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 */