From: Nicholas Clark Date: Thu, 13 Apr 2006 12:40:24 +0000 (+0000) Subject: Fix B and ByteLoader to cope with cop_warnings no longer being an SV. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5c3c3f81c4e0c229b48dd3a3b920635017d32c46;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 */