/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
LvTARGLEN(sv) = 0;
LvTARG(sv) = 0;
LvTYPE(sv) = 0;
+ GvGP(sv) = 0;
+ GvNAME(sv) = 0;
+ GvNAMELEN(sv) = 0;
+ GvSTASH(sv) = 0;
+ GvFLAGS(sv) = 0;
break;
case SVt_PVAV:
SvANY(sv) = new_XPVAV();
}
#endif /* !NV_PRESERVES_UV*/
+/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
+ * this function provided for binary compatibility only
+ */
+
+IV
+Perl_sv_2iv(pTHX_ register SV *sv)
+{
+ return sv_2iv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2iv
+=for apidoc sv_2iv_flags
-Return the integer value of an SV, doing any necessary string conversion,
-magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+Return the integer value of an SV, doing any necessary string
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
=cut
*/
IV
-Perl_sv_2iv(pTHX_ register SV *sv)
+Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvIOKp(sv))
return SvIVX(sv);
if (SvNOKp(sv)) {
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
+/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
+ * this function provided for binary compatibility only
+ */
+
+UV
+Perl_sv_2uv(pTHX_ register SV *sv)
+{
+ return sv_2uv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2uv
+=for apidoc sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
-conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
-macros.
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
=cut
*/
UV
-Perl_sv_2uv(pTHX_ register SV *sv)
+Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvIOKp(sv))
return SvUVX(sv);
if (SvNOKp(sv))
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
(void) sv_utf8_upgrade(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
+ if (SvREADONLY(sv)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
SvUTF8_off(sv);
}
if (dtype != SVt_PVGV) {
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
- sv_upgrade(dstr, SVt_PVGV);
+ /* don't upgrade SVt_PVLV: it can hold a glob */
+ if (dtype != SVt_PVLV)
+ sv_upgrade(dstr, SVt_PVGV);
sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
GvNAME(dstr) = savepvn(name, len);
}
else
new_SV(dstr);
- SvUPGRADE (dstr, SVt_PVIV);
+ (void)SvUPGRADE (dstr, SVt_PVIV);
assert (SvPOK(sstr));
assert (SvPOKp(sstr));
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
- SvUPGRADE (sstr, SVt_PVIV);
+ (void)SvUPGRADE (sstr, SVt_PVIV);
SvREADONLY_on(sstr);
SvFAKE_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
&& how != PERL_MAGIC_bm
&& how != PERL_MAGIC_fm
&& how != PERL_MAGIC_sv
+ && how != PERL_MAGIC_backref
)
{
Perl_croak(aTHX_ PL_no_modify);
* by magic_killbackrefs() when tsv is being freed */
}
if (AvFILLp(av) >= AvMAX(av)) {
+ I32 i;
SV **svp = AvARRAY(av);
- I32 i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i] == &PL_sv_undef) {
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (!svp[i]) {
svp[i] = sv; /* reuse the slot */
return;
}
- i--;
- }
av_extend(av, AvFILLp(av)+1);
}
AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i] == sv) {
- svp[i] = &PL_sv_undef; /* XXX */
- }
- i--;
- }
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (svp[i] == sv) svp[i] = Nullsv;
}
/*
nv = -nv;
if (nv < UV_MAX) {
nv += 0.5;
- uv = nv;
+ uv = (UV)nv;
if (uv & 1 && uv == nv)
uv--; /* Round to even */
do {
pp = pat + 2;
while (*pp >= '0' && *pp <= '9')
digits = 10 * digits + (*pp++ - '0');
- if (pp - pat == patlen - 1) {
+ if (pp - pat == (int)patlen - 1) {
NV nv;
if (args)
else if (args) {
switch (intsize) {
case 'h': iv = (short)va_arg(*args, int); break;
- default: iv = va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+ default: iv = va_arg(*args, int); break;
#ifdef HAS_QUAD
case 'q': iv = va_arg(*args, Quad_t); break;
#endif
}
}
else {
- iv = SvIVx(argsv);
+ IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': iv = (short)iv; break;
- default: break;
- case 'l': iv = (long)iv; break;
- case 'V': break;
+ case 'h': iv = (short)tiv; break;
+ case 'l': iv = (long)tiv; break;
+ case 'V':
+ default: iv = tiv; break;
#ifdef HAS_QUAD
- case 'q': iv = (Quad_t)iv; break;
+ case 'q': iv = (Quad_t)tiv; break;
#endif
}
}
else if (args) {
switch (intsize) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
- default: uv = va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+ default: uv = va_arg(*args, unsigned); break;
#ifdef HAS_QUAD
- case 'q': uv = va_arg(*args, Quad_t); break;
+ case 'q': uv = va_arg(*args, Uquad_t); break;
#endif
}
}
else {
- uv = SvUVx(argsv);
+ UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': uv = (unsigned short)uv; break;
- default: break;
- case 'l': uv = (unsigned long)uv; break;
- case 'V': break;
+ case 'h': uv = (unsigned short)tuv; break;
+ case 'l': uv = (unsigned long)tuv; break;
+ case 'V':
+ default: uv = tuv; break;
#ifdef HAS_QUAD
- case 'q': uv = (Quad_t)uv; break;
+ case 'q': uv = (Uquad_t)tuv; break;
#endif
}
}
continue; /* not "break" */
}
+ /* calculate width before utf8_upgrade changes it */
+ have = esignlen + zeros + elen;
+
if (is_utf8 != has_utf8) {
if (is_utf8) {
if (SvCUR(sv))
"Newline in left-justified string for %sprintf",
(PL_op->op_type == OP_PRTF) ? "" : "s");
- have = esignlen + zeros + elen;
need = (have > width ? have : width);
gap = need - have;
New(0, ret->offsets, 2*len+1, U32);
Copy(r->offsets, ret->offsets, 2*len+1, U32);
- ret->precomp = SAVEPV(r->precomp);
+ ret->precomp = SAVEPVN(r->precomp, r->prelen);
ret->refcnt = r->refcnt;
ret->minlen = r->minlen;
ret->prelen = r->prelen;
ret->sublen = r->sublen;
if (RX_MATCH_COPIED(ret))
- ret->subbeg = SAVEPV(r->subbeg);
+ ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
else
ret->subbeg = Nullch;
#ifdef PERL_COPY_ON_WRITE
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
- AV *av = (AV*) mg->mg_obj;
- SV **svp;
- I32 i;
- nmg->mg_obj = (SV*)newAV();
- svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
- av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
- i--;
- }
+ AV *av = (AV*) mg->mg_obj;
+ SV **svp;
+ I32 i;
+ SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
+ svp = AvARRAY(av);
+ for (i = AvFILLp(av); i >= 0; i--) {
+ if (!svp[i]) continue;
+ av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
+ }
}
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
GvHV(gv) = (HV*)sv;
}
else {
- SvREADONLY_on(GvAV(gv));
+ SvREADONLY_on(GvHV(gv));
}
return sstr; /* he_dup() will SvREFCNT_inc() */
SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
}
- CvGV(dstr) = gv_dup(CvGV(sstr), param);
+ /* don't dup if copying back - CvGV isn't refcounted, so the
+ * duped GV may never be freed. A bit of a hack! DAPM */
+ CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
+ Nullgv : gv_dup(CvGV(sstr), param) ;
if (param->flags & CLONEf_COPY_STACKS) {
CvDEPTH(dstr) = CvDEPTH(sstr);
} else {
PL_egid = proto_perl->Iegid;
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
- PL_op_seqmax = proto_perl->Iop_seqmax;
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
PL_last_swash_tmps = (U8*)NULL;
PL_last_swash_slen = 0;
- /* perly.c globals */
- PL_yydebug = proto_perl->Iyydebug;
- PL_yynerrs = proto_perl->Iyynerrs;
- PL_yyerrflag = proto_perl->Iyyerrflag;
- PL_yychar = proto_perl->Iyychar;
- PL_yyval = proto_perl->Iyyval;
- PL_yylval = proto_perl->Iyylval;
-
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
PL_hash_seed = proto_perl->Ihash_seed;
https://perl5.git.perl.org / perl5.git / blobdiff