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 */
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;
}
{
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));
}
) {
#ifdef USE_LOCALE_NUMERIC
if (specialradix)
- s += SvCUR(PL_numeric_radix);
+ s += SvCUR(PL_numeric_radix_sv);
else
#endif
s++;
) {
#ifdef USE_LOCALE_NUMERIC
if (specialradix)
- s += SvCUR(PL_numeric_radix);
+ s += SvCUR(PL_numeric_radix_sv);
else
#endif
s++;
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;
}
if (!sv)
return 0;
- if (!SvPOK(sv))
- (void) SvPV_nolen(sv);
+ if (!SvPOK(sv)) {
+ STRLEN len = 0;
+ (void) sv_2pv(sv,&len);
+ 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);
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;
}
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;
=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
*/
=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)
{
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);
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++;
}
#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;
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, ...)
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_BYTE) {
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;
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff