# define POSION_SV_HEAD(sv)
#endif
+/* Mark an SV head as unused, and add to free list.
+ *
+ * If SVf_BREAK is set, skip adding it to the free list, as this SV had
+ * its refcount artificially decremented during global destruction, so
+ * there may be dangling pointers to it. The last thing we want in that
+ * case is for it to be reused. */
+
#define plant_SV(p) \
STMT_START { \
+ const U32 old_flags = SvFLAGS(p); \
FREE_SV_DEBUG_FILE(p); \
POSION_SV_HEAD(p); \
- SvARENA_CHAIN(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
- PL_sv_root = (p); \
+ if (!(old_flags & SVf_BREAK)) { \
+ SvARENA_CHAIN(p) = (void *)PL_sv_root; \
+ PL_sv_root = (p); \
+ } \
--PL_sv_count; \
} STMT_END
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
- sv->sv_debug_line = (U16) (PL_parser
- ? PL_parser->copline == NOLINE
- ? PL_curcop
+ sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
+ ? PL_parser->copline
+ : PL_curcop
? CopLINE(PL_curcop)
: 0
- : PL_parser->copline
- : 0);
+ );
sv->sv_debug_inpad = 0;
sv->sv_debug_cloned = 0;
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
const U8 ch = *t++;
/* Check for hi bit */
if (!NATIVE_IS_INVARIANT(ch)) {
- STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ STRLEN len = SvCUR(sv);
+ /* *Currently* bytes_to_utf8() adds a '\0' after every string
+ it converts. This isn't documented. It's not clear if it's
+ a bad thing to be doing, and should be changed to do exactly
+ what the documentation says. If so, this code will have to
+ be changed.
+ As is, we mustn't rely on our incoming SV being well formed
+ and having a trailing '\0', as certain code in pp_formline
+ can send us partially built SVs. */
U8 * const recoded = bytes_to_utf8((U8*)s, &len);
SvPV_free(sv); /* No longer using what was there before. */
SvPV_set(sv, (char*)recoded);
- SvCUR_set(sv, len - 1);
- SvLEN_set(sv, len); /* No longer know the real size. */
+ SvCUR_set(sv, len);
+ SvLEN_set(sv, len + 1); /* No longer know the real size. */
break;
}
}
{
/* need to nuke the magic */
mg_free(dstr);
- SvRMAGICAL_off(dstr);
}
/* There's a lot of redundancy below but we're going for speed here */
Perl_croak(aTHX_ "Cannot copy to %s", type);
} else if (sflags & SVf_ROK) {
if (isGV_with_GP(dstr) && dtype == SVt_PVGV
- && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
#ifdef DEBUGGING
const U8 *real_start;
#endif
+ STRLEN max_delta;
PERL_ARGS_ASSERT_SV_CHOP;
/* Nothing to do. */
return;
}
- assert(ptr > SvPVX_const(sv));
+ /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
+ nothing uses the value of ptr any more. */
+ max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
+ if (ptr <= SvPVX_const(sv))
+ Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
+ ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
SV_CHECK_THINKFIRST(sv);
+ if (delta > max_delta)
+ Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
+ SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
+ SvPVX_const(sv) + max_delta);
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
* back-reference to sv onto the array associated with the backref magic.
*/
+/* A discussion about the backreferences array and its refcount:
+ *
+ * The AV holding the backreferences is pointed to either as the mg_obj of
+ * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
+ * structure, from the xhv_backreferences field. (A HV without hv_aux will
+ * have the standard magic instead.) The array is created with a refcount
+ * of 2. This means that if during global destruction the array gets
+ * picked on first to have its refcount decremented by the random zapper,
+ * it won't actually be freed, meaning it's still theere for when its
+ * parent gets freed.
+ * When the parent SV is freed, in the case of magic, the magic is freed,
+ * Perl_magic_killbackrefs is called which decrements one refcount, then
+ * mg_obj is freed which kills the second count.
+ * In the vase of a HV being freed, one ref is removed by
+ * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
+ * calls.
+ */
+
void
Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
{
} else {
av = newAV();
AvREAL_off(av);
- SvREFCNT_inc_simple_void(av);
+ SvREFCNT_inc_simple_void(av); /* see discussion above */
}
*avp = av;
}
av = newAV();
AvREAL_off(av);
sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
- /* av now has a refcnt of 2, which avoids it getting freed
- * before us during global cleanup. The extra ref is removed
- * by magic_killbackrefs() when tsv is being freed */
+ /* av now has a refcnt of 2; see discussion above */
}
}
if (AvFILLp(av) >= AvMAX(av)) {
if (mg)
av = (AV *)mg->mg_obj;
}
- if (!av) {
- if (PL_in_clean_all)
- return;
+
+ if (!av)
Perl_croak(aTHX_ "panic: del_backref");
- }
- if (SvIS_FREED(av))
- return;
+ assert(!SvIS_FREED(av));
svp = AvARRAY(av);
/* We shouldn't be in here more than once, but for paranoia reasons lets
PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
PERL_UNUSED_ARG(sv);
- /* Not sure why the av can get freed ahead of its sv, but somehow it does
- in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
- if (svp && !SvIS_FREED(av)) {
+ assert(!svp || !SvIS_FREED(av));
+ if (svp) {
SV *const *const last = svp + AvFILLp(av);
while (svp <= last) {
#endif
if (bytesread < 0)
bytesread = 0;
- SvCUR_set(sv, bytesread += append);
+ SvCUR_set(sv, bytesread + append);
buffer[bytesread] = '\0';
goto return_string_or_null;
}
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
+ /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
+ changes here, update it there too. */
sv_upgrade(sv, SVt_PV);
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
SvCUR_set(sv, len);
io = (IO*)sv;
break;
case SVt_PVGV:
- gv = (GV*)sv;
- io = GvIO(gv);
- if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
- break;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ io = GvIO(gv);
+ if (!io)
+ Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
+ break;
+ }
+ /* FALL THROUGH */
default:
if (!SvOK(sv))
Perl_croak(aTHX_ PL_no_usym, "filehandle");
*gvp = NULL;
return NULL;
case SVt_PVGV:
- gv = (GV*)sv;
- *gvp = gv;
- *st = GvESTASH(gv);
- goto fix_gv;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ *gvp = gv;
+ *st = GvESTASH(gv);
+ goto fix_gv;
+ }
+ /* FALL THROUGH */
default:
if (SvROK(sv)) {
*st = CvSTASH(cv);
return cv;
}
- else if(isGV(sv))
+ else if(isGV_with_GP(sv))
gv = (GV*)sv;
else
Perl_croak(aTHX_ "Not a subroutine reference");
}
- else if (isGV(sv)) {
+ else if (isGV_with_GP(sv)) {
SvGETMAGIC(sv);
gv = (GV*)sv;
}
return NULL;
}
/* Some flags to gv_fetchsv mean don't really create the GV */
- if (SvTYPE(gv) != SVt_PVGV) {
+ if (!isGV_with_GP(gv)) {
*st = NULL;
return NULL;
}
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
- case SVt_PVGV: return "GLOB";
+ case SVt_PVGV: return (char *) (isGV_with_GP(sv)
+ ? "GLOB" : "SCALAR");
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
case SVt_BIND: return "BIND";
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
(bool)!!HvSHAREKEYS(sstr), param) : 0;
+ /* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
saux->xhv_backreferences
? (AV*) SvREFCNT_inc(
- sv_dup((SV*)saux->xhv_backreferences, param))
+ sv_dup_inc((SV*)saux->xhv_backreferences, param))
: 0;
daux->xhv_mro_meta = saux->xhv_mro_meta
case OP_PRTF:
case OP_PRINT:
case OP_SAY:
+ match = 1; /* print etc can return undef on defined args */
/* 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)
case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
case OP_RV2SV:
- case OP_CUSTOM:
- match = 1; /* XS or custom code could trigger random warnings */
+ case OP_CUSTOM: /* XS or custom code could trigger random warnings */
+
+ /* the following ops are capable of returning PL_sv_undef even for
+ * defined arg(s) */
+
+ case OP_BACKTICK:
+ case OP_PIPE_OP:
+ case OP_FILENO:
+ case OP_BINMODE:
+ case OP_TIED:
+ case OP_GETC:
+ case OP_SYSREAD:
+ case OP_SEND:
+ case OP_IOCTL:
+ case OP_SOCKET:
+ case OP_SOCKPAIR:
+ case OP_BIND:
+ case OP_CONNECT:
+ case OP_LISTEN:
+ case OP_ACCEPT:
+ case OP_SHUTDOWN:
+ case OP_SSOCKOPT:
+ case OP_GETPEERNAME:
+ case OP_FTRREAD:
+ case OP_FTRWRITE:
+ case OP_FTREXEC:
+ case OP_FTROWNED:
+ case OP_FTEREAD:
+ case OP_FTEWRITE:
+ case OP_FTEEXEC:
+ case OP_FTEOWNED:
+ case OP_FTIS:
+ case OP_FTZERO:
+ case OP_FTSIZE:
+ case OP_FTFILE:
+ case OP_FTDIR:
+ case OP_FTLINK:
+ case OP_FTPIPE:
+ case OP_FTSOCK:
+ case OP_FTBLK:
+ case OP_FTCHR:
+ case OP_FTTTY:
+ case OP_FTSUID:
+ case OP_FTSGID:
+ case OP_FTSVTX:
+ case OP_FTTEXT:
+ case OP_FTBINARY:
+ case OP_FTMTIME:
+ case OP_FTATIME:
+ case OP_FTCTIME:
+ case OP_READLINK:
+ case OP_OPEN_DIR:
+ case OP_READDIR:
+ case OP_TELLDIR:
+ case OP_SEEKDIR:
+ case OP_REWINDDIR:
+ case OP_CLOSEDIR:
+ case OP_GMTIME:
+ case OP_ALARM:
+ case OP_SEMGET:
+ case OP_GETLOGIN:
+ case OP_UNDEF:
+ case OP_SUBSTR:
+ case OP_AEACH:
+ case OP_EACH:
+ case OP_SORT:
+ case OP_CALLER:
+ case OP_DOFILE:
+ case OP_PROTOTYPE:
+ case OP_NCMP:
+ case OP_SMARTMATCH:
+ case OP_UNPACK:
+ case OP_SYSOPEN:
+ case OP_SYSSEEK:
+ match = 1;
goto do_op;
case OP_ENTERSUB:
Need a better fix at dome point. DAPM 11/2007 */
break;
+
case OP_POS:
/* def-ness of rval pos() is independent of the def-ness of its arg */
if ( !(obase->op_flags & OPf_MOD))
https://perl5.git.perl.org / perl5.git / blobdiff