/* 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 */
-
PP(pp_const)
{
- djSP;
+ dSP;
XPUSHs(cSVOP_sv);
RETURN;
}
PP(pp_gvsv)
{
- djSP;
+ dSP;
EXTEND(SP,1);
if (PL_op->op_private & OPpLVAL_INTRO)
PUSHs(save_scalar(cGVOP_gv));
PP(pp_stringify)
{
- djSP; dTARGET;
- STRLEN len;
- char *s;
- s = SvPV(TOPs,len);
- sv_setpvn(TARG,s,len);
- if (SvUTF8(TOPs) && !IN_BYTE)
- SvUTF8_on(TARG);
- else
- SvUTF8_off(TARG);
+ dSP; dTARGET;
+ sv_copypv(TARG,TOPs);
SETTARG;
RETURN;
}
PP(pp_gv)
{
- djSP;
+ dSP;
XPUSHs((SV*)cGVOP_gv);
RETURN;
}
PP(pp_and)
{
- djSP;
+ dSP;
if (!SvTRUE(TOPs))
RETURN;
else {
PP(pp_sassign)
{
- djSP; dPOPTOPssrl;
+ dSP; dPOPTOPssrl;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
SV *temp;
PP(pp_cond_expr)
{
- djSP;
+ dSP;
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
else
PP(pp_concat)
{
- djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+ 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);
-
- if (TARG == right) {
- if (left == right) {
- /* $right = $right . $right; */
- STRLEN rlen;
- char *rpv = SvPV(right, rlen);
-
- sv_catpvn(TARG, rpv, rlen);
- }
- else /* $right = $left . $right; */
- sv_catsv(TARG, rcopy);
+ 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 {
- if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
- sv_setpv(TARG, "");
- /* $other = $left . $right; */
- /* $left = $left . $right; */
- sv_catsv(TARG, right);
+ 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)) {
- STRLEN n;
- char *s = SvPV(TARG,n);
- if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
- && (n == 2 || !isDIGIT(s[n-3])))
+ if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
+ if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
+ && (llen == 2 || !isDIGIT(lpv[llen - 3])))
{
- Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
+ Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
"about to append an integer to '19'");
}
}
#endif
+ if (lbyte != rbyte) {
+ if (lbyte)
+ sv_utf8_upgrade_nomg(TARG);
+ else {
+ sv_utf8_upgrade_nomg(right);
+ rpv = SvPV(right, rlen);
+ }
+ }
+ sv_catpvn_nomg(TARG, rpv, rlen);
+
SETTARG;
RETURN;
}
PP(pp_padsv)
{
- djSP; dTARGET;
+ dSP; dTARGET;
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;
}
}
PP(pp_eq)
{
- djSP; tryAMAGICbinSET(eq,0);
+ dSP; tryAMAGICbinSET(eq,0);
+#ifndef NV_PRESERVES_UV
+ if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
+ RETURN;
+ }
+#endif
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
- /* 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. */
+ /* 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. */
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
- if (!auvok && !buvok) { /* ## IV == IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
-
- SP--;
- SETs(boolSV(aiv == biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV == UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(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(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)
{
- djSP;
- if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ dSP;
+ 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_or)
{
- djSP;
+ dSP;
if (SvTRUE(TOPs))
RETURN;
else {
}
}
+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)
{
- djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
+ dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
useleft = USE_LEFT(TOPm1s);
#ifdef PERL_PRESERVE_IVUV
/* We must see if we can perform the addition with integers if possible,
public IOK flag if the value in the NV (or PV) slot is truly integer.
A side effect is that this also aggressively prefers integer maths over
- fp maths for integer values. */
+ fp maths for integer values.
+
+ How to detect overflow?
+
+ C 99 section 6.2.6.1 says
+
+ The range of nonnegative values of a signed integer type is a subrange
+ of the corresponding unsigned integer type, and the representation of
+ the same value in each type is the same. A computation involving
+ unsigned operands can never overflow, because a result that cannot be
+ represented by the resulting unsigned integer type is reduced modulo
+ the number that is one greater than the largest value that can be
+ represented by the resulting type.
+
+ (the 9th paragraph)
+
+ which I read as "unsigned ints wrap."
+
+ signed integer overflow seems to be classed as "exception condition"
+
+ If an exceptional condition occurs during the evaluation of an
+ expression (that is, if the result is not mathematically defined or not
+ in the range of representable values for its type), the behavior is
+ undefined.
+
+ (6.5, the 5th paragraph)
+
+ I had assumed that on 2s complement machines signed arithmetic would
+ wrap, hence coded pp_add and pp_subtract on the assumption that
+ everything perl builds on would be happy. After much wailing and
+ gnashing of teeth it would seem that irix64 knows its ANSI spec well,
+ knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
+ unsigned code below is actually shorter than the old code. :-)
+ */
+
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
/* 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 = 0;
+ bool auvok = FALSE;
+ bool a_valid = 0;
+
if (!useleft) {
- /* left operand is undef, treat as zero. + 0 is identity. */
- if (SvUOK(TOPs)) {
- dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
- SETu(value);
- RETURN;
- } else {
- dPOPiv;
- SETi(value);
- RETURN;
+ auv = 0;
+ a_valid = auvok = 1;
+ /* left operand is undef, treat as zero. + 0 is identity,
+ Could SETi or SETu right now, but space optimise by not adding
+ lots of code to speed up what is probably a rarish case. */
+ } else {
+ /* Left operand is defined, so is it IV? */
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ if ((auvok = SvUOK(TOPm1s)))
+ auv = SvUVX(TOPm1s);
+ else {
+ register IV aiv = SvIVX(TOPm1s);
+ if (aiv >= 0) {
+ auv = aiv;
+ auvok = 1; /* Now acting as a sign flag. */
+ } else { /* 2s complement assumption for IV_MIN */
+ auv = (UV)-aiv;
+ }
+ }
+ a_valid = 1;
}
}
- /* Left operand is defined, so is it IV? */
- SvIV_please(TOPm1s);
- if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
+ if (a_valid) {
+ bool result_good = 0;
+ UV result;
+ register UV buv;
bool buvok = SvUOK(TOPs);
- if (!auvok && !buvok) { /* ## IV + IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
- IV result = aiv + biv;
-
- if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
- SP--;
- SETi( result );
- RETURN;
- }
- if (biv >=0 && aiv >= 0) {
- UV result = (UV)aiv + (UV)biv;
- /* UV + UV can only get bigger... */
- if (result >= (UV) aiv) {
- SP--;
- SETu( result );
- RETURN;
+ if (buvok)
+ buv = SvUVX(TOPs);
+ else {
+ register IV biv = SvIVX(TOPs);
+ if (biv >= 0) {
+ buv = biv;
+ buvok = 1;
+ } else
+ buv = (UV)-biv;
+ }
+ /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
+ 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)
+ a + B => (a - b)
+ A + B => -(a + b)
+ all UV maths. negate result if A negative.
+ add if signs same, subtract if signs differ. */
+
+ if (auvok ^ buvok) {
+ /* Signs differ. */
+ if (auv >= buv) {
+ result = auv - buv;
+ /* Must get smaller */
+ if (result <= auv)
+ result_good = 1;
+ } else {
+ result = buv - auv;
+ if (result <= buv) {
+ /* result really should be -(auv-buv). as its negation
+ of true value, need to swap our result flag */
+ auvok = !auvok;
+ result_good = 1;
}
}
- /* Overflow, drop through to NVs (beyond next if () else ) */
- } else if (auvok && buvok) { /* ## UV + UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
- UV result = auv + buv;
- if (result >= auv) {
- SP--;
+ } else {
+ /* Signs same */
+ result = auv + buv;
+ if (result >= auv)
+ result_good = 1;
+ }
+ if (result_good) {
+ SP--;
+ if (auvok)
SETu( result );
- RETURN;
- }
- /* Overflow, drop through to NVs (beyond next if () else ) */
- } else { /* ## Mixed IV,UV ## */
- IV aiv;
- UV buv;
-
- /* addition is commutative so swap if needed (save code) */
- if (buvok) {
- aiv = SvIVX(TOPm1s);
- buv = SvUVX(TOPs);
- } else {
- aiv = SvIVX(TOPs);
- buv = SvUVX(TOPm1s);
- }
-
- if (aiv >= 0) {
- UV result = (UV)aiv + buv;
- if (result >= buv) {
- SP--;
- SETu( result );
- RETURN;
- }
- } else if (buv > (UV) IV_MAX) {
- /* assuming 2s complement means that IV_MIN == -IV_MIN,
- and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
- as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
- as the value we can be subtracting from it only lies in
- the range (-IV_MIN to -1) it can't overflow a UV */
- SP--;
- SETu( buv - (UV)-aiv );
- RETURN;
- } else {
- IV result = (IV) buv + aiv;
- /* aiv < 0 so it must get smaller. */
- if (result < (IV) buv) {
- SP--;
- SETi( result );
- RETURN;
+ else {
+ /* Negate result */
+ if (result <= (UV)IV_MIN)
+ SETi( -(IV)result );
+ else {
+ /* result valid, but out of range for IV. */
+ SETn( -(NV)result );
}
}
- } /* end of IV+IV / UV+UV / mixed */
+ RETURN;
+ } /* Overflow, drop through to NVs. */
}
}
#endif
PP(pp_aelemfast)
{
- djSP;
+ dSP;
AV *av = GvAV(cGVOP_gv);
U32 lval = PL_op->op_flags & OPf_MOD;
SV** svp = av_fetch(av, PL_op->op_private, lval);
PP(pp_join)
{
- djSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
MARK++;
do_join(TARG, *MARK, MARK, SP);
SP = MARK;
PP(pp_pushre)
{
- djSP;
+ dSP;
#ifdef DEBUGGING
/*
* We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
PP(pp_print)
{
- djSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
GV *gv;
IO *io;
register PerlIO *fp;
MAGIC *mg;
- STRLEN n_a;
if (PL_op->op_flags & OPf_STACKED)
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
- if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
+
+ 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),'q')))
+ 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 {
PP(pp_rv2av)
{
- djSP; dTOPss;
+ dSP; dTOPss;
AV *av;
if (SvROK(sv)) {
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);
PP(pp_rv2hv)
{
- djSP; dTOPss;
+ dSP; dTOPss;
HV *hv;
if (SvROK(sv)) {
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;
}
}
PP(pp_aassign)
{
- djSP;
+ dSP;
SV **lastlelem = PL_stack_sp;
SV **lastrelem = PL_stack_base + POPMARK;
SV **firstrelem = PL_stack_base + POPMARK + 1;
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;
PP(pp_qr)
{
- djSP;
+ dSP;
register PMOP *pm = cPMOP;
SV *rv = sv_newmortal();
SV *sv = newSVrv(rv, "Regexp");
- sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',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));
}
PP(pp_match)
{
- djSP; dTARG;
+ 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, 'g');
+ MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
if (!(rx->reganch & ROPT_GPOS_SEEN))
rx->endp[0] = rx->startp[0] = mg->mg_len;
}
}
}
- if ((gimme != G_ARRAY && !global && rx->nparens)
+ if ((!global && rx->nparens)
|| SvTEMP(TARG) || PL_sawampersand)
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
}
if (rx->reganch & RE_USE_INTUIT &&
DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
+ PL_bostr = truebase;
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
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 */
if (global) {
MAGIC* mg = 0;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
- mg = mg_find(TARG, 'g');
+ mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (!mg) {
- sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
- mg = mg_find(TARG, 'g');
+ 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];
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, 'g');
+ MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg)
mg->mg_len = -1;
}
I32 gimme = GIMME_V;
MAGIC *mg;
- if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
+ 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;
}
else if (type == OP_GLOB)
SP--;
- else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
- && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
- || fp == PerlIO_stderr()))
+ else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
+ }
}
if (!fp) {
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));
|| (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
for (;;) {
+ PUTBACK;
if (!sv_gets(sv, fp, offset)
&& (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
{
}
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" : "");
}
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
+ SPAGAIN;
PUSHTARG;
}
MAYBE_TAINT_LINE(io, sv);
IoLINES(io)++;
IoFLAGS(io) |= IOf_NOLINE;
SvSETMAGIC(sv);
+ SPAGAIN;
XPUSHs(sv);
if (type == OP_GLOB) {
char *tmps;
PP(pp_enter)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme = OP_GIMME(PL_op, -1);
PP(pp_helem)
{
- djSP;
+ dSP;
HE* he;
SV **svp;
SV *keysv = POPs;
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;
}
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
+ sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
SvREFCNT_dec(key2); /* sv_magic() increments refcount */
LvTARG(lv) = SvREFCNT_inc(hv);
LvTARGLEN(lv) = 1;
PP(pp_leave)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
register SV **mark;
SV **newsp;
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;
}
PP(pp_iter)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
SV* sv;
AV* av;
STRLEN maxlen;
char *max = SvPV((SV*)av, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
-#ifndef USE_THREADS /* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
sv_setsv(*itersvp, cur);
}
else
-#endif
{
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as
if (cx->blk_loop.iterix > cx->blk_loop.itermax)
RETPUSHNO;
-#ifndef USE_THREADS /* don't risk potential race */
+ /* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
sv_setiv(*itersvp, cx->blk_loop.iterix++);
}
else
-#endif
{
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as they
SvREFCNT_dec(*itersvp);
- if ((sv = SvMAGICAL(av)
- ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
- : AvARRAY(av)[++cx->blk_loop.iterix]))
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ if (svp)
+ sv = *svp;
+ else
+ sv = Nullsv;
+ }
+ else {
+ sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ }
+ if (sv)
SvTEMP_off(sv);
else
sv = &PL_sv_undef;
- if (av != PL_curstack && SvIMMORTAL(sv)) {
+ if (av != PL_curstack && sv == &PL_sv_undef) {
SV *lv = cx->blk_loop.iterlval;
if (lv && SvREFCNT(lv) > 1) {
SvREFCNT_dec(lv);
lv = cx->blk_loop.iterlval = NEWSV(26, 0);
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, Nullsv, 'y', Nullch, 0);
+ sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
}
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = cx->blk_loop.iterix;
PP(pp_subst)
{
- djSP; dTARG;
+ dSP; dTARG;
register PMOP *pm = cPMOP;
PMOP *rpm = pm;
register SV *dstr;
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;
}
orig = m = s;
if (rx->reganch & RE_USE_INTUIT) {
+ PL_bostr = orig;
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
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);
PP(pp_grepwhile)
{
- djSP;
+ dSP;
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
PP(pp_leavesub)
{
- djSP;
+ dSP;
SV **mark;
SV **newsp;
PMOP *newpm;
* get any slower by more conditions */
PP(pp_leavesublv)
{
- djSP;
+ dSP;
SV **mark;
SV **newsp;
PMOP *newpm;
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. */
PP(pp_entersub)
{
- djSP; dPOPss;
+ dSP; dPOPss;
GV *gv;
HV *stash;
register CV *cv;
}
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
- /*
- * 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
- * stash (for static methods), as appropriate. This has to be
- * inline because for FAKE_THREADS, COND_WAIT inlines code to
- * reschedule by returning a new op.
- */
- MUTEX_LOCK(CvMUTEXP(cv));
- if (CvFLAGS(cv) & CVf_LOCKED) {
- MAGIC *mg;
- if (CvFLAGS(cv) & CVf_METHOD) {
- if (SP > PL_stack_base + TOPMARK)
- sv = *(PL_stack_base + TOPMARK + 1);
- else {
- AV *av = (AV*)PL_curpad[0];
- if (hasargs || !av || AvFILLp(av) < 0
- || !(sv = AvARRAY(av)[0]))
- {
- MUTEX_UNLOCK(CvMUTEXP(cv));
- DIE(aTHX_ "no argument for locked method call");
- }
- }
- if (SvROK(sv))
- sv = SvRV(sv);
- else {
- STRLEN len;
- char *stashname = SvPV(sv, len);
- sv = (SV*)gv_stashpvn(stashname, len, TRUE);
- }
- }
- else {
- sv = (SV*)cv;
- }
- MUTEX_UNLOCK(CvMUTEXP(cv));
- mg = condpair_magic(sv);
- MUTEX_LOCK(MgMUTEXP(mg));
- if (MgOWNER(mg) == thr)
- MUTEX_UNLOCK(MgMUTEXP(mg));
- else {
- while (MgOWNER(mg))
- COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
- MgOWNER(mg) = thr;
- DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
- thr, sv);)
- MUTEX_UNLOCK(MgMUTEXP(mg));
- SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
- }
- MUTEX_LOCK(CvMUTEXP(cv));
- }
- /*
- * Now we have permission to enter the sub, we must distinguish
- * four cases. (0) It's an XSUB (in which case we don't care
- * about ownership); (1) it's ours already (and we're recursing);
- * (2) it's free (but we may already be using a cached clone);
- * (3) another thread owns it. Case (1) is easy: we just use it.
- * Case (2) means we look for a clone--if we have one, use it
- * otherwise grab ownership of cv. Case (3) means we look for a
- * clone (for non-XSUBs) and have to create one if we don't
- * already have one.
- * Why look for a clone in case (2) when we could just grab
- * ownership of cv straight away? Well, we could be recursing,
- * i.e. we originally tried to enter cv while another thread
- * owned it (hence we used a clone) but it has been freed up
- * and we're now recursing into it. It may or may not be "better"
- * to use the clone but at least CvDEPTH can be trusted.
- */
- if (CvOWNER(cv) == thr || CvXSUB(cv))
- MUTEX_UNLOCK(CvMUTEXP(cv));
- else {
- /* Case (2) or (3) */
- SV **svp;
-
- /*
- * XXX Might it be better to release CvMUTEXP(cv) while we
- * do the hv_fetch? We might find someone has pinched it
- * when we look again, in which case we would be in case
- * (3) instead of (2) so we'd have to clone. Would the fact
- * that we released the mutex more quickly make up for this?
- */
- if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
- {
- /* We already have a clone to use */
- MUTEX_UNLOCK(CvMUTEXP(cv));
- cv = *(CV**)svp;
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "entersub: %p already has clone %p:%s\n",
- thr, cv, SvPEEK((SV*)cv)));
- CvOWNER(cv) = thr;
- SvREFCNT_inc(cv);
- if (CvDEPTH(cv) == 0)
- SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
- }
- else {
- /* (2) => grab ownership of cv. (3) => make clone */
- if (!CvOWNER(cv)) {
- CvOWNER(cv) = thr;
- SvREFCNT_inc(cv);
- MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "entersub: %p grabbing %p:%s in stash %s\n",
- thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
- HvNAME(CvSTASH(cv)) : "(none)"));
- }
- else {
- /* Make a new clone. */
- CV *clonecv;
- SvREFCNT_inc(cv); /* don't let it vanish from under us */
- MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_S((PerlIO_printf(Perl_debug_log,
- "entersub: %p cloning %p:%s\n",
- thr, cv, SvPEEK((SV*)cv))));
- /*
- * We're creating a new clone so there's no race
- * between the original MUTEX_UNLOCK and the
- * SvREFCNT_inc since no one will be trying to undef
- * it out from underneath us. At least, I don't think
- * there's a race...
- */
- clonecv = cv_clone(cv);
- SvREFCNT_dec(cv); /* finished with this */
- hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
- CvOWNER(clonecv) = thr;
- cv = clonecv;
- SvREFCNT_inc(cv);
- }
- DEBUG_S(if (CvDEPTH(cv) != 0)
- PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
- CvDEPTH(cv)););
- SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
- }
- }
-#endif /* USE_THREADS */
-
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
if (CvOLDSTYLE(cv)) {
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
AV* av;
I32 items;
-#ifdef USE_THREADS
- av = (AV*)PL_curpad[0];
-#else
av = GvAV(PL_defgv);
-#endif /* USE_THREADS */
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);
- }
- }
-#ifdef USE_THREADS
- if (!hasargs) {
- AV* av = (AV*)PL_curpad[0];
-
- items = AvFILLp(av) + 1;
- if (items) {
- /* Mark is at the end of the stack. */
- EXTEND(SP, items);
- Copy(AvARRAY(av), SP + 1, items, SV*);
- SP += items;
- PUTBACK ;
- }
- }
-#endif /* USE_THREADS */
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_THREADS
+ pad_push(padlist, CvDEPTH(cv), 1);
+ }
+ PAD_SET_CUR(padlist, CvDEPTH(cv));
if (hasargs)
-#endif /* USE_THREADS */
{
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
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
+ 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));
}
}
PP(pp_aelem)
{
- djSP;
+ dSP;
SV** svp;
SV* elemsv = POPs;
IV elem = SvIV(elemsv);
U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
SV *sv;
- if (SvROK(elemsv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
+ if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
+ 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)
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, Nullsv, 'y', Nullch, 0);
+ sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = elem;
LvTARGLEN(lv) = 1;
PP(pp_method)
{
- djSP;
+ dSP;
SV* sv = TOPs;
if (SvROK(sv)) {
PP(pp_method_named)
{
- djSP;
+ dSP;
SV* sv = cSVOP->op_sv;
U32 hash = SvUVX(sv);
HV* stash;
char* name;
STRLEN namelen;
- char* packname;
+ char* packname = 0;
STRLEN packlen;
name = SvPV(meth, namelen);
Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
if (SvGMAGICAL(sv))
- mg_get(sv);
+ mg_get(sv);
if (SvROK(sv))
ob = (SV*)SvRV(sv);
else {
GV* iogv;
+ /* this isn't a reference */
packname = Nullch;
if (!SvOK(sv) ||
!(packname = SvPV(sv, packlen)) ||
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
+ /* this isn't the name of a filehandle either */
if (!packname ||
((UTF8_IS_START(*packname) && DO_UTF8(sv))
? !isIDFIRST_utf8((U8*)packname)
SvOK(sv) ? "without a package or object reference"
: "on an undefined value");
}
- stash = gv_stashpvn(packname, packlen, TRUE);
+ /* assume it's a package name */
+ stash = gv_stashpvn(packname, packlen, FALSE);
goto fetch;
}
+ /* it _is_ a filehandle name -- replace with a reference */
*(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
}
+ /* if we got here, ob should be a reference or a glob */
if (!ob || !(SvOBJECT(ob)
|| (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
&& SvOBJECT(ob))))
stash = SvSTASH(ob);
fetch:
+ /* NOTE: stash may be null, hope hv_fetch_ent and
+ gv_fetchmethod can cope (it seems they can) */
+
/* shortcut for simple names */
if (hashp) {
HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
}
gv = gv_fetchmethod(stash, name);
+
if (!gv) {
+ /* This code tries to figure out just what went wrong with
+ gv_fetchmethod. It therefore needs to duplicate a lot of
+ the internals of that function. We can't move it inside
+ Perl_gv_fetchmethod_autoload(), however, since that would
+ cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
+ don't want that.
+ */
char* leaf = name;
char* sep = Nullch;
char* p;
- GV* gv;
for (p = name; *p; p++) {
if (*p == '\'')
sep = p, leaf = p + 2;
}
if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
- packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
+ /* the method name is unqualified or starts with SUPER:: */
+ packname = sep ? CopSTASHPV(PL_curcop) :
+ stash ? HvNAME(stash) : packname;
packlen = strlen(packname);
}
else {
+ /* the method name is qualified */
packname = name;
packlen = sep - name;
}
- gv = gv_fetchpv(packname, 0, SVt_PVHV);
- if (gv && isGV(gv)) {
+
+ /* we're relying on gv_fetchmethod not autovivifying the stash */
+ if (gv_stashpvn(packname, packlen, FALSE)) {
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%s\"",
- leaf, packname);
+ "Can't locate object method \"%s\" via package \"%.*s\"",
+ leaf, (int)packlen, packname);
}
else {
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%s\""
- " (perhaps you forgot to load \"%s\"?)",
- leaf, packname, packname);
+ "Can't locate object method \"%s\" via package \"%.*s\""
+ " (perhaps you forgot to load \"%.*s\"?)",
+ leaf, (int)packlen, packname, (int)packlen, packname);
}
}
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
}
-
-#ifdef USE_THREADS
-static void
-unset_cvowner(pTHXo_ void *cvarg)
-{
- register CV* cv = (CV *) cvarg;
-
- DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
- thr, cv, SvPEEK((SV*)cv))));
- MUTEX_LOCK(CvMUTEXP(cv));
- DEBUG_S(if (CvDEPTH(cv) != 0)
- PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
- CvDEPTH(cv)););
- assert(thr == CvOWNER(cv));
- CvOWNER(cv) = 0;
- MUTEX_UNLOCK(CvMUTEXP(cv));
- SvREFCNT_dec(cv);
-}
-#endif /* USE_THREADS */
https://perl5.git.perl.org / perl5.git / blobdiff