/* 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.
if (!ok) {
if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free non-arena SV: 0x%"UVxf,
- PTR2UV(p));
+ "Attempt to free non-arena SV: 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
return;
}
}
return sv;
}
-/* visit(): call the named function for each non-free SV in the arenas. */
+/* visit(): call the named function for each non-free SV in the arenas
+ * whose flags field matches the flags/mask args. */
STATIC I32
-S_visit(pTHX_ SVFUNC_t f)
+S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
{
SV* sva;
SV* sv;
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 && SvREFCNT(sv)) {
+ if (SvTYPE(sv) != SVTYPEMASK
+ && (sv->sv_flags & mask) == flags
+ && SvREFCNT(sv))
+ {
(FCALL)(aTHX_ sv);
++visited;
}
Perl_sv_report_used(pTHX)
{
#ifdef DEBUGGING
- visit(do_report_used);
+ visit(do_report_used, 0, 0);
#endif
}
(GvCV(sv) && SvOBJECT(GvCV(sv))) )
{
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
+ SvFLAGS(sv) |= SVf_BREAK;
SvREFCNT_dec(sv);
}
}
Perl_sv_clean_objs(pTHX)
{
PL_in_clean_objs = TRUE;
- visit(do_clean_objs);
+ visit(do_clean_objs, SVf_ROK, SVf_ROK);
#ifndef DISABLE_DESTRUCTOR_KLUDGE
/* some barnacles may yet remain, clinging to typeglobs */
- visit(do_clean_named_objs);
+ visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
#endif
PL_in_clean_objs = FALSE;
}
{
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
+ if (PL_comppad == (AV*)sv) {
+ PL_comppad = Nullav;
+ PL_curpad = Null(SV**);
+ }
SvREFCNT_dec(sv);
}
{
I32 cleaned;
PL_in_clean_all = TRUE;
- cleaned = visit(do_clean_all);
+ cleaned = visit(do_clean_all, 0,0);
PL_in_clean_all = FALSE;
return cleaned;
}
PL_sv_root = 0;
}
+/* ---------------------------------------------------------------------
+ *
+ * support functions for report_uninit()
+ */
+
+/* the maxiumum size of array or hash where we will scan looking
+ * for the undefined element that triggered the warning */
+
+#define FUV_MAX_SEARCH_SIZE 1000
+
+/* Look for an entry in the hash whose value has the same SV as val;
+ * If so, return a mortal copy of the key. */
+
+STATIC SV*
+S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+{
+ register HE **array;
+ register HE *entry;
+ I32 i;
+
+ if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
+ (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
+ return Nullsv;
+
+ array = HvARRAY(hv);
+
+ for (i=HvMAX(hv); i>0; i--) {
+ for (entry = array[i]; entry; entry = HeNEXT(entry)) {
+ if (HeVAL(entry) != val)
+ continue;
+ if ( HeVAL(entry) == &PL_sv_undef ||
+ HeVAL(entry) == &PL_sv_placeholder)
+ continue;
+ if (!HeKEY(entry))
+ return Nullsv;
+ if (HeKLEN(entry) == HEf_SVKEY)
+ return sv_mortalcopy(HeKEY_sv(entry));
+ return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
+ }
+ }
+ return Nullsv;
+}
+
+/* Look for an entry in the array whose value has the same SV as val;
+ * If so, return the index, otherwise return -1. */
+
+STATIC I32
+S_find_array_subscript(pTHX_ AV *av, SV* val)
+{
+ SV** svp;
+ I32 i;
+ if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
+ (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
+ return -1;
+
+ svp = AvARRAY(av);
+ for (i=AvFILLp(av); i>=0; i--) {
+ if (svp[i] == val && svp[i] != &PL_sv_undef)
+ return i;
+ }
+ return -1;
+}
+
+/* S_varname(): return the name of a variable, optionally with a subscript.
+ * If gv is non-zero, use the name of that global, along with gvtype (one
+ * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
+ * targ. Depending on the value of the subscript_type flag, return:
+ */
+
+#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
+#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
+#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
+#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
+
+STATIC SV*
+S_varname(pTHX_ GV *gv, char *gvtype, PADOFFSET targ,
+ SV* keyname, I32 aindex, int subscript_type)
+{
+ AV *av;
+
+ SV *sv, *name;
+
+ name = sv_newmortal();
+ if (gv) {
+
+ /* simulate gv_fullname4(), but add literal '^' for $^FOO names
+ * XXX get rid of all this if gv_fullnameX() ever supports this
+ * directly */
+
+ char *p;
+ HV *hv = GvSTASH(gv);
+ sv_setpv(name, gvtype);
+ if (!hv)
+ p = "???";
+ else if (!HvNAME(hv))
+ p = "__ANON__";
+ else
+ p = HvNAME(hv);
+ if (strNE(p, "main")) {
+ sv_catpv(name,p);
+ sv_catpvn(name,"::", 2);
+ }
+ if (GvNAMELEN(gv)>= 1 &&
+ ((unsigned int)*GvNAME(gv)) <= 26)
+ { /* handle $^FOO */
+ Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
+ sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
+ }
+ else
+ sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
+ }
+ else {
+ U32 u;
+ CV *cv = find_runcv(&u);
+ if (!cv || !CvPADLIST(cv))
+ return Nullsv;;
+ av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
+ sv = *av_fetch(av, targ, FALSE);
+ /* SvLEN in a pad name is not to be trusted */
+ sv_setpv(name, SvPV_nolen(sv));
+ }
+
+ if (subscript_type == FUV_SUBSCRIPT_HASH) {
+ *SvPVX(name) = '$';
+ sv = NEWSV(0,0);
+ Perl_sv_catpvf(aTHX_ name, "{%s}",
+ pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
+ SvREFCNT_dec(sv);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
+ *SvPVX(name) = '$';
+ Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
+ sv_insert(name, 0, 0, "within ", 7);
+
+ return name;
+}
+
+
+/*
+=for apidoc find_uninit_var
+
+Find the name of the undefined variable (if any) that caused the operator o
+to issue a "Use of uninitialized value" warning.
+If match is true, only return a name if it's value matches uninit_sv.
+So roughly speaking, if a unary operator (such as OP_COS) generates a
+warning, then following the direct child of the op may yield an
+OP_PADSV or OP_GV that gives the name of the undefined variable. On the
+other hand, with OP_ADD there are two branches to follow, so we only print
+the variable name if we get an exact match.
+
+The name is returned as a mortal SV.
+
+Assumes that PL_op is the op that originally triggered the error, and that
+PL_comppad/PL_curpad points to the currently executing pad.
+
+=cut
+*/
+
+STATIC SV *
+S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
+{
+ SV *sv;
+ AV *av;
+ SV **svp;
+ GV *gv;
+ OP *o, *o2, *kid;
+
+ if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
+ uninit_sv == &PL_sv_placeholder)))
+ return Nullsv;
+
+ switch (obase->op_type) {
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ case OP_PADAV:
+ case OP_PADHV:
+ {
+ bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
+ bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ I32 index;
+ SV *keysv;
+ int subscript_type = FUV_SUBSCRIPT_WITHIN;
+
+ if (pad) { /* @lex, %lex */
+ sv = PAD_SVl(obase->op_targ);
+ gv = Nullgv;
+ }
+ else {
+ if (cUNOPx(obase)->op_first->op_type == OP_GV) {
+ /* @global, %global */
+ gv = cGVOPx_gv(cUNOPx(obase)->op_first);
+ if (!gv)
+ break;
+ sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
+ }
+ else /* @{expr}, %{expr} */
+ return find_uninit_var(cUNOPx(obase)->op_first,
+ uninit_sv, match);
+ }
+
+ /* attempt to find a match within the aggregate */
+ if (hash) {
+ keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ if (keysv)
+ subscript_type = FUV_SUBSCRIPT_HASH;
+ }
+ else {
+ index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ if (index >= 0)
+ subscript_type = FUV_SUBSCRIPT_ARRAY;
+ }
+
+ if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
+ break;
+
+ return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
+ keysv, index, subscript_type);
+ }
+
+ case OP_PADSV:
+ if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+ break;
+ return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
+ Nullsv, 0, FUV_SUBSCRIPT_NONE);
+
+ case OP_GVSV:
+ gv = cGVOPx_gv(obase);
+ if (!gv || (match && GvSV(gv) != uninit_sv))
+ break;
+ return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
+
+ case OP_AELEMFAST:
+ if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
+ if (match) {
+ av = (AV*)PAD_SV(obase->op_targ);
+ if (!av || SvRMAGICAL(av))
+ break;
+ svp = av_fetch(av, (I32)obase->op_private, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
+ Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ }
+ else {
+ gv = cGVOPx_gv(obase);
+ if (!gv)
+ break;
+ if (match) {
+ av = GvAV(gv);
+ if (!av || SvRMAGICAL(av))
+ break;
+ svp = av_fetch(av, (I32)obase->op_private, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ return S_varname(aTHX_ gv, "$", 0,
+ Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ }
+ break;
+
+ case OP_EXISTS:
+ o = cUNOPx(obase)->op_first;
+ if (!o || o->op_type != OP_NULL ||
+ ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
+ break;
+ return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
+
+ case OP_AELEM:
+ case OP_HELEM:
+ if (PL_op == obase)
+ /* $a[uninit_expr] or $h{uninit_expr} */
+ return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
+
+ gv = Nullgv;
+ o = cBINOPx(obase)->op_first;
+ kid = cBINOPx(obase)->op_last;
+
+ /* get the av or hv, and optionally the gv */
+ sv = Nullsv;
+ if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
+ sv = PAD_SV(o->op_targ);
+ }
+ else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
+ && cUNOPo->op_first->op_type == OP_GV)
+ {
+ gv = cGVOPx_gv(cUNOPo->op_first);
+ if (!gv)
+ break;
+ sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
+ }
+ if (!sv)
+ break;
+
+ if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
+ /* index is constant */
+ if (match) {
+ if (SvMAGICAL(sv))
+ break;
+ if (obase->op_type == OP_HELEM) {
+ HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
+ if (!he || HeVAL(he) != uninit_sv)
+ break;
+ }
+ else {
+ svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ }
+ if (obase->op_type == OP_HELEM)
+ return S_varname(aTHX_ gv, "%", o->op_targ,
+ cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
+ else
+ return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
+ SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
+ ;
+ }
+ else {
+ /* index is an expression;
+ * attempt to find a match within the aggregate */
+ if (obase->op_type == OP_HELEM) {
+ SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ if (keysv)
+ return S_varname(aTHX_ gv, "%", o->op_targ,
+ keysv, 0, FUV_SUBSCRIPT_HASH);
+ }
+ else {
+ I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ if (index >= 0)
+ return S_varname(aTHX_ gv, "@", o->op_targ,
+ Nullsv, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ if (match)
+ break;
+ return S_varname(aTHX_ gv,
+ (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
+ ? "@" : "%",
+ o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
+ }
+
+ break;
+
+ case OP_AASSIGN:
+ /* only examine RHS */
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+
+ case OP_OPEN:
+ o = cUNOPx(obase)->op_first;
+ if (o->op_type == OP_PUSHMARK)
+ o = o->op_sibling;
+
+ if (!o->op_sibling) {
+ /* one-arg version of open is highly magical */
+
+ if (o->op_type == OP_GV) { /* open FOO; */
+ gv = cGVOPx_gv(o);
+ if (match && GvSV(gv) != uninit_sv)
+ break;
+ return S_varname(aTHX_ gv, "$", 0,
+ Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ }
+ /* other possibilities not handled are:
+ * open $x; or open my $x; should return '${*$x}'
+ * open expr; should return '$'.expr ideally
+ */
+ break;
+ }
+ goto do_op;
+
+ /* ops where $_ may be an implicit arg */
+ case OP_TRANS:
+ case OP_SUBST:
+ case OP_MATCH:
+ if ( !(obase->op_flags & OPf_STACKED)) {
+ if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
+ ? PAD_SVl(obase->op_targ)
+ : DEFSV))
+ {
+ sv = sv_newmortal();
+ sv_setpv(sv, "$_");
+ return sv;
+ }
+ }
+ goto do_op;
+
+ case OP_PRTF:
+ case OP_PRINT:
+ /* skip filehandle as it can't produce 'undef' warning */
+ o = cUNOPx(obase)->op_first;
+ if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+ o = o->op_sibling->op_sibling;
+ goto do_op2;
+
+
+ case OP_RV2SV:
+ case OP_CUSTOM:
+ case OP_ENTERSUB:
+ match = 1; /* XS or custom code could trigger random warnings */
+ goto do_op;
+
+ case OP_SCHOMP:
+ case OP_CHOMP:
+ if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
+ return sv_2mortal(newSVpv("${$/}", 0));
+ /* FALL THROUGH */
+
+ default:
+ do_op:
+ if (!(obase->op_flags & OPf_KIDS))
+ break;
+ o = cUNOPx(obase)->op_first;
+
+ do_op2:
+ if (!o)
+ break;
+
+ /* if all except one arg are constant, or have no side-effects,
+ * or are optimized away, then it's unambiguous */
+ o2 = Nullop;
+ for (kid=o; kid; kid = kid->op_sibling) {
+ if (kid &&
+ ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
+ || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
+ || (kid->op_type == OP_PUSHMARK)
+ )
+ )
+ continue;
+ if (o2) { /* more than one found */
+ o2 = Nullop;
+ break;
+ }
+ o2 = kid;
+ }
+ if (o2)
+ return find_uninit_var(o2, uninit_sv, match);
+
+ /* scan all args */
+ while (o) {
+ sv = find_uninit_var(o, uninit_sv, 1);
+ if (sv)
+ return sv;
+ o = o->op_sibling;
+ }
+ break;
+ }
+ return Nullsv;
+}
+
+
/*
=for apidoc report_uninit
*/
void
-Perl_report_uninit(pTHX)
+Perl_report_uninit(pTHX_ SV* uninit_sv)
{
- if (PL_op)
+ if (PL_op) {
+ SV* varname;
+ if (uninit_sv) {
+ varname = find_uninit_var(PL_op, uninit_sv,0);
+ if (varname)
+ sv_insert(varname, 0, 0, " ", 1);
+ }
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- " in ", OP_DESC(PL_op));
+ varname ? SvPV_nolen(varname) : "",
+ " in ", OP_DESC(PL_op));
+ }
else
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+ "", "", "");
}
/* grab a new IV body from the free list, allocating more if necessary */
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();
else if (SvPOKp(sv))
sbegin = SvPV(sv, len);
else
- return 1; /* Historic. Wrong? */
+ return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
return grok_number(sbegin, len, NULL);
}
}
#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)) {
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- report_uninit();
+ report_uninit(sv);
}
return 0;
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
return 0;
}
}
}
} else {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- report_uninit();
+ report_uninit(sv);
if (SvTYPE(sv) < SVt_IV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_IV);
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))
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- report_uninit();
+ report_uninit(sv);
}
return 0;
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
return 0;
}
}
else {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- report_uninit();
+ report_uninit(sv);
}
if (SvTYPE(sv) < SVt_IV)
/* Typically the caller expects that sv_any is not NULL now. */
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- report_uninit();
+ report_uninit(sv);
}
return 0;
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
return 0.0;
}
}
}
else {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- report_uninit();
+ report_uninit(sv);
if (SvTYPE(sv) < SVt_NV)
/* Typically the caller expects that sv_any is not NULL now. */
/* XXX Ilya implies that this is a bug in callers that assume this
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- report_uninit();
+ report_uninit(sv);
}
*lp = 0;
return "";
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
*lp = 0;
return "";
}
else {
if (ckWARN(WARN_UNINITIALIZED)
&& !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- report_uninit();
+ report_uninit(sv);
*lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
}
if (hibit) {
STRLEN len;
-
+ (void)SvOOK_off(sv);
+ s = (U8*)SvPVX(sv);
len = SvCUR(sv) + 1; /* Plus the \0 */
SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
SvCUR(sv) = len - 1;
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,
}
if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free unreferenced scalar: SV 0x%"UVxf,
- PTR2UV(sv));
+ "Attempt to free unreferenced scalar: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
return;
}
if (--(SvREFCNT(sv)) > 0)
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "Attempt to free temp prematurely: SV 0x%"UVxf,
- PTR2UV(sv));
+ "Attempt to free temp prematurely: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
return;
}
#endif
s += UTF8SKIP(s);
if (s >= send)
s = send;
- if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
- cache[2] += *offsetp;
+ utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
}
*lenp = s - start;
}
cache[0] -= ubackw;
*offsetp = cache[0];
+
+ /* Drop the stale "length" cache */
+ cache[2] = 0;
+ cache[3] = 0;
+
return;
}
}
cache[0] = len;
cache[1] = *offsetp;
+ /* Drop the stale "length" cache */
+ cache[2] = 0;
+ cache[3] = 0;
}
*offsetp = len;
char *
Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_pvn_force(sv,lp);
sv_utf8_downgrade(sv,0);
- return sv_pvn_force(sv,lp);
+ *lp = SvCUR(sv);
+ return SvPVX(sv);
}
/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
char *
Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_pvn_force(sv,lp);
sv_utf8_upgrade(sv);
- return sv_pvn_force(sv,lp);
+ *lp = SvCUR(sv);
+ return SvPVX(sv);
}
/*
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
SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
svp = AvARRAY(av);
for (i = AvFILLp(av); i >= 0; i--) {
- if (!svp[i] || SvREFCNT(svp[i]) < 2) continue;
+ if (!svp[i]) continue;
av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
}
}
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff