/* pp_hot.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
/* Hot code. */
-#ifdef USE_THREADS
-static void unset_cvowner(pTHXo_ void *cvarg);
-#endif /* USE_THREADS */
+#ifdef USE_5005THREADS
+static void unset_cvowner(pTHX_ void *cvarg);
+#endif /* USE_5005THREADS */
PP(pp_const)
{
PP(pp_stringify)
{
dSP; dTARGET;
- STRLEN len;
- char *s;
- s = SvPV(TOPs,len);
- sv_setpvn(TARG,s,len);
- if (SvUTF8(TOPs))
- SvUTF8_on(TARG);
- else
- SvUTF8_off(TARG);
+ sv_copypv(TARG,TOPs);
SETTARG;
RETURN;
}
dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
- SV* rcopy = Nullsv;
-
- if (SvGMAGICAL(left))
- mg_get(left);
- if (TARG == right && SvGMAGICAL(right))
- mg_get(right);
-
- if (TARG == right && left != right)
- /* Clone since otherwise we cannot prepend. */
- rcopy = sv_2mortal(newSVsv(right));
-
- if (TARG != left)
- sv_setsv(TARG, left);
+ STRLEN llen;
+ char* lpv;
+ bool lbyte;
+ STRLEN rlen;
+ char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
+ bool rbyte = !SvUTF8(right);
+
+ if (TARG == right && right != left) {
+ right = sv_2mortal(newSVpvn(rpv, rlen));
+ rpv = SvPV(right, rlen); /* no point setting UTF8 here */
+ }
+
+ if (TARG != left) {
+ lpv = SvPV(left, llen); /* mg_get(left) may happen here */
+ lbyte = !SvUTF8(left);
+ sv_setpvn(TARG, lpv, llen);
+ if (!lbyte)
+ SvUTF8_on(TARG);
+ else
+ SvUTF8_off(TARG);
+ }
+ else { /* TARG == left */
+ if (SvGMAGICAL(left))
+ mg_get(left); /* or mg_get(left) may happen here */
+ if (!SvOK(TARG))
+ sv_setpv(left, "");
+ lpv = SvPV_nomg(left, llen);
+ lbyte = !SvUTF8(left);
+ }
#if defined(PERL_Y2KWARN)
if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
- STRLEN n;
- char *s = SvPV(TARG,n);
- if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
- && (n == 2 || !isDIGIT(s[n-3])))
- {
- Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
- "about to append an integer to '19'");
- }
+ if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
+ && (llen == 2 || !isDIGIT(lpv[llen - 3])))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
+ "about to append an integer to '19'");
+ }
}
#endif
- if (TARG == right) {
- if (left == right) {
- /* $right = $right . $right; */
- STRLEN rlen;
- char *rpv = SvPV(right, rlen);
-
- sv_catpvn(TARG, rpv, rlen);
+ if (lbyte != rbyte) {
+ if (lbyte)
+ sv_utf8_upgrade_nomg(TARG);
+ else {
+ sv_utf8_upgrade_nomg(right);
+ rpv = SvPV(right, rlen);
}
- else /* $right = $left . $right; */
- sv_catsv(TARG, rcopy);
- }
- else {
- if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
- sv_setpv(TARG, "");
- /* $other = $left . $right; */
- /* $left = $left . $right; */
- sv_catsv(TARG, right);
}
+ sv_catpvn_nomg(TARG, rpv, rlen);
SETTARG;
RETURN;
XPUSHs(TARG);
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
else if (PL_op->op_private & OPpDEREF) {
PUTBACK;
- vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
+ vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
SPAGAIN;
}
}
dSP; tryAMAGICbinSET(eq,0);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && SvROK(TOPm1s)) {
- SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s)));
+ SP--;
+ SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
RETURN;
}
#endif
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
- if (!auvok && !buvok) { /* ## IV == IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
+ if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
+ /* Casting IV to UV before comparison isn't going to matter
+ on 2s complement. On 1s complement or sign&magnitude
+ (if we have any of them) it could to make negative zero
+ differ from normal zero. As I understand it. (Need to
+ check - is negative zero implementation defined behaviour
+ anyway?). NWC */
+ UV buv = SvUVX(POPs);
+ UV auv = SvUVX(TOPs);
- SP--;
- SETs(boolSV(aiv == biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV == UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
-
- SP--;
SETs(boolSV(auv == buv));
RETURN;
}
{ /* ## Mixed IV,UV ## */
+ SV *ivp, *uvp;
IV iv;
- UV uv;
- /* == is commutative so swap if needed (save code) */
+ /* == is commutative so doesn't matter which is left or right */
if (auvok) {
- /* swap. top of stack (b) is the iv */
- iv = SvIVX(TOPs);
- SP--;
- if (iv < 0) {
- /* As (a) is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_no);
- RETURN;
- }
- uv = SvUVX(TOPs);
- } else {
- iv = SvIVX(TOPm1s);
- SP--;
- if (iv < 0) {
- /* As (b) is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_no);
- RETURN;
- }
- uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
- }
+ /* top of stack (b) is the iv */
+ ivp = *SP;
+ uvp = *--SP;
+ } else {
+ uvp = *SP;
+ ivp = *--SP;
+ }
+ iv = SvIVX(ivp);
+ if (iv < 0) {
+ /* As uv is a UV, it's >0, so it cannot be == */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
/* we know iv is >= 0 */
- if (uv > (UV) IV_MAX) {
- SETs(&PL_sv_no);
- RETURN;
- }
- SETs(boolSV((UV)iv == uv));
+ SETs(boolSV((UV)iv == SvUVX(uvp)));
RETURN;
}
}
PP(pp_preinc)
{
dSP;
- if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
- SvIVX(TOPs) != IV_MAX)
+ if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ && SvIVX(TOPs) != IV_MAX)
{
++SvIVX(TOPs);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
}
+PP(pp_dor)
+{
+ /* Most of this is lifted straight from pp_defined */
+ dSP;
+ register SV* sv;
+
+ sv = TOPs;
+ if (!sv || !SvANY(sv)) {
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+ }
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+ RETURN;
+ break;
+ case SVt_PVHV:
+ if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+ RETURN;
+ break;
+ case SVt_PVCV:
+ if (CvROOT(sv) || CvXSUB(sv))
+ RETURN;
+ break;
+ default:
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvOK(sv))
+ RETURN;
+ }
+
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+}
+
PP(pp_add)
{
dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
- register UV auv;
- bool auvok;
+ register UV auv = 0;
+ bool auvok = FALSE;
bool a_valid = 0;
if (!useleft) {
buv = (UV)-biv;
}
/* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
- else "IV" now, independant of how it came in.
+ else "IV" now, independent of how it came in.
if a, b represents positive, A, B negative, a maps to -A etc
a + b => (a + b)
A + b => -(a - b)
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
- if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
had_magic:
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
++SP;
}
PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj((SV*)gv, mg);
+ *MARK = SvTIED_obj((SV*)io, mg);
PUTBACK;
ENTER;
call_method("PRINT", G_SCALAR);
RETURN;
}
if (!(io = GvIO(gv))) {
- if ((GvEGV(gv))
- && (mg = SvTIED_mg((SV*)GvEGV(gv), PERL_MAGIC_tiedscalar)))
+ if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
- SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
+ SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
goto just_say_no;
}
else {
EXTEND(SP, maxarg);
if (SvRMAGICAL(av)) {
U32 i;
- for (i=0; i < maxarg; i++) {
+ for (i=0; i < (U32)maxarg; i++) {
SV **svp = av_fetch(av, i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
}
SP += maxarg;
}
- else {
+ else if (GIMME_V == G_SCALAR) {
dTARGET;
I32 maxarg = AvFILL(av) + 1;
SETi(maxarg);
tryAMAGICunDEREF(to_hv);
hv = (HV*)SvRV(sv);
- if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
+ if (SvTYPE(hv) != SVt_PVHV)
DIE(aTHX_ "Not a HASH reference");
if (PL_op->op_flags & OPf_REF) {
SETs((SV*)hv);
}
}
else {
- if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
+ if (SvTYPE(sv) == SVt_PVHV) {
hv = (HV*)sv;
if (PL_op->op_flags & OPf_REF) {
SETs((SV*)hv);
}
else {
dTARGET;
- if (SvTYPE(hv) == SVt_PVAV)
- hv = avhv_keys((AV*)hv);
if (HvFILL(hv))
Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
(IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
}
}
-STATIC int
-S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
- SV **lastrelem)
-{
- OP *leftop;
- I32 i;
-
- leftop = ((BINOP*)PL_op)->op_last;
- assert(leftop);
- assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
- leftop = ((LISTOP*)leftop)->op_first;
- assert(leftop);
- /* Skip PUSHMARK and each element already assigned to. */
- for (i = lelem - firstlelem; i > 0; i--) {
- leftop = leftop->op_sibling;
- assert(leftop);
- }
- if (leftop->op_type != OP_RV2HV)
- return 0;
-
- /* pseudohash */
- if (av_len(ary) > 0)
- av_fill(ary, 0); /* clear all but the fields hash */
- if (lastrelem >= relem) {
- while (relem < lastrelem) { /* gobble up all the rest */
- SV *tmpstr;
- assert(relem[0]);
- assert(relem[1]);
- /* Avoid a memory leak when avhv_store_ent dies. */
- tmpstr = sv_newmortal();
- sv_setsv(tmpstr,relem[1]); /* value */
- relem[1] = tmpstr;
- if (avhv_store_ent(ary,relem[0],tmpstr,0))
- (void)SvREFCNT_inc(tmpstr);
- if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- relem += 2;
- TAINT_NOT;
- }
- }
- if (relem == lastrelem)
- return 1;
- return 2;
-}
-
STATIC void
S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
{
if (*relem) {
SV *tmpstr;
- if (ckWARN(WARN_MISC)) {
+ HE *didstore;
+
+ if (ckWARN(WARN_MISC)) {
if (relem == firstrelem &&
SvROK(*relem) &&
(SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV))
{
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Reference found where even-sized list expected");
}
else
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Odd number of elements in hash assignment");
}
- if (SvTYPE(hash) == SVt_PVAV) {
- /* pseudohash */
- tmpstr = sv_newmortal();
- if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
- (void)SvREFCNT_inc(tmpstr);
- if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- }
- else {
- HE *didstore;
- tmpstr = NEWSV(29,0);
- didstore = hv_store_ent(hash,*relem,tmpstr,0);
- if (SvMAGICAL(hash)) {
- if (SvSMAGICAL(tmpstr))
- mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
- }
- }
- TAINT_NOT;
+
+ tmpstr = NEWSV(29,0);
+ didstore = hv_store_ent(hash,*relem,tmpstr,0);
+ if (SvMAGICAL(hash)) {
+ if (SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ if (!didstore)
+ sv_2mortal(tmpstr);
+ }
+ TAINT_NOT;
}
}
case SVt_PVAV:
ary = (AV*)sv;
magic = SvMAGICAL(ary) != 0;
- if (PL_op->op_private & OPpASSIGN_HASH) {
- switch (do_maybe_phash(ary, lelem, firstlelem, relem,
- lastrelem))
- {
- case 0:
- goto normal_array;
- case 1:
- do_oddball((HV*)ary, relem, firstrelem);
- }
- relem = lastrelem + 1;
- break;
- }
- normal_array:
av_clear(ary);
av_extend(ary, lastrelem - relem);
i = 0;
register PMOP *pm = cPMOP;
SV *rv = sv_newmortal();
SV *sv = newSVrv(rv, "Regexp");
- sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp), PERL_MAGIC_qr,0,0);
+ if (pm->op_pmdynflags & PMdf_TAINTED)
+ SvTAINTED_on(rv);
+ sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
RETURNX(PUSHs(rv));
}
{
dSP; dTARG;
register PMOP *pm = cPMOP;
+ PMOP *dynpm = pm;
register char *t;
register char *s;
char *strend;
I32 global;
I32 r_flags = REXEC_CHECKED;
char *truebase; /* Start of string */
- register REGEXP *rx = pm->op_pmregexp;
+ register REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
I32 gimme = GIMME;
STRLEN len;
TARG = DEFSV;
EXTEND(SP,1);
}
- PL_reg_sv = TARG;
+
PUTBACK; /* EVAL blocks need stack_sp. */
s = SvPV(TARG, len);
strend = s + len;
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
+ PL_reg_match_utf8 = DO_UTF8(TARG);
+
+ /* PMdf_USED is set after a ?? matches once */
if (pm->op_pmdynflags & PMdf_USED) {
failure:
if (gimme == G_ARRAY)
RETPUSHNO;
}
+ /* empty pattern special-cased to use last successful pattern if possible */
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
- rx = pm->op_pmregexp;
+ rx = PM_GETRE(pm);
}
- if (rx->minlen > len) goto failure;
+
+ if (rx->minlen > (I32)len)
+ goto failure;
truebase = t = s;
/* XXXX What part of this is needed with true \G-support? */
- if ((global = pm->op_pmflags & PMf_GLOBAL)) {
+ if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
rx->startp[0] = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
{
PL_curpm = pm;
- if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmdynflags |= PMdf_USED;
+ if (dynpm->op_pmflags & PMf_ONCE)
+ dynpm->op_pmdynflags |= PMdf_USED;
goto gotcha;
}
else
/*SUPPRESS 560*/
if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
len = rx->endp[i] - rx->startp[i];
+ if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
+ len < 0 || len > strend - s)
+ DIE(aTHX_ "panic: pp_match start/end pointers");
s = rx->startp[i] + truebase;
sv_setpvn(*SP, s, len);
- if (DO_UTF8(TARG))
+ if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
}
}
if (global) {
+ if (dynpm->op_pmflags & PMf_CONTINUE) {
+ MAGIC* mg = 0;
+ if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
+ mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ if (!mg) {
+ sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
+ mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ }
+ if (rx->startp[0] != -1) {
+ mg->mg_len = rx->endp[0];
+ if (rx->startp[0] == rx->endp[0])
+ mg->mg_flags |= MGf_MINMATCH;
+ else
+ mg->mg_flags &= ~MGf_MINMATCH;
+ }
+ }
had_zerolen = (rx->startp[0] != -1
&& rx->startp[0] == rx->endp[0]);
PUTBACK; /* EVAL blocks may use stack */
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
PL_curpm = pm;
- if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmdynflags |= PMdf_USED;
+ if (dynpm->op_pmflags & PMf_ONCE)
+ dynpm->op_pmdynflags |= PMdf_USED;
if (RX_MATCH_COPIED(rx))
Safefree(rx->subbeg);
RX_MATCH_COPIED_off(rx);
if (global) {
rx->subbeg = truebase;
rx->startp[0] = s - truebase;
- if (DO_UTF8(PL_reg_sv)) {
+ if (PL_reg_match_utf8) {
char *t = (char*)utf8_hop((U8*)s, rx->minlen);
rx->endp[0] = t - truebase;
}
nope:
ret_no:
- if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
+ if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg)
I32 gimme = GIMME_V;
MAGIC *mg;
- if ((mg = SvTIED_mg((SV*)PL_last_in_gv, PERL_MAGIC_tiedscalar))) {
+ if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
ENTER;
call_method("READLINE", gimme);
LEAVE;
SPAGAIN;
- if (gimme == G_SCALAR)
- SvSetMagicSV_nosteal(TARG, TOPs);
+ if (gimme == G_SCALAR) {
+ SV* result = POPs;
+ SvSetSV_nosteal(TARG, result);
+ PUSHTARG;
+ }
RETURN;
}
fp = Nullfp;
if (ckWARN2(WARN_GLOB, WARN_CLOSED)
&& (!io || !(IoFLAGS(io) & IOf_START))) {
if (type == OP_GLOB)
- Perl_warner(aTHX_ WARN_GLOB,
+ Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen)
Sv_Grow(sv, 80); /* try short-buffering it */
- if (type == OP_RCATLINE)
+ offset = 0;
+ if (type == OP_RCATLINE && SvOK(sv)) {
+ if (!SvPOK(sv)) {
+ STRLEN n_a;
+ (void)SvPV_force(sv, n_a);
+ }
offset = SvCUR(sv);
- else
- offset = 0;
+ }
}
else {
sv = sv_2mortal(NEWSV(57, 80));
}
else if (type == OP_GLOB) {
if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
- Perl_warner(aTHX_ WARN_GLOB,
+ Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (child exited with status %d%s)",
(int)(STATUS_CURRENT >> 8),
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
+#ifdef PERL_COPY_ON_WRITE
+ U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
+#else
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
- I32 preeminent;
+#endif
+ I32 preeminent = 0;
if (SvTYPE(hv) == SVt_PVHV) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ MAGIC *mg;
+ HV *stash;
+ /* does the element we're localizing already exist? */
+ preeminent =
+ /* can we determine whether it exists? */
+ ( !SvRMAGICAL(hv)
+ || mg_find((SV*)hv, PERL_MAGIC_env)
+ || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
+ /* Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise */
+ && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
+ && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
+ && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
+ )
+ ) ? hv_exists_ent(hv, keysv, 0) : 1;
+
+ }
he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : 0;
}
- else if (SvTYPE(hv) == SVt_PVAV) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- DIE(aTHX_ "Can't localize pseudo-hash element");
- svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
- }
else {
RETPUSHUNDEF;
}
SP = newsp;
else if (gimme == G_SCALAR) {
MARK = newsp + 1;
- if (MARK <= SP)
+ if (MARK <= SP) {
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
*MARK = TOPs;
else
*MARK = sv_mortalcopy(TOPs);
- else {
+ } else {
MEXTEND(mark,0);
*MARK = &PL_sv_undef;
}
STRLEN maxlen;
char *max = SvPV((SV*)av, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
-#ifndef USE_THREADS /* don't risk potential race */
+#ifndef USE_5005THREADS /* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
sv_setsv(*itersvp, cur);
if (cx->blk_loop.iterix > cx->blk_loop.itermax)
RETPUSHNO;
-#ifndef USE_THREADS /* don't risk potential race */
+#ifndef USE_5005THREADS /* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
sv_setiv(*itersvp, cx->blk_loop.iterix++);
bool rxtainted;
char *orig;
I32 r_flags;
- register REGEXP *rx = pm->op_pmregexp;
+ register REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
- bool do_utf8;
STRLEN slen;
+ bool doutf8 = FALSE;
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
TARG = DEFSV;
EXTEND(SP,1);
}
- PL_reg_sv = TARG;
- do_utf8 = DO_UTF8(PL_reg_sv);
- if (SvFAKE(TARG) && SvREADONLY(TARG))
- sv_force_normal(TARG);
+
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG,0);
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
rxtainted |= 2;
TAINT_NOT;
+ PL_reg_match_utf8 = DO_UTF8(TARG);
+
force_it:
if (!pm || !s)
DIE(aTHX_ "panic: pp_subst");
strend = s + len;
- slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
+ slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
maxiters = 2 * slen + 10; /* We can match twice at each
position, once with zero-length,
second time with non-zero. */
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
- rx = pm->op_pmregexp;
+ rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
? REXEC_COPY_STR : 0;
once = !(rpm->op_pmflags & PMf_GLOBAL);
/* known replacement string? */
- c = dstr ? SvPV(dstr, clen) : Nullch;
-
+ if (dstr) {
+ /* replacement needing upgrading? */
+ if (DO_UTF8(TARG) && !doutf8) {
+ SV *nsv = sv_newmortal();
+ SvSetSV(nsv, dstr);
+ if (PL_encoding)
+ sv_recode_to_utf8(nsv, PL_encoding);
+ else
+ sv_utf8_upgrade(nsv);
+ c = SvPV(nsv, clen);
+ doutf8 = TRUE;
+ }
+ else {
+ c = SvPV(dstr, clen);
+ doutf8 = DO_UTF8(dstr);
+ }
+ }
+ else {
+ c = Nullch;
+ doutf8 = FALSE;
+ }
+
/* can do inplace substitution? */
- if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
+ if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
SPAGAIN;
}
SvTAINT(TARG);
+ if (doutf8)
+ SvUTF8_on(TARG);
LEAVE_SCOPE(oldsave);
RETURN;
}
if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
{
- bool isutf8;
-
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
break;
} while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
TARG, NULL, r_flags));
- sv_catpvn(dstr, s, strend - s);
+ if (doutf8 && !DO_UTF8(dstr)) {
+ SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
+
+ sv_utf8_upgrade(nsv);
+ sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
+ }
+ else
+ sv_catpvn(dstr, s, strend - s);
(void)SvOOK_off(TARG);
Safefree(SvPVX(TARG));
SvPVX(TARG) = SvPVX(dstr);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
- isutf8 = DO_UTF8(dstr);
+ doutf8 |= DO_UTF8(dstr);
SvPVX(dstr) = 0;
sv_free(dstr);
PUSHs(sv_2mortal(newSViv((I32)iters)));
(void)SvPOK_only(TARG);
- if (isutf8)
+ if (doutf8)
SvUTF8_on(TARG);
TAINT_IF(rxtainted);
SvSETMAGIC(TARG);
else if (gimme == G_ARRAY) {
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
- if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+ if (*mark != &PL_sv_undef
+ && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
/* Might be flattened array after $#array = */
PUTBACK;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVE;
LEAVESUB(sv);
- DIE(aTHX_ "Can't return %s from lvalue subroutine",
- (*mark != &PL_sv_undef)
- ? (SvREADONLY(TOPs)
- ? "a readonly value" : "a temporary")
- : "an uninitialized value");
+ DIE(aTHX_ "Can't return a %s from lvalue subroutine",
+ SvREADONLY(TOPs) ? "readonly value" : "temporary");
}
else {
/* Can be a localized value subject to deletion. */
}
if (SvGMAGICAL(sv)) {
mg_get(sv);
+ if (SvROK(sv))
+ goto got_rv;
sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
}
else
cv = get_cv(sym, TRUE);
break;
}
+ got_rv:
{
SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
DIE(aTHX_ "No DBsub routine");
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
/*
* First we need to check if the sub or method requires locking.
* If so, we gain a lock on the CV, the first argument or the
if (SP > PL_stack_base + TOPMARK)
sv = *(PL_stack_base + TOPMARK + 1);
else {
- AV *av = (AV*)PL_curpad[0];
+ AV *av = (AV*)PAD_SVl(0);
if (hasargs || !av || AvFILLp(av) < 0
|| !(sv = AvARRAY(av)[0]))
{
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
- thr, sv);)
+ thr, sv));
MUTEX_UNLOCK(MgMUTEXP(mg));
SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
}
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
- CvDEPTH(cv)););
+ CvDEPTH(cv)));
SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
}
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
AV* av;
I32 items;
-#ifdef USE_THREADS
- av = (AV*)PL_curpad[0];
+#ifdef USE_5005THREADS
+ av = (AV*)PAD_SVl(0);
#else
av = GvAV(PL_defgv);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
items = AvFILLp(av) + 1; /* @_ is not tieable */
if (items) {
PL_curcopdb = NULL;
}
/* Do we need to open block here? XXXX */
- (void)(*CvXSUB(cv))(aTHXo_ cv);
+ (void)(*CvXSUB(cv))(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
dMARK;
register I32 items = SP - MARK;
AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
*/
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
- else { /* save temporaries on recursion? */
+ else {
PERL_STACK_OVERFLOW_CHECK();
- if (CvDEPTH(cv) > AvFILLp(padlist)) {
- AV *av;
- AV *newpad = newAV();
- SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILLp((AV*)svp[1]);
- I32 names_fill = AvFILLp((AV*)svp[0]);
- svp = AvARRAY(svp[0]);
- for ( ;ix > 0; ix--) {
- if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
- char *name = SvPVX(svp[ix]);
- if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
- || *name == '&') /* anonymous code? */
- {
- av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
- }
- else { /* our own lexical */
- if (*name == '@')
- av_store(newpad, ix, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix, sv = (SV*)newHV());
- else
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADMY_on(sv);
- }
- }
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
- av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
- }
- else {
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADTMP_on(sv);
- }
- }
- av = newAV(); /* will be @_ */
- av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
- av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILLp(padlist) = CvDEPTH(cv);
- svp = AvARRAY(padlist);
- }
+ pad_push(padlist, CvDEPTH(cv), 1);
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (!hasargs) {
- AV* av = (AV*)PL_curpad[0];
+ AV* av = (AV*)PAD_SVl(0);
items = AvFILLp(av) + 1;
if (items) {
PUTBACK ;
}
}
-#endif /* USE_THREADS */
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_THREADS
+#endif /* USE_5005THREADS */
+ PAD_SET_CUR(padlist, CvDEPTH(cv));
+#ifndef USE_5005THREADS
if (hasargs)
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
{
AV* av;
SV** ary;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"%p entersub preparing @_\n", thr));
#endif
- av = (AV*)PL_curpad[0];
+ av = (AV*)PAD_SVl(0);
if (AvREAL(av)) {
/* @_ is normally not REAL--this should only ever
* happen when DB::sub() calls things that modify @_ */
AvREAL_off(av);
AvREIFY_on(av);
}
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
+#endif /* USE_5005THREADS */
+ CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
++MARK;
Perl_sub_crush_depth(pTHX_ CV *cv)
{
if (CvANON(cv))
- Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
+ Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
+ Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
SvPVX(tmpstr));
}
}
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
if (elem > 0)
elem -= PL_curcop->cop_arybase;
if (SvTYPE(av) != SVt_PVAV)
HV* stash;
char* name;
STRLEN namelen;
- char* packname;
+ char* packname = 0;
STRLEN packlen;
name = SvPV(meth, namelen);
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
static void
-unset_cvowner(pTHXo_ void *cvarg)
+unset_cvowner(pTHX_ void *cvarg)
{
register CV* cv = (CV *) cvarg;
MUTEX_LOCK(CvMUTEXP(cv));
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
- CvDEPTH(cv)););
+ CvDEPTH(cv)));
assert(thr == CvOWNER(cv));
CvOWNER(cv) = 0;
MUTEX_UNLOCK(CvMUTEXP(cv));
SvREFCNT_dec(cv);
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */