diff options
| -rw-r--r-- | ext/B/B.pm | 3 | ||||
| -rw-r--r-- | ext/Devel/Peek/t/Peek.t | 22 | ||||
| -rw-r--r-- | lib/overload.t | 2 | ||||
| -rw-r--r-- | pp_hot.c | 1 | ||||
| -rw-r--r-- | regexec.c | 4 | ||||
| -rw-r--r-- | sv.c | 9 | ||||
| -rw-r--r-- | util.c | 2 |
7 files changed, 36 insertions, 7 deletions
diff --git a/ext/B/B.pm b/ext/B/B.pm index 9dc85bb4bf..7c498e4a6d 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -34,10 +34,11 @@ use strict; @B::IV::ISA = 'B::SV'; @B::NV::ISA = 'B::SV'; # RV is eliminated with 5.11.0, but effectively is a specialisation of IV now. -@B::RV::ISA = $] > 5.011 ? 'B::IV' : 'B::SV'; +@B::RV::ISA = $] >= 5.011 ? 'B::IV' : 'B::SV'; @B::PVIV::ISA = qw(B::PV B::IV); @B::PVNV::ISA = qw(B::PVIV B::NV); @B::PVMG::ISA = 'B::PVNV'; +@B::ORANGE::ISA = 'B::PVMG' if $] >= 5.011; # Change in the inheritance hierarchy post 5.9.0 @B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG'; # BM is eliminated post 5.9.5, but effectively is a specialisation of GV now. diff --git a/ext/Devel/Peek/t/Peek.t b/ext/Devel/Peek/t/Peek.t index 76118d1395..65937e75a7 100644 --- a/ext/Devel/Peek/t/Peek.t +++ b/ext/Devel/Peek/t/Peek.t @@ -275,6 +275,27 @@ do_test(14, \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2" OUTSIDE = $ADDR \\(MAIN\\)'); +if ($] >= 5.011) { +do_test(15, + qr(tic), +'SV = $RV\\($ADDR\\) at $ADDR + REFCNT = 1 + FLAGS = \\(ROK\\) + RV = $ADDR + SV = ORANGE\\($ADDR\\) at $ADDR + REFCNT = 1 + FLAGS = \\(OBJECT,SMG\\) + IV = 0 + NV = 0 + PV = 0 + MAGIC = $ADDR + MG_VIRTUAL = $ADDR + MG_TYPE = PERL_MAGIC_qr\(r\) + MG_OBJ = $ADDR + PAT = "\(\?-xism:tic\)" + REFCNT = 2 + STASH = $ADDR\\t"Regexp"'); +} else { do_test(15, qr(tic), 'SV = $RV\\($ADDR\\) at $ADDR @@ -294,6 +315,7 @@ do_test(15, PAT = "\(\?-xism:tic\)" REFCNT = 2 STASH = $ADDR\\t"Regexp"'); +} do_test(16, (bless {}, "Tac"), diff --git a/lib/overload.t b/lib/overload.t index 94cd296b44..fbaa4fd1ba 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -1125,7 +1125,7 @@ like ($@, qr/zap/); like(overload::StrVal(sub{1}), qr/^CODE\(0x[0-9a-f]+\)$/); like(overload::StrVal(\*GLOB), qr/^GLOB\(0x[0-9a-f]+\)$/); like(overload::StrVal(\$o), qr/^REF\(0x[0-9a-f]+\)$/); - like(overload::StrVal(qr/a/), qr/^Regexp=SCALAR\(0x[0-9a-f]+\)$/); + like(overload::StrVal(qr/a/), qr/^Regexp=ORANGE\(0x[0-9a-f]+\)$/); like(overload::StrVal($o), qr/^perl31793=ARRAY\(0x[0-9a-f]+\)$/); like(overload::StrVal($of), qr/^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/); like(overload::StrVal($no), qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/); @@ -1197,6 +1197,7 @@ PP(pp_qr) SV * const sv = newSVrv(rv, SvPV_nolen(pkg)); if (rx->extflags & RXf_TAINTED) SvTAINTED_on(rv); + sv_upgrade(sv, SVt_ORANGE); sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0); XPUSHs(rv); RETURN; @@ -3730,9 +3730,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog) re = CALLREGCOMP(ret, pm_flags); if (!(SvFLAGS(ret) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY - | SVs_GMG))) + | SVs_GMG))) { + SvUPGRADE(ret, SVt_ORANGE); sv_magic(ret,(SV*)ReREFCNT_inc(re), PERL_MAGIC_qr,0,0); + } PL_regsize = osize; } } @@ -916,8 +916,9 @@ static const struct body_details bodies_by_type[] = { { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - /* There are plans for this */ - { 0, 0, 0, SVt_ORANGE, FALSE, NONV, NOARENA, 0 }, + /* 28 */ + { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_ORANGE, FALSE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, @@ -1309,6 +1310,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: + case SVt_ORANGE: case SVt_PVMG: case SVt_PVNV: case SVt_PV: @@ -2696,7 +2698,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (!referent) { len = 7; retval = buffer = savepvn("NULLREF", len); - } else if (SvTYPE(referent) == SVt_PVMG + } else if (SvTYPE(referent) == SVt_ORANGE && ((SvFLAGS(referent) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_SMG)) @@ -7768,6 +7770,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; case SVt_BIND: return "BIND"; + case SVt_ORANGE: return "ORANGE"; default: return "UNKNOWN"; } } @@ -5921,7 +5921,7 @@ Perl_get_re_arg(pTHX_ SV *sv) { mg_get(sv); if (SvROK(sv) && (tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */ - SvTYPE(tmpsv) == SVt_PVMG && + SvTYPE(tmpsv) == SVt_ORANGE && (mg = mg_find(tmpsv, PERL_MAGIC_qr))) /* assign deliberate */ { return (REGEXP *)mg->mg_obj; |