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
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;
}
{
- /* Emulate what sv_usepvn_flags does; it can't be called
- directly, because it assumes that the data for the PV is at the
- start of a malloced block */
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
- SvTAINT(sv);
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
SvREADONLY_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"
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;
}
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
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;
set operation as merely an internal storage change. */
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") && SvROK(vecsv)) {
+ 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 */
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)));