/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
Newxz(adesc->arena, arena_size, char);
adesc->size = arena_size;
DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n",
- curr, adesc->arena, arena_size));
+ curr, (void*)adesc->arena, arena_size));
return adesc->arena;
}
{ sizeof(HE), 0, 0, SVt_NULL,
FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
+ /* The bind placeholder pretends to be an RV for now.
+ Also it's marked as "can't upgrade" top stop anyone using it before it's
+ implemented. */
+ { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
+
/* IVs are in the head, so the allocation size is 0.
However, the slot is overloaded for PTEs. */
{ sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
{ sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
- /* 36 */
- { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV,
- HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
-
/* 48 */
{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
/* computed count doesnt reflect the 1st slot reservation */
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d type %d size %d ct %d\n",
- start, end,
+ (void*)start, (void*)end,
(int)bdp->arena_size, sv_type, (int)body_size,
(int)bdp->arena_size / (int)body_size));
(In fact, GP ends up pointing at a previous GP structure, because the
principle cause of the padding in XPVMG getting garbage is a copy of
- sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
+ sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
+ this happens to be moot because XPVGV has been re-ordered, with GP
+ no longer after STASH)
So we are careful and work out the size of used parts of all the
structures. */
assert(!SvNOK(sv));
case SVt_PVIO:
case SVt_PVFM:
- case SVt_PVBM:
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
dVAR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || SvTYPE(sv) == SVt_PVBM) {
- /* PVBMs use the same flag bit as SVf_IVisUV, so must let them
+ if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+ /* FBMs use the same flag bit as SVf_IVisUV, so must let them
cache IVs just in case. In practice it seems that they never
actually anywhere accessible by user Perl code, let alone get used
in anything other than a string context. */
dVAR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || SvTYPE(sv) == SVt_PVBM) {
- /* PVBMs use the same flag bit as SVf_IVisUV, so must let them
+ if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+ /* FBMs use the same flag bit as SVf_IVisUV, so must let them
cache IVs just in case. */
if (flags & SV_GMAGIC)
mg_get(sv);
dVAR;
if (!sv)
return 0.0;
- if (SvGMAGICAL(sv) || SvTYPE(sv) == SVt_PVBM) {
- /* PVBMs use the same flag bit as SVf_IVisUV, so must let them
+ if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+ /* FBMs use the same flag bit as SVf_IVisUV, so must let them
cache IVs just in case. */
mg_get(sv);
if (SvNOKp(sv))
}
sv_upgrade(dstr, SVt_PVGV);
(void)SvOK_off(dstr);
- SvSCREAM_on(dstr);
+ /* FIXME - why are we doing this, then turning it off and on again
+ below? */
+ isGV_with_GP_on(dstr);
}
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
#endif
gp_free((GV*)dstr);
- SvSCREAM_off(dstr);
+ isGV_with_GP_off(dstr);
(void)SvOK_off(dstr);
- SvSCREAM_on(dstr);
+ isGV_with_GP_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
GvGP(dstr) = gp_ref(GvGP(sstr));
if (SvTAINTED(sstr))
if (SvIS_FREED(dstr)) {
Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
- " to a freed scalar %p", sstr, dstr);
+ " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
}
SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (!sstr)
sstr = &PL_sv_undef;
if (SvIS_FREED(sstr)) {
- Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr,
- dstr);
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
+ (void*)sstr, (void*)dstr);
}
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
case SVt_PV:
sv_upgrade(dstr, SVt_PVIV);
break;
+ case SVt_PVGV:
+ goto end_of_first_switch;
}
(void)SvIOK_only(dstr);
SvIV_set(dstr, SvIVX(sstr));
case SVt_PVIV:
sv_upgrade(dstr, SVt_PVNV);
break;
+ case SVt_PVGV:
+ goto end_of_first_switch;
}
SvNV_set(dstr, SvNVX(sstr));
(void)SvNOK_only(dstr);
}
break;
+ /* case SVt_BIND: */
case SVt_PVGV:
- if (dtype <= SVt_PVGV) {
+ if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
glob_assign_glob(dstr, sstr, dtype);
return;
}
+ /* SvVALID means that this PVGV is playing at being an FBM. */
/*FALLTHROUGH*/
case SVt_PVMG:
case SVt_PVLV:
- case SVt_PVBM:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
- if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
+ if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
glob_assign_glob(dstr, sstr, dtype);
return;
}
else
SvUPGRADE(dstr, (svtype)stype);
}
+ end_of_first_switch:
/* dstr may have been upgraded. */
dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
- if (dtype == SVt_PVCV) {
+ if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
/* Assigning to a subroutine sets the prototype. */
if (SvOK(sstr)) {
STRLEN len;
Copy(ptr, SvPVX(dstr), len + 1, char);
SvCUR_set(dstr, len);
SvPOK_only(dstr);
+ SvFLAGS(dstr) |= sflags & SVf_UTF8;
} else {
SvOK_off(dstr);
}
+ } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
+ const char * const type = sv_reftype(dstr,0);
+ if (PL_op)
+ Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
+ else
+ Perl_croak(aTHX_ "Cannot copy to %s", type);
} else if (sflags & SVf_ROK) {
- if (dtype == SVt_PVGV && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ if (isGV_with_GP(dstr) && dtype == SVt_PVGV
+ && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
assert(!(sflags & SVf_NOK));
assert(!(sflags & SVf_IOK));
}
- else if (dtype == SVt_PVGV) {
+ else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
if (!(sflags & SVf_OK)) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
- sstr, dstr);
+ (void*)sstr, (void*)dstr);
sv_dump(sstr);
if (dstr)
sv_dump(dstr);
=cut
*/
MAGIC *
-Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
const char* name, I32 namlen)
{
dVAR;
else
mg->mg_ptr = (char *) name;
}
- mg->mg_virtual = vtable;
+ mg->mg_virtual = (MGVTBL *) vtable;
mg_magical(sv);
if (SvGMAGICAL(sv))
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
dVAR;
- MGVTBL *vtable;
+ const MGVTBL *vtable;
MAGIC* mg;
#ifdef PERL_OLD_COPY_ON_WRITE
case PERL_MAGIC_regdata:
vtable = &PL_vtbl_regdata;
break;
- case PERL_MAGIC_regdata_names:
- vtable = &PL_vtbl_regdata_names;
- break;
case PERL_MAGIC_regdatum:
vtable = &PL_vtbl_regdatum;
break;
}
}
if (type >= SVt_PVMG) {
- if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) {
- SvREFCNT_dec(OURSTASH(sv));
+ if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+ SvREFCNT_dec(SvOURSTASH(sv));
} else if (SvMAGIC(sv))
mg_free(sv);
if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
+ /* case SVt_BIND: */
case SVt_PVIO:
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
goto freescalar;
- case SVt_PVBM:
- goto freescalar;
case SVt_PVCV:
case SVt_PVFM:
cv_undef((CV*)sv);
SvREFCNT_dec(LvTARG(sv));
goto freescalar;
case SVt_PVGV:
- gp_free((GV*)sv);
- if (GvNAME_HEK(sv)) {
- unshare_hek(GvNAME_HEK(sv));
- }
+ if (isGV_with_GP(sv)) {
+ gp_free((GV*)sv);
+ if (GvNAME_HEK(sv))
+ unshare_hek(GvNAME_HEK(sv));
/* If we're in a stash, we don't own a reference to it. However it does
have a back reference to us, which needs to be cleared. */
- if (GvSTASH(sv))
- sv_del_backref((SV*)GvSTASH(sv), sv);
+ if (!SvVALID(sv) && GvSTASH(sv))
+ sv_del_backref((SV*)GvSTASH(sv), sv);
+ }
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
" real %"UVuf" for %"SVf,
- (UV) ulen, (UV) real, (void*)sv);
+ (UV) ulen, (UV) real, SVfARG(sv));
}
}
}
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
" real %"UVuf" for %"SVf,
- (UV) boffset, (UV) real_boffset, (void*)sv);
+ (UV) boffset, (UV) real_boffset, SVfARG(sv));
}
}
boffset = real_boffset;
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
- " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv);
+ " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
}
}
PL_utf8cache = 0;
Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
" real %"UVuf" for %"SVf,
- (UV) len, (UV) real_len, (void*)sv);
+ (UV) len, (UV) real_len, SVfARG(sv));
}
}
len = real_len;
else
io = 0;
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv);
+ Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
break;
}
return io;
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- (void*)sv);
+ SVfARG(sv));
}
return GvCVu(gv);
}
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVMG:
- case SVt_PVBM:
if (SvVOK(sv))
return "VSTRING";
if (SvROK(sv))
case SVt_PVGV: return "GLOB";
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
+ case SVt_BIND: return "BIND";
default: return "UNKNOWN";
}
}
if (GvNAME_HEK(sv)) {
unshare_hek(GvNAME_HEK(sv));
}
- SvSCREAM_off(sv);
+ isGV_with_GP_off(sv);
/* need to keep SvANY(sv) in the right arena */
xpvmg = new_XPVMG();
}
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
- argsv = va_arg(*args, SV*);
+ argsv = (SV*)va_arg(*args, void*);
sv_catsv(sv, argsv);
return;
}
precis = n;
has_precis = TRUE;
}
- argsv = va_arg(*args, SV*);
+ argsv = (SV*)va_arg(*args, void*);
eptr = SvPVx_const(argsv, elen);
if (DO_UTF8(argsv))
is_utf8 = TRUE;
(UV)c & 0xFF);
} else
sv_catpvs(msg, "end of string");
- Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
}
/* output mangled stuff ... */
#define SAVEPV(p) ((p) ? savepv(p) : NULL)
#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
+/* clone a parser */
+
+yy_parser *
+Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
+{
+ yy_parser *parser;
+
+ if (!proto)
+ return NULL;
+
+ /* look for it in the table first */
+ parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
+ if (parser)
+ return parser;
+
+ /* create anew and remember what it is */
+ Newxz(parser, 1, yy_parser);
+ ptr_table_store(PL_ptr_table, proto, parser);
+
+ parser->yyerrstatus = 0;
+ parser->yychar = YYEMPTY; /* Cause a token to be read. */
+
+ /* XXX these not yet duped */
+ parser->old_parser = NULL;
+ parser->stack = NULL;
+ parser->ps = NULL;
+ parser->stack_size = 0;
+ /* XXX parser->stack->state = 0; */
+
+ /* XXX eventually, just Copy() most of the parser struct ? */
+
+ parser->lex_brackets = proto->lex_brackets;
+ parser->lex_casemods = proto->lex_casemods;
+ parser->lex_brackstack = savepvn(proto->lex_brackstack,
+ (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
+ parser->lex_casestack = savepvn(proto->lex_casestack,
+ (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
+ parser->lex_defer = proto->lex_defer;
+ parser->lex_dojoin = proto->lex_dojoin;
+ parser->lex_expect = proto->lex_expect;
+ parser->lex_formbrack = proto->lex_formbrack;
+ parser->lex_inpat = proto->lex_inpat;
+ parser->lex_inwhat = proto->lex_inwhat;
+ parser->lex_op = proto->lex_op;
+ parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
+ parser->lex_starts = proto->lex_starts;
+ parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
+ parser->multi_close = proto->multi_close;
+ parser->multi_open = proto->multi_open;
+ parser->multi_start = proto->multi_start;
+ parser->pending_ident = proto->pending_ident;
+ parser->preambled = proto->preambled;
+ parser->sublex_info = proto->sublex_info; /* XXX not quite right */
+
+#ifdef PERL_MAD
+ parser->endwhite = proto->endwhite;
+ parser->faketokens = proto->faketokens;
+ parser->lasttoke = proto->lasttoke;
+ parser->nextwhite = proto->nextwhite;
+ parser->realtokenstart = proto->realtokenstart;
+ parser->skipwhite = proto->skipwhite;
+ parser->thisclose = proto->thisclose;
+ parser->thismad = proto->thismad;
+ parser->thisopen = proto->thisopen;
+ parser->thisstuff = proto->thisstuff;
+ parser->thistoken = proto->thistoken;
+ parser->thiswhite = proto->thiswhite;
+#endif
+ return parser;
+}
+
/* duplicate a file handle */
return mgret;
}
+#endif /* USE_ITHREADS */
+
/* create a new pointer-mapping table */
PTR_TBL_t *
Safefree(tbl);
}
+#if defined(USE_ITHREADS)
void
Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
#ifdef DEBUGGING
if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
- PL_watch_pvx, SvPVX_const(sstr));
+ (void*)PL_watch_pvx, SvPVX_const(sstr));
#endif
/* don't clone objects whose class has asked us not to */
SvANY(dstr) = &(dstr->sv_u.svu_rv);
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
+ /* case SVt_BIND: */
default:
{
/* These are all the types that need complex bodies allocating. */
case SVt_PVFM:
case SVt_PVHV:
case SVt_PVAV:
- case SVt_PVBM:
case SVt_PVCV:
case SVt_PVLV:
case SVt_PVMG:
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
- OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param));
+ SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvSTASH(dstr))
break;
case SVt_PVMG:
break;
- case SVt_PVBM:
- break;
case SVt_PVLV:
/* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
break;
case SVt_PVGV:
- if (GvNAME_HEK(dstr))
- GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+ if(isGV_with_GP(sstr)) {
+ if (GvNAME_HEK(dstr))
+ GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+ }
/* Don't call sv_add_backref here as it's going to be created
as part of the magic cloning of the symbol table. */
- GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ if(!SvVALID(dstr))
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
if(isGV_with_GP(sstr)) {
/* Danger Will Robinson - GvGP(dstr) isn't initialised
at the point of this comment. */
ANY *
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
+ dVAR;
ANY * const ss = proto_perl->Tsavestack;
const I32 max = proto_perl->Tsavestack_max;
I32 ix = proto_perl->Tsavestack_ix;
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
break;
+ case SAVEt_PARSER:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = parser_dup(ptr, param);
+ break;
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
PL_Argv = NULL;
PL_Cmd = NULL;
PL_gensym = proto_perl->Igensym;
- PL_preambled = proto_perl->Ipreambled;
PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
PL_laststatval = proto_perl->Ilaststatval;
PL_laststype = proto_perl->Ilaststype;
if (PL_my_cxt_size) {
Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ Newx(PL_my_cxt_keys, PL_my_cxt_size, char *);
+ Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
+#endif
}
- else
+ else {
PL_my_cxt_list = (void**)NULL;
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ PL_my_cxt_keys = (void**)NULL;
+#endif
+ }
PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
#endif
+ PL_parser = parser_dup(proto_perl->Iparser, param);
+
PL_lex_state = proto_perl->Ilex_state;
- PL_lex_defer = proto_perl->Ilex_defer;
- PL_lex_expect = proto_perl->Ilex_expect;
- PL_lex_formbrack = proto_perl->Ilex_formbrack;
- PL_lex_dojoin = proto_perl->Ilex_dojoin;
- PL_lex_starts = proto_perl->Ilex_starts;
- PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
- PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
- PL_lex_op = proto_perl->Ilex_op;
- PL_lex_inpat = proto_perl->Ilex_inpat;
- PL_lex_inwhat = proto_perl->Ilex_inwhat;
- PL_lex_brackets = proto_perl->Ilex_brackets;
- i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
- PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
- PL_lex_casemods = proto_perl->Ilex_casemods;
- i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
- PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
#ifdef PERL_MAD
Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE);
- PL_lasttoke = proto_perl->Ilasttoke;
- PL_realtokenstart = proto_perl->Irealtokenstart;
- PL_faketokens = proto_perl->Ifaketokens;
- PL_thismad = proto_perl->Ithismad;
- PL_thistoken = proto_perl->Ithistoken;
- PL_thisopen = proto_perl->Ithisopen;
- PL_thisstuff = proto_perl->Ithisstuff;
- PL_thisclose = proto_perl->Ithisclose;
- PL_thiswhite = proto_perl->Ithiswhite;
- PL_nextwhite = proto_perl->Inextwhite;
- PL_skipwhite = proto_perl->Iskipwhite;
- PL_endwhite = proto_perl->Iendwhite;
PL_curforce = proto_perl->Icurforce;
#else
Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
PL_nexttoke = proto_perl->Inexttoke;
#endif
- /* XXX This is probably masking the deeper issue of why
- * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
- * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
- * (A little debugging with a watchpoint on it may help.)
- */
- if (SvANY(proto_perl->Ilinestr)) {
- PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
- i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
- PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- }
- else {
- PL_linestr = newSV(79);
- sv_upgrade(PL_linestr,SVt_PVIV);
- sv_setpvn(PL_linestr,"",0);
- PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
- }
+ PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
+ i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
+ PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
+ PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
+ PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
+ PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_pending_ident = proto_perl->Ipending_ident;
- PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
PL_expect = proto_perl->Iexpect;
- PL_multi_start = proto_perl->Imulti_start;
PL_multi_end = proto_perl->Imulti_end;
- PL_multi_open = proto_perl->Imulti_open;
- PL_multi_close = proto_perl->Imulti_close;
PL_error_count = proto_perl->Ierror_count;
PL_subline = proto_perl->Isubline;
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
- /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
- if (SvANY(proto_perl->Ilinestr)) {
- i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
- PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
- PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- PL_last_lop_op = proto_perl->Ilast_lop_op;
- }
- else {
- PL_last_uni = SvPVX(PL_linestr);
- PL_last_lop = SvPVX(PL_linestr);
- PL_last_lop_op = 0;
- }
+ i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
+ PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
+ PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ PL_last_lop_op = proto_perl->Ilast_lop_op;
PL_in_my = proto_perl->Iin_my;
PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
#ifdef FCRYPT
return NULL;
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_const(sv));
+ sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
https://perl5.git.perl.org / perl5.git / blobdiff