}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvIOKp(sv) &&
+ if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
+ SvNOK_on(sv);
+ }
+ else if (SvIOKp(sv) &&
(!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
{
SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
UV_MAX= 18446744073709551615) so be cautious */
numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
- if (*s == '.'
+ if (
#ifdef USE_LOCALE_NUMERIC
- || (specialradix = IS_NUMERIC_RADIX(s))
+ (specialradix = IS_NUMERIC_RADIX(s, send)) ||
#endif
- ) {
+ *s == '.') {
#ifdef USE_LOCALE_NUMERIC
if (specialradix)
s += SvCUR(PL_numeric_radix_sv);
s++;
}
}
- else if (*s == '.'
+ else if (
#ifdef USE_LOCALE_NUMERIC
- || (specialradix = IS_NUMERIC_RADIX(s))
+ (specialradix = IS_NUMERIC_RADIX(s, send)) ||
#endif
+ *s == '.'
) {
#ifdef USE_LOCALE_NUMERIC
if (specialradix)
char *
Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
{
+ return sv_2pv_flags(sv, lp, SV_GMAGIC);
+}
+
+char *
+Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
+{
register char *s;
int olderrno;
SV *tsv;
return "";
}
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvPOKp(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_utf8_upgrade_flags
+
+Convert the PV of an SV to its UTF8-encoded form.
+Forces the SV to string form it it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
+will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+
+=cut
+*/
+
+STRLEN
+Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
+{
U8 *s, *t, *e;
int hibit = 0;
if (!SvPOK(sv)) {
STRLEN len = 0;
- (void) sv_2pv(sv,&len);
+ (void) sv_2pv_flags(sv,&len, flags);
if (!SvPOK(sv))
return len;
}
if (fail_ok)
return FALSE;
#ifdef USE_BYTES_DOWNGRADES
- else if (IN_BYTE) {
+ else if (IN_BYTES) {
U8 *d = s;
U8 *e = (U8 *) SvEND(sv);
int first = 1;
=cut
*/
+/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
+ for binary compatibility only
+*/
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
+ sv_setsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_setsv_flags
+
+Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
+The source SV may be destroyed if it is mortal. Does not handle 'set'
+magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
+appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
+in terms of this function.
+
+=cut
+*/
+
+void
+Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
+{
register U32 sflags;
register int dtype;
register int stype;
/* FALL THROUGH */
default:
- if (SvGMAGICAL(sstr)) {
+ if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
else {
/* len is STRLEN which is unsigned, need to copy to signed */
IV iv = len;
- assert(iv >= 0);
+ if (iv < 0)
+ Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
}
(void)SvUPGRADE(sv, SVt_PV);
=cut
*/
+/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
+ for binary compatibility only
+*/
void
-Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
{
- STRLEN tlen;
- char *junk;
+ sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
+}
- junk = SvPV_force(sv, tlen);
- SvGROW(sv, tlen + len + 1);
- if (ptr == junk)
- ptr = SvPVX(sv);
- Move(ptr,SvPVX(sv)+tlen,len,char);
- SvCUR(sv) += len;
- *SvEND(sv) = '\0';
- (void)SvPOK_only_UTF8(sv); /* validate pointer */
- SvTAINT(sv);
+/*
+=for apidoc sv_catpvn_flags
+
+Concatenates the string onto the end of the string which is in the SV. The
+C<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
+appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
+in terms of this function.
+
+=cut
+*/
+
+void
+Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
+{
+ STRLEN dlen;
+ char *dstr;
+
+ dstr = SvPV_force_flags(dsv, dlen, flags);
+ SvGROW(dsv, dlen + slen + 1);
+ if (sstr == dstr)
+ sstr = SvPVX(dsv);
+ Move(sstr, SvPVX(dsv) + dlen, slen, char);
+ SvCUR(dsv) += slen;
+ *SvEND(dsv) = '\0';
+ (void)SvPOK_only_UTF8(dsv); /* validate pointer */
+ SvTAINT(dsv);
}
/*
=cut */
+/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
+ for binary compatibility only
+*/
+void
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+{
+ sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_catsv_flags
+
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
+bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
+and C<sv_catsv_nomg> are implemented in terms of this function.
+
+=cut */
+
void
-Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
+Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
{
char *spv;
STRLEN slen;
if (!ssv)
return;
if ((spv = SvPV(ssv, slen))) {
- bool dutf8 = DO_UTF8(dsv);
bool sutf8 = DO_UTF8(ssv);
+ bool dutf8;
- if (dutf8 == sutf8)
- sv_catpvn(dsv,spv,slen);
- else {
+ if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
+ mg_get(dsv);
+ dutf8 = DO_UTF8(dsv);
+
+ if (dutf8 != sutf8) {
if (dutf8) {
/* Not modifying source SV, so taking a temporary copy. */
- SV* csv = sv_2mortal(newSVsv(ssv));
- char *cpv;
- STRLEN clen;
+ SV* csv = sv_2mortal(newSVpvn(spv, slen));
sv_utf8_upgrade(csv);
- cpv = SvPV(csv,clen);
- sv_catpvn(dsv,cpv,clen);
- }
- else {
- sv_utf8_upgrade(dsv);
- sv_catpvn(dsv,spv,slen);
- SvUTF8_on(dsv); /* If dsv has no wide characters. */
+ spv = SvPV(csv, slen);
}
+ else
+ sv_utf8_upgrade_nomg(dsv);
}
+ sv_catpvn_nomg(dsv, spv, slen);
}
}
}
if (!SvMAGIC(sv)) {
SvMAGICAL_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
return 0;
--PL_sv_objcount; /* XXX Might want something more general */
}
}
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
- mg_free(sv);
+ if (SvTYPE(sv) >= SVt_PVMG) {
+ if (SvMAGIC(sv))
+ mg_free(sv);
+ if (SvFLAGS(sv) & SVpad_TYPED)
+ SvREFCNT_dec(SvSTASH(sv));
+ }
stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVIO:
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
- if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
bool is_utf8 = TRUE;
/* UTF-8ness differs */
if (PL_hints & HINT_UTF8_DISTINCT)
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
- if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
if (PL_hints & HINT_UTF8_DISTINCT)
return SvUTF8(sv1) ? 1 : -1;
register STDCHAR rslast;
register STDCHAR *bp;
register I32 cnt;
- I32 i;
+ I32 i = 0;
SV_CHECK_THINKFIRST(sv);
(void)SvUPGRADE(sv, SVt_PV);
char *
Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
{
+ return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_pvn_force_flags
+
+Get a sensible string out of the SV somehow.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+implemented in terms of this function.
+
+=cut
+*/
+
+char *
+Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+{
char *s;
if (SvTHINKFIRST(sv) && !SvROK(sv))
PL_op_name[PL_op->op_type]);
}
else
- s = sv_2pv(sv, lp);
+ s = sv_2pv_flags(sv, lp, flags);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
STRLEN len = *lp;
STRLEN origlen;
I32 svix = 0;
static char nullstr[] = "(null)";
- SV *argsv;
+ SV *argsv = Nullsv;
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
STRLEN veclen = 0;
char c;
int i;
- unsigned base;
+ unsigned base = 0;
IV iv;
UV uv;
NV nv;
uv = args ? va_arg(*args, int) : SvIVx(argsv);
if ((uv > 255 ||
(!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
- && !IN_BYTE) {
+ && !IN_BYTES) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr))
+ : sv_dup_inc(SvRV(sstr));
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SV* rv;
if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
if (SvWEAKREF(sv)) {
sv_del_backref(sv);
SvWEAKREF_off(sv);
(GvIO(sv) && SvOBJECT(GvIO(sv))) ||
(GvCV(sv) && SvOBJECT(GvCV(sv))) )
{
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
SvREFCNT_dec(sv);
}
}
static void
do_clean_all(pTHXo_ SV *sv)
{
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
SvREFCNT_dec(sv);
}
https://perl5.git.perl.org / perl5.git / blobdiff