if (PL_op)
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ /* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric in %s", pv,
OP_DESC(PL_op));
else
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ /* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric", pv);
}
Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
-if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
+if all the bytes are invariant in UTF-8.
+If C<flags> has C<SV_GMAGIC> bit set,
will C<mg_get> on C<sv> if appropriate, else not.
Returns the number of bytes in the converted string
C<sv_utf8_upgrade> and
* we want to make sure everything inside is valid utf8 first.
*/
c = start = (const U8 *) SvPVX_const(sv);
- if (!is_utf8_string(c, SvCUR(sv)+1))
+ if (!is_utf8_string(c, SvCUR(sv)))
return FALSE;
e = (const U8 *) SvEND(sv);
while (c < e) {
}
SvUPGRADE(dstr, SVt_PVGV);
(void)SvOK_off(dstr);
- /* FIXME - why are we doing this, then turning it off and on again
- below? */
+ /* We have to turn this on here, even though we turn it off
+ below, as GvSTASH will fail an assertion otherwise. */
isGV_with_GP_on(dstr);
}
GvSTASH(dstr) = GvSTASH(sstr);
}
gp_free(MUTABLE_GV(dstr));
- isGV_with_GP_off(dstr);
+ isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
(void)SvOK_off(dstr);
isGV_with_GP_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
CV* const cv = MUTABLE_CV(*location);
if (cv) {
if (!GvCVGEN((const GV *)dstr) &&
- (CvROOT(cv) || CvXSUB(cv)))
+ (CvROOT(cv) || CvXSUB(cv)) &&
+ /* redundant check that avoids creating the extra SV
+ most of the time: */
+ (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
{
- const char *hvname;
- /* Redefining a sub - warning is mandatory if
- it was a const and its value changed. */
- if (CvCONST(cv) && CvCONST((const CV *)sref)
- && cv_const_sv(cv)
- == cv_const_sv((const CV *)sref)) {
- NOOP;
- /* They are 2 constant subroutines generated from
- the same constant. This probably means that
- they are really the "same" proxy subroutine
- instantiated in 2 places. Most likely this is
- when a constant is exported twice. Don't warn.
- */
- }
- else if ((ckWARN(WARN_REDEFINE)
- && !(
- CvGV(cv) && GvSTASH(CvGV(cv)) &&
- HvNAMELEN(GvSTASH(CvGV(cv))) == 7 &&
- (hvname = HvNAME(GvSTASH(CvGV(cv))),
- strEQ(hvname, "autouse"))
- )
- )
- || (CvCONST(cv)
- && ckWARN_d(WARN_REDEFINE)
- && (!CvCONST((const CV *)sref)
- || sv_cmp(cv_const_sv(cv),
- cv_const_sv((const CV *)
- sref))))) {
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- (const char *)
- (CvCONST(cv)
- ? "Constant subroutine %"HEKf
- "::%"HEKf" redefined"
- : "Subroutine %"HEKf"::%"HEKf
- " redefined"),
+ SV * const new_const_sv =
+ CvCONST((const CV *)sref)
+ ? cv_const_sv((const CV *)sref)
+ : NULL;
+ report_redefined_cv(
+ sv_2mortal(Perl_newSVpvf(aTHX_
+ "%"HEKf"::%"HEKf,
HEKfARG(
HvNAME_HEK(GvSTASH((const GV *)dstr))
),
- HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))));
- }
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
+ )),
+ cv,
+ CvCONST((const CV *)sref) ? &new_const_sv : NULL
+ );
}
if (!intro)
cv_ckproto_len_flags(cv, (const GV *)dstr,
if ( SvVOK(dstr) )
{
/* need to nuke the magic */
- mg_free(dstr);
+ sv_unmagic(dstr, PERL_MAGIC_vstring);
}
/* There's a lot of redundancy below but we're going for speed here */
{
const char * const type = sv_reftype(sstr,0);
if (PL_op)
+ /* diag_listed_as: Bizarre copy of %s */
Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Bizarre copy of %s", type);
} else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
const char * const type = sv_reftype(dstr,0);
if (PL_op)
+ /* diag_listed_as: Cannot copy to %s */
Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Cannot copy to %s", type);
/* len is STRLEN which is unsigned, need to copy to signed */
const IV iv = len;
if (iv < 0)
- Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
+ Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
+ IVdf, iv);
}
SvUPGRADE(sv, SVt_PV);
return;
}
{
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
- sv_usepvn_flags(sv, (char *)HEK_KEY(share_hek_hek(hek)), HEK_LEN(hek), SV_HAS_TRAILING_NUL);
+ SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
+ SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
SvREADONLY_on(sv);
SvFAKE_on(sv);
Tells an SV to use C<ptr> to find its string value. Normally the
string is stored inside the SV but sv_usepvn allows the SV to use an
outside string. The C<ptr> should point to memory that was allocated
-by C<malloc>. The string length, C<len>, must be supplied. By default
+by C<malloc>. It must be the start of a mallocked block
+of memory, and not a pointer to the middle of it. The
+string length, C<len>, must be supplied. By default
this function will realloc (i.e. move) the memory pointed to by C<ptr>,
so that pointer should not be freed or used by the programmer after
giving it to sv_usepvn, and neither should any pointers from "behind"
}
#else
if (SvREADONLY(sv)) {
- if (SvFAKE(sv) && !isGV_with_GP(sv)) {
+ if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
- SvGROW(sv, len + 1);
- Move(pvx,SvPVX(sv),len,char);
- *SvEND(sv) = '\0';
+ if (flags & SV_COW_DROP_PV) {
+ /* OK, so we don't need to copy our buffer. */
+ SvPOK_off(sv);
+ } else {
+ SvGROW(sv, len + 1);
+ Move(pvx,SvPVX(sv),len,char);
+ *SvEND(sv) = '\0';
+ }
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
else if (IN_PERL_RUNTIME)
if (SvROK(sv))
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && isGV_with_GP(sv))
- sv_unglob(sv);
+ sv_unglob(sv, flags);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
/* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
to sv_unglob. We only need it here, so inline it. */
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
- SvFLAGS(sv) |= SVf_OOK;
+ SvOOK_on(sv);
old_delta = 0;
} else {
SvOOK_offset(sv, old_delta);
#endif
if (SvREADONLY(sv)) {
if (
- /* its okay to attach magic to shared strings; the subsequent
- * upgrade to PVMG will unshare the string */
- !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
+ /* its okay to attach magic to shared strings */
+ (!SvFAKE(sv) || isGV_with_GP(sv))
&& IN_PERL_RUNTIME
&& !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
svp = mg ? &(mg->mg_obj) : NULL;
}
- if (!svp || !*svp)
- Perl_croak(aTHX_ "panic: del_backref");
+ if (!svp)
+ Perl_croak(aTHX_ "panic: del_backref, svp=0");
+ if (!*svp) {
+ /* It's possible that sv is being freed recursively part way through the
+ freeing of tsv. If this happens, the backreferences array of tsv has
+ already been freed, and so svp will be NULL. If this is the case,
+ we should not panic. Instead, nothing needs doing, so return. */
+ if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
+ return;
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
+ *svp, PL_phase_names[PL_phase], SvREFCNT(tsv));
+ }
if (SvTYPE(*svp) == SVt_PVAV) {
#ifdef DEBUGGING
assert(count ==1);
AvFILLp(av) = fill-1;
}
+ else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
+ /* freed AV; skip */
+ }
else {
/* optimisation: only a single backref, stored directly */
if (*svp != sv)
- Perl_croak(aTHX_ "panic: del_backref");
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
*svp = NULL;
}
=for apidoc sv_insert_flags
-Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
+Same as C<sv_insert>, but the extra C<flags> are passed to the
+C<SvPV_force_flags> that applies to C<bigstr>.
=cut
*/
PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
if (!bigstr)
- Perl_croak(aTHX_ "Can't modify non-existent substring");
+ Perl_croak(aTHX_ "Can't modify nonexistent substring");
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
bigend = big + SvCUR(bigstr);
if (midend > bigend)
- Perl_croak(aTHX_ "panic: sv_insert");
+ Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
+ midend, bigend);
if (mid - big > bigend - midend) { /* faster to shorten from end */
if (littlelen) {
Safefree(IoTOP_NAME(sv));
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
+ if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
/* FIXME. There are probably more unreferenced pointers to SVs
* in the interpreter struct that we should check and tidy in
* a similar fashion to this: */
+ /* See also S_sv_unglob, which does the same thing. */
if ((const GV *)sv == PL_last_in_gv)
PL_last_in_gv = NULL;
+ else if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
/*
=for apidoc sv_len
-Returns the length of the string in the SV. Handles magic and type
+Returns the length of the string in the SV. Handles magic and type
coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
=cut
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles type coercion.
+the offset, rather than from the start
+of the string. Handles type coercion.
I<flags> is passed to C<SvPV_flags>, and usually should be
C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles magic and
+the offset, rather than from the start of the string. Handles magic and
type coercion.
Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
s = (const U8*)SvPV_const(sv, blen);
if (blen < byte)
- Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
+ ", byte=%"UVuf, (UV)blen, (UV)byte);
send = s + byte;
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
+ /* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
"Lost precision when incrementing %" NVff " by 1",
was);
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
was <= -NV_OVERFLOWS_INTEGERS_AT) {
+ /* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
"Lost precision when decrementing %" NVff " by 1",
was);
Marks an existing SV as mortal. The SV will be destroyed "soon", either
by an explicit call to FREETMPS, or by an implicit call at places such as
statement boundaries. SvTEMP() is turned on which means that the SV's
-string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
+string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
and C<sv_mortalcopy>.
=cut
table. If the string does not already exist in the table, it is
created first. Turns on READONLY and FAKE. If the C<hash> parameter
is non-zero, that value is used; otherwise the hash is computed.
-The string's hash can be later be retrieved from the SV
+The string's hash can later be retrieved from the SV
with the C<SvSHARED_HASH()> macro. The idea here is
that as the string table is used for shared hash keys these strings will have
SvPVX_const == HeKEY and hash lookup will avoid string compare.
if (SvROK(sv)) {
if (SvAMAGIC(sv))
sv = amagic_deref_call(sv, to_cv_amg);
- /* At this point I'd like to do SPAGAIN, but really I need to
- force it upon my callers. Hmmm. This is a mess... */
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVCV) {
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
+ if (flags & SV_GMAGIC) SvGETMAGIC(sv);
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
/* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
- s = sv_2pv_flags(sv, &len, flags);
+ s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
if (lp)
*lp = len;
* as it is after unglobbing it.
*/
-STATIC void
-S_sv_unglob(pTHX_ SV *const sv)
+PERL_STATIC_INLINE void
+S_sv_unglob(pTHX_ SV *const sv, U32 flags)
{
dVAR;
void *xpvmg;
HV *stash;
- SV * const temp = sv_newmortal();
+ SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
PERL_ARGS_ASSERT_SV_UNGLOB;
assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
SvFAKE_off(sv);
- gv_efullname3(temp, MUTABLE_GV(sv), "*");
+ if (!(flags & SV_COW_DROP_PV))
+ gv_efullname3(temp, MUTABLE_GV(sv), "*");
if (GvGP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
/* Intentionally not calling any local SET magic, as this isn't so much a
set operation as merely an internal storage change. */
- sv_setsv_flags(sv, temp, 0);
+ if (flags & SV_COW_DROP_PV) SvOK_off(sv);
+ else sv_setsv_flags(sv, temp, 0);
+
+ if ((const GV *)sv == PL_last_in_gv)
+ PL_last_in_gv = NULL;
+ else if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
}
/*
* back into v-string notation and then let the
* vectorize happen normally
*/
- if (sv_derived_from(vecsv, "version")) {
+ if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
char *version = savesvpv(vecsv);
if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
}
}
else
- sv_setuv_mg(argsv, (UV)i);
+ sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
continue; /* not "break" */
/* UNKNOWN */
The foo_dup() functions make an exact copy of an existing foo thingy.
During the course of a cloning, a hash table is used to map old addresses
-to new addresses. The table is created and manipulated with the
+to new addresses. The table is created and manipulated with the
ptr_table_* functions.
=cut
register const Direntry_t *dirent;
char smallbuf[256];
char *name = NULL;
- STRLEN len = -1;
+ STRLEN len = 0;
long pos;
#endif
return dstr;
}
}
+ else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
+ HV *stash = GvSTASH(sstr);
+ const HEK * hvname;
+ if (stash && (hvname = HvNAME_HEK(stash))) {
+ /** don't clone GVs if they already exist **/
+ SV **svp;
+ stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+ HEK_UTF8(hvname) ? SVf_UTF8 : 0);
+ svp = hv_fetch(
+ stash, GvNAME(sstr),
+ GvNAMEUTF8(sstr)
+ ? -GvNAMELEN(sstr)
+ : GvNAMELEN(sstr),
+ 0
+ );
+ if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
+ ptr_table_store(PL_ptr_table, sstr, *svp);
+ return *svp;
+ }
+ }
+ }
}
/* create anew and remember what it is */
const struct xpvhv_aux * const saux = HvAUX(sstr);
struct xpvhv_aux * const daux = HvAUX(dstr);
/* This flag isn't copied. */
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(dstr) |= SVf_OOK;
+ SvOOK_on(dstr);
if (saux->xhv_name_count) {
HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
from the position which (PV + *offset) pointed to. The dsv will be
concatenated the decoded UTF-8 string from ssv. Decoding will terminate
when the string tstr appears in decoding output or the input ends on
-the PV of the ssv. The value which the offset points will be modified
+the PV of the ssv. The value which the offset points will be modified
to the last input position on the ssv.
Returns TRUE if the terminator was found, else returns FALSE.
{
SV * const name = sv_newmortal();
- if (gv) {
+ if (gv && isGV(gv)) {
char buffer[2];
buffer[0] = gvtype;
buffer[1] = 0;
}
}
else {
- CV * const cv = find_runcv(NULL);
+ CV * const cv = gv ? (CV *)gv : find_runcv(NULL);
SV *sv;
AV *av;
+ assert(!cv || SvTYPE(cv) == SVt_PVCV);
+
if (!cv || !CvPADLIST(cv))
return NULL;
av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
break;
sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
}
- else /* @{expr}, %{expr} */
+ else if (obase == PL_op) /* @{expr}, %{expr} */
return find_uninit_var(cUNOPx(obase)->op_first,
uninit_sv, match);
+ else /* @{expr}, %{expr} as a sub-expression */
+ return NULL;
}
/* attempt to find a match within the aggregate */
if (!o)
break;
- /* if all except one arg are constant, or have no side-effects,
- * or are optimized away, then it's unambiguous */
+ /* This loop checks all the kid ops, skipping any that cannot pos-
+ * sibly be responsible for the uninitialized value; i.e., defined
+ * constants and ops that return nothing. If there is only one op
+ * left that is not skipped, then we *know* it is responsible for
+ * the uninitialized value. If there is more than one op left, we
+ * have to look for an exact match in the while() loop below.
+ */
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
if (kid) {
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
- || (
- /* @$a and %$a, but not @a or %a */
- (type == OP_RV2AV || type == OP_RV2HV)
- && cUNOPx(kid)->op_first
- && cUNOPx(kid)->op_first->op_type != OP_GV
- )
)
continue;
}
https://perl5.git.perl.org / perl5.git / blobdiff