This frees up a scalar type for first class regular expressions.
p4raw-id: //depot/perl@32734
"NULL",
"BIND",
"IV",
- "RV",
"NV",
"PV",
"PVIV",
"PVNV",
"PVMG",
+ "ORANGE",
"PVGV",
"PVLV",
"PVAV",
"UNDEF",
"BIND",
"IV",
- "RV",
"NV",
"PV",
"PVIV",
"PVNV",
"PVMG",
+ "ORANGE",
"GV",
"PVLV",
"AV",
}
if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
&& type != SVt_PVCV && !isGV_with_GP(sv))
- || type == SVt_IV) {
+ || (type == SVt_IV && !SvROK(sv))) {
if (SvIsUV(sv)
#ifdef PERL_OLD_COPY_ON_WRITE
|| SvIsCOW(sv)
case SVt_NV:
sv_catpv(t, " NV=\"");
break;
- case SVt_RV:
- sv_catpv(t, " RV=\"");
- break;
case SVt_PV:
sv_catpv(t, " PV=\"");
break;
case SVt_BIND:
sv_catpv(t, " BIND=\"");
break;
+ case SVt_ORANGE:
+ sv_catpv(t, " ORANGE=\"");
+ break;
case SVt_PVFM:
sv_catpv(t, " FM=\"");
break;
#
package B;
-our $VERSION = '1.17';
+our $VERSION = '1.18';
use XSLoader ();
require Exporter;
@B::PV::ISA = 'B::SV';
@B::IV::ISA = 'B::SV';
@B::NV::ISA = 'B::SV';
-@B::RV::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::PVIV::ISA = qw(B::PV B::IV);
@B::PVNV::ISA = qw(B::PVIV B::NV);
@B::PVMG::ISA = 'B::PVNV';
B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM (5.9.5 and
earlier), B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes
correspond in the obvious way to the underlying C structures of similar names.
-The inheritance hierarchy mimics the underlying C "inheritance". For 5.9.5
-and later this is:
+The inheritance hierarchy mimics the underlying C "inheritance". For the
+5.10, 5.10.1 I<etc> this is:
B::SV
|
B::PVLV B::FM
+For 5.11.0 and later, B::RV is abolished, and IVs can be used to store
+references.
+
For 5.9.0 and earlier, PVLV is a direct subclass of PVMG, and BM is still
present as a distinct type, so the base of this diagram is
"B::BIND",
#endif
"B::IV",
- "B::RV",
"B::NV",
+#if PERL_VERSION <= 10
+ "B::RV",
+#endif
"B::PV",
"B::PVIV",
"B::PVNV",
#if PERL_VERSION <= 8
"B::BM",
#endif
+#if PERL_VERSION >= 11
+ "B::ORANGE",
+#endif
#if PERL_VERSION >= 9
"B::GV",
#endif
ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
}
+
+#if PERL_VERSION >= 11
+
+B::SV
+RV(sv)
+ B::IV sv
+ CODE:
+ if( SvROK(sv) ) {
+ RETVAL = SvRV(sv);
+ }
+ else {
+ croak( "argument is not SvROK" );
+ }
+ OUTPUT:
+ RETVAL
+
+#endif
+
MODULE = B PACKAGE = B::NV PREFIX = Sv
NV
PARENT_FAKELEX_FLAGS(sv)
B::NV sv
+#if PERL_VERSION < 11
+
MODULE = B PACKAGE = B::RV PREFIX = Sv
B::SV
SvRV(sv)
B::RV sv
+#endif
+
MODULE = B PACKAGE = B::PV PREFIX = Sv
char*
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
- CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI);
+ CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);
my %style =
("terse" =>
$hr->{svval} = "*$stash" . $gv->SAFENAME;
return "*$stash" . $gv->SAFENAME;
} else {
- while (class($sv) eq "RV") {
- $hr->{svval} .= "\\";
- $sv = $sv->RV;
+ if ($] >= 5.011) {
+ while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) {
+ $hr->{svval} .= "\\";
+ $sv = $sv->RV;
+ }
+ } else {
+ while (class($sv) eq "RV") {
+ $hr->{svval} .= "\\";
+ $sv = $sv->RV;
+ }
}
if (class($sv) eq "SPECIAL") {
$hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR");
is($$null_ret, $nv, "Test object_2svref()");
+my $RV_class = $] >= 5.011 ? 'B::IV' : 'B::RV';
my $cv = sub{ 1; };
my $cv_ref = B::svref_2object(\$cv);
-is($cv_ref->REFCNT, 1, "Test B::RV->REFCNT");
-is(ref $cv_ref, "B::RV", "Test B::RV return from svref_2object - code");
+is($cv_ref->REFCNT, 1, "Test $RV_class->REFCNT");
+is(ref $cv_ref, "$RV_class",
+ "Test $RV_class return from svref_2object - code");
my $cv_ret = $cv_ref->object_2svref();
is(ref $cv_ret, "REF", "Test object_2svref() return is REF");
is($$cv_ret, $cv, "Test object_2svref()");
my $av = [];
my $av_ref = B::svref_2object(\$av);
-is(ref $av_ref, "B::RV", "Test B::RV return from svref_2object - array");
+is(ref $av_ref, "$RV_class",
+ "Test $RV_class return from svref_2object - array");
my $hv = [];
my $hv_ref = B::svref_2object(\$hv);
-is(ref $hv_ref, "B::RV", "Test B::RV return from svref_2object - hash");
+is(ref $hv_ref, "$RV_class",
+ "Test $RV_class return from svref_2object - hash");
local *gv = *STDOUT;
my $gv_ref = B::svref_2object(\*gv);
sub myno () { return 1!=1 }
sub pi () { 3.14159 };
+my $RV_class = $] >= 5.011 ? 'IV' : 'RV';
+
my $want = { # expected types, how value renders in-line, todos (maybe)
mystr => [ 'PV', '"'.mystr.'"' ],
- myhref => [ 'RV', '\\\\HASH'],
+ myhref => [ $RV_class, '\\\\HASH'],
pi => [ 'NV', pi ],
- myglob => [ 'RV', '\\\\' ],
- mysub => [ 'RV', '\\\\' ],
- myunsub => [ 'RV', '\\\\' ],
+ myglob => [ $RV_class, '\\\\' ],
+ mysub => [ $RV_class, '\\\\' ],
+ myunsub => [ $RV_class, '\\\\' ],
# these are not inlined, at least not per BC::Concise
- #myyes => [ 'RV', ],
- #myno => [ 'RV', ],
+ #myyes => [ $RV_class, ],
+ #myno => [ $RV_class, ],
$] > 5.009 ? (
- myaref => [ 'RV', '\\\\' ],
+ myaref => [ $RV_class, '\\\\' ],
myfl => [ 'NV', myfl ],
myint => [ 'IV', myint ],
- myrex => [ 'RV', '\\\\' ],
+ myrex => [ $RV_class, '\\\\' ],
myundef => [ 'NULL', ],
) : (
myaref => [ 'PVIV', '' ],
$path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
my $redir = $^O eq 'MacOS' ? '' : "2>&1";
my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
-like( $items, qr/RV $hex \\42/, 'RV' );
+if( $] >= 5.011 ) {
+ like( $items, qr/IV $hex \\42/, 'RV (but now stored in an IV)' );
+} else {
+ like( $items, qr/RV $hex \\42/, 'RV' );
+}
package TieOut;
$pattern =~ s/^ *\$IVNV *\n/
($] < 5.009) ? " IV = 0\n NV = 0\n" : '';
/mge;
+ $pattern =~ s/\$RV/IV/g if $] >= 5.011;
print $pattern, "\n" if $DEBUG;
my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
do_test(10,
\$a,
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
}
do_test(11,
[$b,$c],
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
do_test(12,
{$b=>$c},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
do_test(13,
sub(){@_},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
do_test(14,
\&do_test,
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
do_test(15,
qr(tic),
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
do_test(16,
(bless {}, "Tac"),
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
if (ord('A') == 193) {
do_test(19,
{chr(256)=>chr(512)},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
} else {
do_test(19,
{chr(256)=>chr(512)},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
# blessed refs
do_test(22,
bless(\\undef, 'Foobar'),
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
do_test(23,
\&const,
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = \\(ROK\\)
RV = $ADDR
{
switch (SvTYPE(sv)) {
case SVt_NULL:
+#if PERL_VERSION <= 10
case SVt_IV:
+#endif
case SVt_NV:
/*
* No need to check for ROK, that can't be set here since there
*/
return svis_SCALAR;
case SVt_PV:
+#if PERL_VERSION <= 10
case SVt_RV:
+#else
+ case SVt_IV:
+#endif
case SVt_PVIV:
case SVt_PVNV:
/*
const char * const name = CopSTASHPV(PL_curcop);
gv = newGVgen(name);
}
- if (SvTYPE(sv) < SVt_RV || SvTYPE(sv) == SVt_NV)
- sv_upgrade(sv, SVt_RV);
+ if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV)
+ sv_upgrade(sv, SVt_IV);
else if (SvPVX_const(sv)) {
SvPV_free(sv);
SvLEN_set(sv, 0);
SvREFCNT_inc_void_NN(sv);
}
rv = sv_newmortal();
- sv_upgrade(rv, SVt_RV);
+ sv_upgrade(rv, SVt_IV);
SvRV_set(rv, sv);
SvROK_on(rv);
return rv;
The gv becomes a(nother) reference to the constant. */
SV *const value = SvRV(cv);
- SvUPGRADE((SV *)gv, SVt_RV);
+ SvUPGRADE((SV *)gv, SVt_IV);
SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
Perl_croak(aTHX_ PL_no_modify);
- if (SvTYPE(sv) < SVt_RV || SvTYPE(sv) == SVt_NV)
- sv_upgrade(sv, SVt_RV);
+ if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV)
+ sv_upgrade(sv, SVt_IV);
else if (SvTYPE(sv) >= SVt_PV) {
SvPV_free(sv);
SvLEN_set(sv, 0);
FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
},
- /* RVs are in the head now. */
- { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
-
/* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
FIT_ARENA(0, sizeof(NV)) },
/* 28 */
{ 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 },
+
/* 48 */
{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
const struct body_details *new_type_details;
const struct body_details *const old_type_details
= bodies_by_type + old_type;
+ SV *referant = NULL;
if (new_type != SVt_PV && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
if (old_type == new_type)
return;
- if (old_type == SVt_RV) {
- /* Verify my assumption that no-one upgrades a scalar which has a
- referant but isn't flagged as a reference. */
- assert(!(!SvROK(sv) && SvRV(sv)));
- }
-
old_body = SvANY(sv);
/* Copying structures onto other structures that have been neatly zeroed
case SVt_NULL:
break;
case SVt_IV:
- if (new_type < SVt_PVIV) {
- new_type = (new_type == SVt_NV)
- ? SVt_PVNV : SVt_PVIV;
+ if (SvROK(sv)) {
+ referant = SvRV(sv);
+ if (new_type < SVt_PVIV) {
+ new_type = SVt_PVIV;
+ /* FIXME to check SvROK(sv) ? SVt_PV : and fake up
+ old_body_details */
+ }
+ } else {
+ if (new_type < SVt_PVIV) {
+ new_type = (new_type == SVt_NV)
+ ? SVt_PVNV : SVt_PVIV;
+ }
}
break;
case SVt_NV:
new_type = SVt_PVNV;
}
break;
- case SVt_RV:
- break;
case SVt_PV:
assert(new_type > SVt_PV);
assert(SVt_IV < SVt_PV);
SvANY(sv) = new_XNV();
SvNV_set(sv, 0);
return;
- case SVt_RV:
- assert(old_type == SVt_NULL);
- SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
- /* Could leave this in, but changing it happens to make the next step
- clearler. The key part is that SvANY(sv) is not NULL:
- SvANY(sv) = &sv->sv_u.svu_rv;
- */
- SvRV_set(sv, 0);
- return;
case SVt_PVHV:
case SVt_PVAV:
assert(new_type_details->body_size);
The target created by newSVrv also is, and it can have magic.
However, it never has SvPVX set.
*/
- if (old_type == SVt_RV || old_type >= SVt_PV) {
+ if (old_type == SVt_IV) {
+ assert(!SvROK(sv));
+ } else if (old_type >= SVt_PV) {
assert(SvPVX_const(sv) == 0);
}
if (new_type == SVt_PVIO)
IoPAGE_LEN(sv) = 60;
- if (old_type < SVt_RV || old_type == SVt_NV)
- SvPV_set(sv, NULL);
+ if (old_type < SVt_PV) {
+ /* referant will be NULL unless the old type was SVt_IV emulating
+ SVt_RV */
+ sv->sv_u.svu_rv = referant;
+ }
break;
default:
Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
case SVt_NV:
sv_upgrade(sv, SVt_IV);
break;
- case SVt_RV:
case SVt_PV:
sv_upgrade(sv, SVt_PVIV);
break;
case SVt_IV:
sv_upgrade(sv, SVt_NV);
break;
- case SVt_RV:
case SVt_PV:
case SVt_PVIV:
sv_upgrade(sv, SVt_PVNV);
sv_upgrade(dstr, SVt_IV);
break;
case SVt_NV:
- case SVt_RV:
case SVt_PV:
sv_upgrade(dstr, SVt_PVIV);
break;
assert(!SvTAINTED(sstr));
return;
}
- goto undef_sstr;
+ if (!SvROK(sstr))
+ goto undef_sstr;
+ if (dtype < SVt_PV && dtype != SVt_IV)
+ sv_upgrade(dstr, SVt_IV);
+ break;
case SVt_NV:
if (SvNOK(sstr)) {
case SVt_IV:
sv_upgrade(dstr, SVt_NV);
break;
- case SVt_RV:
case SVt_PV:
case SVt_PVIV:
sv_upgrade(dstr, SVt_PVNV);
}
goto undef_sstr;
- case SVt_RV:
- if (dtype < SVt_PV && dtype != SVt_RV)
- sv_upgrade(dstr, SVt_RV);
- break;
case SVt_PVFM:
#ifdef PERL_OLD_COPY_ON_WRITE
if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
#else
StructCopy(nsv,sv,SV);
#endif
- /* Currently could join these into one piece of pointer arithmetic, but
- it would be unclear. */
- if(SvTYPE(sv) == SVt_IV)
+ if(SvTYPE(sv) == SVt_IV) {
SvANY(sv)
= (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
- else if (SvTYPE(sv) == SVt_RV) {
- SvANY(sv) = &sv->sv_u.svu_rv;
}
/* See the comment in sv.h about the collusion between this early
return and the overloading of the NULL and IV slots in the size
table. */
+ if (SvROK(sv)) {
+ SV * const target = SvRV(sv);
+ if (SvWEAKREF(sv))
+ sv_del_backref(target, sv);
+ else
+ SvREFCNT_dec(target);
+ }
+ SvFLAGS(sv) &= SVf_BREAK;
+ SvFLAGS(sv) |= SVTYPEMASK;
return;
}
/* Don't even bother with turning off the OOK flag. */
}
case SVt_PV:
- case SVt_RV:
if (SvROK(sv)) {
SV * const target = SvRV(sv);
if (SvWEAKREF(sv))
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
dVAR;
- register SV *sv = newSV_type(SVt_RV);
+ register SV *sv = newSV_type(SVt_IV);
SvTEMP_off(tmpRef);
SvRV_set(sv, tmpRef);
SvROK_on(sv);
case SVt_NULL:
case SVt_IV:
case SVt_NV:
- case SVt_RV:
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
SvFLAGS(rv) = 0;
SvREFCNT(rv) = refcnt;
- sv_upgrade(rv, SVt_RV);
+ sv_upgrade(rv, SVt_IV);
} else if (SvROK(rv)) {
SvREFCNT_dec(SvRV(rv));
- } else if (SvTYPE(rv) < SVt_RV || SvTYPE(rv) == SVt_NV)
- sv_upgrade(rv, SVt_RV);
- else if (SvTYPE(rv) > SVt_RV) {
+ } else if (SvTYPE(rv) < SVt_PV && SvTYPE(rv) != SVt_IV)
+ sv_upgrade(rv, SVt_IV);
+ else if (SvTYPE(rv) >= SVt_PV) {
SvPV_free(rv);
SvCUR_set(rv, 0);
SvLEN_set(rv, 0);
}
else {
/* Copy the NULL */
- if (SvTYPE(dstr) == SVt_RV)
- SvRV_set(dstr, NULL);
- else
- SvPV_set(dstr, NULL);
+ SvPV_set(dstr, NULL);
}
}
break;
case SVt_IV:
SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
- SvIV_set(dstr, SvIVX(sstr));
+ if(SvROK(sstr)) {
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
+ } else {
+ SvIV_set(dstr, SvIVX(sstr));
+ }
break;
case SVt_NV:
SvANY(dstr) = new_XNV();
SvNV_set(dstr, SvNVX(sstr));
break;
- case SVt_RV:
- SvANY(dstr) = &(dstr->sv_u.svu_rv);
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- break;
/* case SVt_BIND: */
default:
{
SVt_NULL, /* 0 */
SVt_BIND, /* 1 */
SVt_IV, /* 2 */
- SVt_RV, /* 3 */
- SVt_NV, /* 4 */
- SVt_PV, /* 5 */
- SVt_PVIV, /* 6 */
- SVt_PVNV, /* 7 */
- SVt_PVMG, /* 8 */
+ SVt_NV, /* 3 */
+ /* RV was here, before it was merged with IV. */
+ SVt_PV, /* 4 */
+ SVt_PVIV, /* 5 */
+ SVt_PVNV, /* 6 */
+ SVt_PVMG, /* 7 */
+ SVt_ORANGE, /* 8 */
/* PVBM was here, before BIND replaced it. */
SVt_PVGV, /* 9 */
SVt_PVLV, /* 10 */
purposes eternal code wanting to consider PVBM probably needs to think of
PVMG instead. */
# define SVt_PVBM SVt_PVMG
+/* Anything wanting to create a reference from clean should ensure that it has
+ a scalar of type SVt_IV now: */
+# define SVt_RV SVt_IV
#endif
/* There is collusion here with sv_clear - sv_clear exits early for SVt_NULL
}))
# define SvRV(sv) \
(*({ SV *const _svi = (SV *) (sv); \
- assert(SvTYPE(_svi) >= SVt_PV || SvTYPE(_svi) == SVt_RV); \
+ assert(SvTYPE(_svi) >= SVt_PV || SvTYPE(_svi) == SVt_IV); \
assert(SvTYPE(_svi) != SVt_PVAV); \
assert(SvTYPE(_svi) != SVt_PVHV); \
assert(SvTYPE(_svi) != SVt_PVCV); \
assert(!isGV_with_GP(sv)); \
(((XPVUV*)SvANY(sv))->xuv_uv = (val)); } STMT_END
#define SvRV_set(sv, val) \
- STMT_START { assert(SvTYPE(sv) >= SVt_PV || SvTYPE(sv) == SVt_RV); \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV || SvTYPE(sv) == SVt_IV); \
assert(SvTYPE(sv) != SVt_PVAV); \
assert(SvTYPE(sv) != SVt_PVHV); \
assert(SvTYPE(sv) != SVt_PVCV); \