if (PL_nice_chunk) {
sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
}
else {
char *chunk; /* must use New here to match call to */
return sv;
}
-STATIC void
+STATIC I32
S_visit(pTHX_ SVFUNC_t f)
{
SV* sva;
SV* sv;
register SV* svend;
+ I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK)
+ if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
(FCALL)(aTHXo_ sv);
+ ++visited;
+ }
}
}
+ return visited;
}
void
PL_in_clean_objs = FALSE;
}
-void
+I32
Perl_sv_clean_all(pTHX)
{
+ I32 cleaned;
PL_in_clean_all = TRUE;
- visit(do_clean_all);
+ cleaned = visit(do_clean_all);
PL_in_clean_all = FALSE;
+ return cleaned;
}
void
{
char tmpbuf[64];
char *d = tmpbuf;
- char *s;
char *limit = tmpbuf + sizeof(tmpbuf) - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
- for (s = SvPVX(sv); *s && d < limit; s++) {
+ char *s, *end;
+ for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
int ch = *s & 0xFF;
if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
*d++ = '\\';
*d++ = '\\';
}
+ else if (ch == '\0') {
+ *d++ = '\\';
+ *d++ = '0';
+ }
else if (isPRINT_LC(ch))
*d++ = ch;
else {
*d++ = toCTRL(ch);
}
}
- if (*s) {
+ if (s < end) {
*d++ = '.';
*d++ = '.';
*d++ = '.';
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvUV(tmpstr);
return PTR2UV(SvRV(sv));
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvNV(tmpstr);
return PTR2NV(SvRV(sv));
}
}
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);
+ s += SvCUR(PL_numeric_radix_sv);
else
#endif
s++;
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)
- s += SvCUR(PL_numeric_radix);
+ s += SvCUR(PL_numeric_radix_sv);
else
#endif
s++;
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);
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvPV(tmpstr,*lp);
sv = (SV*)SvRV(sv);
if (!sv)
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_RMG))
&& strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
- && (mg = mg_find(sv, 'r'))) {
+ && (mg = mg_find(sv, PERL_MAGIC_qr))) {
regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
if (SvROK(sv)) {
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
- (SvRV(tmpsv) != SvRV(sv)))
+ (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
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 (!sv)
return 0;
- if (!SvPOK(sv))
- (void) SvPV_nolen(sv);
+ if (!SvPOK(sv)) {
+ STRLEN len = 0;
+ (void) sv_2pv_flags(sv,&len, flags);
+ if (!SvPOK(sv))
+ return len;
+ }
if (SvUTF8(sv))
return SvCUR(sv);
e = (U8 *) SvEND(sv);
t = s;
while (t < e) {
- if ((hibit = !UTF8_IS_INVARIANT(*t++)))
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
break;
}
if (hibit) {
Safefree(s); /* No longer using what was there before. */
SvLEN(sv) = len; /* No longer know the real size. */
}
-#ifdef EBCDIC
- else {
- for (t = s; t < e; t++)
- *t = NATIVE_TO_ASCII(*t);
- }
-#endif
/* Mark as UTF-8 even if no hibit - saves scanning loop */
SvUTF8_on(sv);
return SvCUR(sv);
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;
return FALSE;
e = (U8 *) SvEND(sv);
while (c < e) {
- if (!UTF8_IS_INVARIANT(*c++)) {
+ U8 ch = *c++;
+ if (!UTF8_IS_INVARIANT(ch)) {
SvUTF8_on(sv);
break;
}
=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;
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
sv_upgrade(dstr, SVt_PVGV);
- sv_magic(dstr, dstr, '*', Nullch, 0);
+ sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
GvNAME(dstr) = savepvn(name, len);
GvNAMELEN(dstr) = len;
/* 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);
=for apidoc sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. Handles 'get' magic, but not
-'set' magic. See C<sv_catpvn_mg>.
+C<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=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);
}
}
=for apidoc sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF8 status set, then the bytes appended should be
+valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
-=cut
-*/
+=cut */
void
Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
MAGIC* mg;
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling && !strchr("gBf", how))
+ if (PL_curcop != &PL_compiling
+ /* XXX this used to be !strchr("gBf", how), which seems to
+ * implicity be equal to !strchr("gBf\0", how), ie \0 matches
+ * too. I find this suprising, but have hadded PERL_MAGIC_sv
+ * to the list of things to check - DAPM 19-May-01 */
+ && how != PERL_MAGIC_regex_global
+ && how != PERL_MAGIC_bm
+ && how != PERL_MAGIC_fm
+ && how != PERL_MAGIC_sv
+ )
+ {
Perl_croak(aTHX_ PL_no_modify);
+ }
}
- if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
+ if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
- if (how == 't')
+ if (how == PERL_MAGIC_taint)
mg->mg_len |= 1;
return;
}
each other. To prevent a avoid a reference loop that would prevent such
objects being freed, we look for such loops and if we find one we avoid
incrementing the object refcount. */
- if (!obj || obj == sv || how == '#' || how == 'r' ||
+ if (!obj || obj == sv ||
+ how == PERL_MAGIC_arylen ||
+ how == PERL_MAGIC_qr ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
}
switch (how) {
- case 0:
+ case PERL_MAGIC_sv:
mg->mg_virtual = &PL_vtbl_sv;
break;
- case 'A':
+ case PERL_MAGIC_overload:
mg->mg_virtual = &PL_vtbl_amagic;
break;
- case 'a':
+ case PERL_MAGIC_overload_elem:
mg->mg_virtual = &PL_vtbl_amagicelem;
break;
- case 'c':
+ case PERL_MAGIC_overload_table:
mg->mg_virtual = &PL_vtbl_ovrld;
break;
- case 'B':
+ case PERL_MAGIC_bm:
mg->mg_virtual = &PL_vtbl_bm;
break;
- case 'D':
+ case PERL_MAGIC_regdata:
mg->mg_virtual = &PL_vtbl_regdata;
break;
- case 'd':
+ case PERL_MAGIC_regdatum:
mg->mg_virtual = &PL_vtbl_regdatum;
break;
- case 'E':
+ case PERL_MAGIC_env:
mg->mg_virtual = &PL_vtbl_env;
break;
- case 'f':
+ case PERL_MAGIC_fm:
mg->mg_virtual = &PL_vtbl_fm;
break;
- case 'e':
+ case PERL_MAGIC_envelem:
mg->mg_virtual = &PL_vtbl_envelem;
break;
- case 'g':
+ case PERL_MAGIC_regex_global:
mg->mg_virtual = &PL_vtbl_mglob;
break;
- case 'I':
+ case PERL_MAGIC_isa:
mg->mg_virtual = &PL_vtbl_isa;
break;
- case 'i':
+ case PERL_MAGIC_isaelem:
mg->mg_virtual = &PL_vtbl_isaelem;
break;
- case 'k':
+ case PERL_MAGIC_nkeys:
mg->mg_virtual = &PL_vtbl_nkeys;
break;
- case 'L':
+ case PERL_MAGIC_dbfile:
SvRMAGICAL_on(sv);
mg->mg_virtual = 0;
break;
- case 'l':
+ case PERL_MAGIC_dbline:
mg->mg_virtual = &PL_vtbl_dbline;
break;
#ifdef USE_THREADS
- case 'm':
+ case PERL_MAGIC_mutex:
mg->mg_virtual = &PL_vtbl_mutex;
break;
#endif /* USE_THREADS */
#ifdef USE_LOCALE_COLLATE
- case 'o':
+ case PERL_MAGIC_collxfrm:
mg->mg_virtual = &PL_vtbl_collxfrm;
break;
#endif /* USE_LOCALE_COLLATE */
- case 'P':
+ case PERL_MAGIC_tied:
mg->mg_virtual = &PL_vtbl_pack;
break;
- case 'p':
- case 'q':
+ case PERL_MAGIC_tiedelem:
+ case PERL_MAGIC_tiedscalar:
mg->mg_virtual = &PL_vtbl_packelem;
break;
- case 'r':
+ case PERL_MAGIC_qr:
mg->mg_virtual = &PL_vtbl_regexp;
break;
- case 'S':
+ case PERL_MAGIC_sig:
mg->mg_virtual = &PL_vtbl_sig;
break;
- case 's':
+ case PERL_MAGIC_sigelem:
mg->mg_virtual = &PL_vtbl_sigelem;
break;
- case 't':
+ case PERL_MAGIC_taint:
mg->mg_virtual = &PL_vtbl_taint;
mg->mg_len = 1;
break;
- case 'U':
+ case PERL_MAGIC_uvar:
mg->mg_virtual = &PL_vtbl_uvar;
break;
- case 'v':
+ case PERL_MAGIC_vec:
mg->mg_virtual = &PL_vtbl_vec;
break;
- case 'x':
+ case PERL_MAGIC_substr:
mg->mg_virtual = &PL_vtbl_substr;
break;
- case 'y':
+ case PERL_MAGIC_defelem:
mg->mg_virtual = &PL_vtbl_defelem;
break;
- case '*':
+ case PERL_MAGIC_glob:
mg->mg_virtual = &PL_vtbl_glob;
break;
- case '#':
+ case PERL_MAGIC_arylen:
mg->mg_virtual = &PL_vtbl_arylen;
break;
- case '.':
+ case PERL_MAGIC_pos:
mg->mg_virtual = &PL_vtbl_pos;
break;
- case '<':
+ case PERL_MAGIC_backref:
mg->mg_virtual = &PL_vtbl_backref;
break;
- case '~': /* Reserved for use by extensions not perl internals. */
+ case PERL_MAGIC_ext:
+ /* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
/* etc holding private data from one are passed to another. */
SvRMAGICAL_on(sv);
break;
default:
- Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
+ Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
}
mg_magical(sv);
if (SvGMAGICAL(sv))
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != 'g') {
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
}
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;
{
AV *av;
MAGIC *mg;
- if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
+ if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
av = (AV*)mg->mg_obj;
else {
av = newAV();
- sv_magic(tsv, (SV*)av, '<', NULL, 0);
+ sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
SvREFCNT_dec(av); /* for sv_magic */
}
av_push(av,sv);
I32 i;
SV *tsv = SvRV(sv);
MAGIC *mg;
- if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
+ if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
--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:
len = 0;
while (s < send) {
STRLEN n;
- /* We can use low level directly here as we are not looking at the values */
- if (utf8n_to_uvuni(s, UTF8SKIP(s), &n, 0)) {
+ /* Call utf8n_to_uvchr() to validate the sequence */
+ utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+ if (n > 0) {
s += n;
len++;
}
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;
#ifdef USE_LOCALE_COLLATE
/*
- * Any scalar variable may carry an 'o' magic that contains the
+ * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
* scalar data of the variable transformed to such a format that
* a normal memory comparison can be used to compare the data
* according to the locale settings.
{
MAGIC *mg;
- mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
+ mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
char *s, *xf;
STRLEN len, xlen;
return xf + sizeof(PL_collation_ix);
}
if (! mg) {
- sv_magic(sv, 0, 'o', 0, 0);
- mg = mg_find(sv, 'o');
+ sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
+ mg = mg_find(sv, PERL_MAGIC_collxfrm);
assert(mg);
}
mg->mg_ptr = xf;
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;
SvREFCNT_dec(GvSTASH(sv));
GvSTASH(sv) = Nullhv;
}
- sv_unmagic(sv, '*');
+ sv_unmagic(sv, PERL_MAGIC_glob);
Safefree(GvNAME(sv));
GvMULTI_off(sv);
void
Perl_sv_taint(pTHX_ SV *sv)
{
- sv_magic((sv), Nullsv, 't', Nullch, 0);
+ sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
}
void
Perl_sv_untaint(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC *mg = mg_find(sv, 't');
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
if (mg)
mg->mg_len &= ~1;
}
Perl_sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC *mg = mg_find(sv, 't');
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
return TRUE;
}
/*
=for apidoc sv_catpvf
-Processes its arguments like C<sprintf> and appends the formatted output
-to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
-typically be called after calling this function to handle 'set' magic.
+Processes its arguments like C<sprintf> and appends the formatted
+output to an SV. If the appended data contains "wide" characters
+(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
+and characters >255 formatted with %c), the original SV might get
+upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
+C<SvSETMAGIC()> must typically be called after calling this function
+to handle 'set' magic.
-=cut
-*/
+=cut */
void
Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
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;
case 'c':
uv = args ? va_arg(*args, int) : SvIVx(argsv);
- if ((uv > 255 || (!UTF8_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTE) {
+ if ((uv > 255 ||
+ (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
+ && !IN_BYTES) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
MAGIC *
Perl_mg_dup(pTHX_ MAGIC *mg)
{
- MAGIC *mgret = (MAGIC*)NULL;
- MAGIC *mgprev;
+ MAGIC *mgprev = (MAGIC*)NULL;
+ MAGIC *mgret;
if (!mg)
return (MAGIC*)NULL;
/* look for it in the table first */
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
Newz(0, nmg, 1, MAGIC);
- if (!mgret)
- mgret = nmg;
- else
+ if (mgprev)
mgprev->mg_moremagic = nmg;
+ else
+ mgret = nmg;
nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
nmg->mg_private = mg->mg_private;
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
- if (mg->mg_type == 'r') {
+ if (mg->mg_type == PERL_MAGIC_qr) {
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
}
else {
}
nmg->mg_len = mg->mg_len;
nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
- if (mg->mg_ptr && mg->mg_type != 'g') {
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0) {
nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
- if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
+ if (mg->mg_type == PERL_MAGIC_overload_table &&
+ AMT_AMAGIC((AMT*)mg->mg_ptr))
+ {
AMT *amtp = (AMT*)mg->mg_ptr;
AMT *namtp = (AMT*)nmg->mg_ptr;
I32 i;
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
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
- CvGV(dstr) = gv_dup_inc(CvGV(sstr));
+ CvGV(dstr) = gv_dup(CvGV(sstr));
CvDEPTH(dstr) = CvDEPTH(sstr);
if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
/* XXX padlists are real, but pretend to be not */
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
? av_dup_inc(cx->blk_sub.argarray)
: Nullav);
- ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
+ ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
TOPIV(nss,ix) = iv;
break;
case SAVEt_FREESV:
+ case SAVEt_MORTALIZESV:
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv);
break;
PL_defgv = gv_dup(proto_perl->Idefgv);
PL_argvgv = gv_dup(proto_perl->Iargvgv);
PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
- PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
+ PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
/* shortcuts to regexp stuff */
PL_replgv = gv_dup(proto_perl->Ireplgv);
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
- PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
+ PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
PL_regtill = Nullch;
- PL_regprev = '\n';
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
PL_regdata = (struct reg_data*)NULL;
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