X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=1b5f278e730675a3a8db98bf8dcb8e0cde1dbdc1;hb=7ed149c909e2812f62b12bd7d09f4ccfb79e0041;hp=90e8f5f4ba9c0757db2d354246b2c90f502ea3d6;hpb=a8bba7fac320f0a7f553e9a133cddd65ef2a66c7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 90e8f5f..1b5f278 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, 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. @@ -22,14 +22,6 @@ #ifdef I_UNISTD #include #endif -#ifdef I_FCNTL -#include -#endif -#ifdef I_SYS_FILE -#include -#endif - -#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off)) /* Hot code. */ @@ -40,7 +32,7 @@ static void unset_cvowner(pTHXo_ void *cvarg); PP(pp_const) { djSP; - XPUSHs(cSVOP->op_sv); + XPUSHs(cSVOP_sv); RETURN; } @@ -58,9 +50,9 @@ PP(pp_gvsv) djSP; EXTEND(SP,1); if (PL_op->op_private & OPpLVAL_INTRO) - PUSHs(save_scalar(cGVOP->op_gv)); + PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSV(cGVOP->op_gv)); + PUSHs(GvSV(cGVOP_gv)); RETURN; } @@ -88,6 +80,8 @@ PP(pp_stringify) char *s; s = SvPV(TOPs,len); sv_setpvn(TARG,s,len); + if (SvUTF8(TOPs) && !IN_BYTE) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -95,7 +89,7 @@ PP(pp_stringify) PP(pp_gv) { djSP; - XPUSHs((SV*)cGVOP->op_gv); + XPUSHs((SV*)cGVOP_gv); RETURN; } @@ -113,7 +107,6 @@ PP(pp_and) PP(pp_sassign) { djSP; dPOPTOPssrl; - MAGIC *mg; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; @@ -152,35 +145,91 @@ PP(pp_concat) { dPOPTOPssrl; STRLEN len; - char *s; + U8 *s; + bool left_utf = DO_UTF8(left); + bool right_utf = DO_UTF8(right); + + if (left_utf != right_utf) { + if (TARG == right && !right_utf) { + sv_utf8_upgrade(TARG); /* Now straight binary copy */ + SvUTF8_on(TARG); + } + else { + /* Set TARG to PV(left), then add right */ + U8 *l, *c, *olds = NULL; + STRLEN targlen; + if (TARG == right) { + /* Need a safe copy elsewhere since we're just about to + write onto TARG */ + olds = (U8*)SvPV(right,len); + s = (U8*)savepv((char*)olds); + } + else + s = (U8*)SvPV(right,len); + l = (U8*)SvPV(left, targlen); + if (TARG != left) + sv_setpvn(TARG, (char*)l, targlen); + if (!left_utf) + sv_utf8_upgrade(TARG); + /* Extend TARG to length of right (s) */ + targlen = SvCUR(TARG) + len; + if (!right_utf) { + /* plus one for each hi-byte char if we have to upgrade */ + for (c = s; *c; c++) { + if (*c & 0x80) + targlen++; + } + } + SvGROW(TARG, targlen+1); + /* And now copy, maybe upgrading right to UTF8 on the fly */ + for (c = (U8*)SvEND(TARG); *s; s++) { + if (*s & 0x80 && !right_utf) + c = uv_to_utf8(c, *s); + else + *c++ = *s; + } + SvCUR_set(TARG, targlen); + *SvEND(TARG) = '\0'; + SvUTF8_on(TARG); + SETs(TARG); + Safefree(olds); + RETURN; + } + } + if (TARG != left) { - s = SvPV(left,len); - sv_setpvn(TARG,s,len); + s = (U8*)SvPV(left,len); + if (TARG == right) { + sv_insert(TARG, 0, 0, (char*)s, len); + SETs(TARG); + RETURN; + } + sv_setpvn(TARG, (char *)s, len); } else if (SvGMAGICAL(TARG)) mg_get(TARG); - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { + else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) sv_setpv(TARG, ""); /* Suppress warning. */ - s = SvPV_force(TARG, len); - } - s = SvPV(right,len); + s = (U8*)SvPV(right,len); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) - if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_MISC)) { + 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]))) { - Perl_warner(aTHX_ WARN_MISC, "Possible Y2K bug: %s", + Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", "about to append an integer to '19'"); } } #endif - sv_catpvn(TARG,s,len); + sv_catpvn(TARG, (char *)s, len); } else - sv_setpvn(TARG,s,len); /* suppress warning */ + sv_setpvn(TARG, (char *)s, len); /* suppress warning */ + if (left_utf) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -271,7 +320,7 @@ PP(pp_add) PP(pp_aelemfast) { djSP; - AV *av = GvAV((GV*)cSVOP->op_sv); + AV *av = GvAV(cGVOP_gv); U32 lval = PL_op->op_flags & OPf_MOD; SV** svp = av_fetch(av, PL_op->op_private, lval); SV *sv = (svp ? *svp : &PL_sv_undef); @@ -326,7 +375,7 @@ PP(pp_print) gv = (GV*)*++MARK; else gv = PL_defoutgv; - if (mg = SvTIED_mg((SV*)gv, 'q')) { + if ((mg = SvTIED_mg((SV*)gv, 'q'))) { if (MARK == ORIGMARK) { /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... @@ -349,26 +398,31 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - if (ckWARN(WARN_UNOPENED)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", - SvPV(sv,n_a)); - } + dTHR; + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED, WARN_IO)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - if (IoIFP(io)) - Perl_warner(aTHX_ WARN_IO, - "Filehandle %s opened only for input", - SvPV(sv,n_a)); - else if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, - "print on closed filehandle %s", SvPV(sv,n_a)); + if (IoIFP(io)) { + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(gv)) { + SV* sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for input"); + } + else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -447,7 +501,7 @@ PP(pp_rv2av) if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -459,20 +513,24 @@ PP(pp_rv2av) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "an ARRAY"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (GIMME == G_ARRAY) { (void)POPs; RETURN; } RETSETUNDEF; } - sym = SvPV(sv,n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -547,7 +605,7 @@ PP(pp_rv2hv) if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -559,20 +617,24 @@ PP(pp_rv2hv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a HASH"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (GIMME == G_ARRAY) { SP--; RETURN; } RETSETUNDEF; } - sym = SvPV(sv,n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -612,6 +674,92 @@ PP(pp_rv2hv) } } +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)) { + if (relem == firstrelem && + SvROK(*relem) && + (SvTYPE(SvRV(*relem)) == SVt_PVAV || + SvTYPE(SvRV(*relem)) == SVt_PVHV)) + { + Perl_warner(aTHX_ WARN_MISC, + "Reference found where even-sized list expected"); + } + else + Perl_warner(aTHX_ 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; + } +} + PP(pp_aassign) { djSP; @@ -637,21 +785,22 @@ PP(pp_aassign) * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ - if (PL_op->op_private & OPpASSIGN_COMMON) { + if (PL_op->op_private & (OPpASSIGN_COMMON)) { EXTEND_MORTAL(lastrelem - firstrelem + 1); - for (relem = firstrelem; relem <= lastrelem; relem++) { - /*SUPPRESS 560*/ - if (sv = *relem) { + for (relem = firstrelem; relem <= lastrelem; relem++) { + /*SUPPRESS 560*/ + if ((sv = *relem)) { TAINT_NOT; /* Each item is independent */ - *relem = sv_mortalcopy(sv); + *relem = sv_mortalcopy(sv); } - } + } } relem = firstrelem; lelem = firstlelem; ary = Null(AV*); hash = Null(HV*); + while (lelem <= lastlelem) { TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; @@ -659,7 +808,19 @@ PP(pp_aassign) 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; @@ -679,7 +840,7 @@ PP(pp_aassign) TAINT_NOT; } break; - case SVt_PVHV: { + case SVt_PVHV: { /* normal hash */ SV *tmpstr; hash = (HV*)sv; @@ -706,27 +867,7 @@ PP(pp_aassign) TAINT_NOT; } if (relem == lastrelem) { - if (*relem) { - HE *didstore; - if (ckWARN(WARN_UNSAFE)) { - if (relem == firstrelem && - SvROK(*relem) && - ( SvTYPE(SvRV(*relem)) == SVt_PVAV || - SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) - Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected"); - else - Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment"); - } - tmpstr = NEWSV(29,0); - didstore = hv_store_ent(hash,*relem,tmpstr,0); - if (magic) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - if (!didstore) - sv_2mortal(tmpstr); - } - TAINT_NOT; - } + do_oddball(hash, relem, firstrelem); relem++; } } @@ -890,7 +1031,7 @@ PP(pp_match) truebase = t = s; /* XXXX What part of this is needed with true \G-support? */ - if (global = pm->op_pmflags & PMf_GLOBAL) { + if ((global = pm->op_pmflags & PMf_GLOBAL)) { rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); @@ -934,7 +1075,8 @@ play_it_again: && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) - && (r_flags & REXEC_SCREAM)))) + && (r_flags & REXEC_SCREAM))) + && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ goto yup; } if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) @@ -970,6 +1112,10 @@ play_it_again: len = rx->endp[i] - rx->startp[i]; s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); + if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { + SvUTF8_on(*SP); + sv_utf8_downgrade(*SP, TRUE); + } } } if (global) { @@ -1036,6 +1182,7 @@ yup: /* Confirmed by INTUIT */ rx->startp[0] = s - truebase; rx->endp[0] = s - truebase + rx->minlen; } + rx->nparens = rx->lastparen = 0; /* used by @- and @+ */ LEAVE_SCOPE(oldsave); RETPUSHYES; @@ -1067,7 +1214,7 @@ Perl_do_readline(pTHX) I32 gimme = GIMME_V; MAGIC *mg; - if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) { + if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); PUTBACK; @@ -1085,9 +1232,9 @@ Perl_do_readline(pTHX) if (!fp) { if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { - IoFLAGS(io) &= ~IOf_START; IoLINES(io) = 0; if (av_len(GvAVn(PL_last_in_gv)) < 0) { + IoFLAGS(io) &= ~IOf_START; do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); sv_setpvn(GvSV(PL_last_in_gv), "-", 1); SvSETMAGIC(GvSV(PL_last_in_gv)); @@ -1098,7 +1245,6 @@ Perl_do_readline(pTHX) fp = nextargv(PL_last_in_gv); if (!fp) { /* Note: fp != IoIFP(io) */ (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ - IoFLAGS(io) |= IOf_START; } } else if (type == OP_GLOB) { @@ -1190,6 +1336,11 @@ Perl_do_readline(pTHX) } } #else /* !VMS */ +#ifdef MACOS_TRADITIONAL + sv_setpv(tmpcmd, "glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#else #ifdef DOSISH #ifdef OS2 sv_setpv(tmpcmd, "for a in "); @@ -1221,6 +1372,7 @@ Perl_do_readline(pTHX) #endif #endif /* !CSH */ #endif /* !DOSISH */ +#endif /* MACOS_TRADITIONAL */ (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), FALSE, O_RDONLY, 0, Nullfp); fp = IoIFP(io); @@ -1234,25 +1386,29 @@ Perl_do_readline(pTHX) && (IoTYPE(io) == '>' || fp == PerlIO_stdout() || fp == PerlIO_stderr())) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, PL_last_in_gv, Nullch); - Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", - SvPV_nolen(sv)); + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(PL_last_in_gv)) { /* can this ever fail? */ + SV* sv = sv_newmortal(); + gv_efullname4(sv, PL_last_in_gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for output", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for output"); } } if (!fp) { - if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { + if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { if (type == OP_GLOB) - Perl_warner(aTHX_ WARN_CLOSED, + Perl_warner(aTHX_ WARN_GLOB, "glob failed (can't start child: %s)", Strerror(errno)); - else { - SV* sv = sv_newmortal(); - gv_efullname3(sv, PL_last_in_gv, Nullch); - Perl_warner(aTHX_ WARN_CLOSED, - "Read on closed filehandle %s", - SvPV_nolen(sv)); - } + else + report_evil_fh(PL_last_in_gv, io, PL_op->op_type); } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1279,12 +1435,10 @@ Perl_do_readline(pTHX) offset = 0; } -/* flip-flop EOF state for a snarfed empty file */ +/* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ - ((gimme != G_SCALAR || SvCUR(sv) \ - || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \ - ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \ - : ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + (gimme != G_SCALAR || SvCUR(sv) \ + || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { if (!sv_gets(sv, fp, offset) @@ -1296,13 +1450,12 @@ Perl_do_readline(pTHX) if (fp) continue; (void)do_close(PL_last_in_gv, FALSE); - IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { - if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) { - Perl_warner(aTHX_ WARN_CLOSED, + if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { + Perl_warner(aTHX_ WARN_GLOB, "glob failed (child exited with status %d%s)", - STATUS_CURRENT >> 8, + (int)(STATUS_CURRENT >> 8), (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } @@ -1318,6 +1471,7 @@ Perl_do_readline(pTHX) SvTAINTED_on(sv); } IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); XPUSHs(sv); if (type == OP_GLOB) { @@ -1505,12 +1659,14 @@ PP(pp_iter) register PERL_CONTEXT *cx; SV* sv; AV* av; + SV **itersvp; EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; if (CxTYPE(cx) != CXt_LOOP) DIE(aTHX_ "panic: pp_iter"); + itersvp = CxITERVAR(cx); av = cx->blk_loop.iterary; if (SvTYPE(av) != SVt_PVAV) { /* iterate ($min .. $max) */ @@ -1521,11 +1677,9 @@ PP(pp_iter) char *max = SvPV((SV*)av, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1 - && !SvMAGICAL(*cx->blk_loop.itervar)) - { + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setsv(*cx->blk_loop.itervar, cur); + sv_setsv(*itersvp, cur); } else #endif @@ -1533,8 +1687,8 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as * they used to */ - SvREFCNT_dec(*cx->blk_loop.itervar); - *cx->blk_loop.itervar = newSVsv(cur); + SvREFCNT_dec(*itersvp); + *itersvp = newSVsv(cur); } if (strEQ(SvPVX(cur), max)) sv_setiv(cur, 0); /* terminate next time */ @@ -1549,11 +1703,9 @@ PP(pp_iter) RETPUSHNO; #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1 - && !SvMAGICAL(*cx->blk_loop.itervar)) - { + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++); + sv_setiv(*itersvp, cx->blk_loop.iterix++); } else #endif @@ -1561,8 +1713,8 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they * used to */ - SvREFCNT_dec(*cx->blk_loop.itervar); - *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++); + SvREFCNT_dec(*itersvp); + *itersvp = newSViv(cx->blk_loop.iterix++); } RETPUSHYES; } @@ -1571,11 +1723,11 @@ PP(pp_iter) if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; - SvREFCNT_dec(*cx->blk_loop.itervar); + SvREFCNT_dec(*itersvp); - if (sv = (SvMAGICAL(av)) - ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) - : AvARRAY(av)[++cx->blk_loop.iterix]) + if ((sv = SvMAGICAL(av) + ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) + : AvARRAY(av)[++cx->blk_loop.iterix])) SvTEMP_off(sv); else sv = &PL_sv_undef; @@ -1599,7 +1751,7 @@ PP(pp_iter) sv = (SV*)lv; } - *cx->blk_loop.itervar = SvREFCNT_inc(sv); + *itersvp = SvREFCNT_inc(sv); RETPUSHYES; } @@ -1626,7 +1778,6 @@ PP(pp_subst) STRLEN len; int force_on_match = 0; I32 oldsave = PL_savestack_ix; - I32 update_minmatch = 1; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; @@ -1732,7 +1883,7 @@ PP(pp_subst) SvCUR_set(TARG, m - s); } /*SUPPRESS 560*/ - else if (i = m - s) { /* faster from front */ + else if ((i = m - s)) { /* faster from front */ d -= clen; m = d; sv_chop(TARG, d-i); @@ -1761,7 +1912,7 @@ PP(pp_subst) rxtainted |= RX_MATCH_TAINTED(rx); m = rx->startp[0] + orig; /*SUPPRESS 560*/ - if (i = m - s) { + if ((i = m - s)) { if (s != d) Move(s, d, i, char); d += i; @@ -1784,7 +1935,7 @@ PP(pp_subst) SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); TAINT_IF(rxtainted); if (SvSMAGICAL(TARG)) { PUTBACK; @@ -1896,7 +2047,7 @@ PP(pp_grepwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); @@ -1914,6 +2065,7 @@ PP(pp_leavesub) PMOP *newpm; I32 gimme; register PERL_CONTEXT *cx; + SV *sv; POPBLOCK(cx,newpm); @@ -1928,8 +2080,10 @@ PP(pp_leavesub) sv_2mortal(*MARK); } else { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ FREETMPS; - *MARK = sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } } else @@ -1951,10 +2105,11 @@ PP(pp_leavesub) } PUTBACK; - POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; + LEAVESUB(sv); return pop_return(); } @@ -1968,6 +2123,7 @@ PP(pp_leavesublv) PMOP *newpm; I32 gimme; register PERL_CONTEXT *cx; + SV *sv; POPBLOCK(cx,newpm); @@ -1995,7 +2151,7 @@ PP(pp_leavesublv) else { /* Can be a localized value subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc(*mark); + (void)SvREFCNT_inc(*mark); } } } @@ -2005,8 +2161,10 @@ PP(pp_leavesublv) * the refcounts so the caller gets a live guy. Cannot set * TEMP, so sv_2mortal is out of question. */ if (!CvLVALUE(cx->blk_sub.cv)) { - POPSUB(cx); + POPSUB(cx,sv); PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } if (gimme == G_SCALAR) { @@ -2014,20 +2172,24 @@ PP(pp_leavesublv) EXTEND_MORTAL(1); if (MARK == SP) { if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { - POPSUB(cx); + POPSUB(cx,sv); PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); DIE(aTHX_ "Can't return a %s from lvalue subroutine", SvREADONLY(TOPs) ? "readonly value" : "temporary"); } else { /* Can be a localized value * subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc(*mark); + (void)SvREFCNT_inc(*mark); } } else { /* Should not happen? */ - POPSUB(cx); + POPSUB(cx,sv); PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); DIE(aTHX_ "%s returned from lvalue subroutine in scalar context", (MARK > SP ? "Empty array" : "Array")); } @@ -2039,8 +2201,10 @@ PP(pp_leavesublv) if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { /* Might be flattened array after $#array = */ PUTBACK; - POPSUB(cx); + POPSUB(cx,sv); PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); DIE(aTHX_ "Can't return %s from lvalue subroutine", (*mark != &PL_sv_undef) ? (SvREADONLY(TOPs) @@ -2048,10 +2212,9 @@ PP(pp_leavesublv) : "an uninitialized value"); } else { - mortalize: /* Can be a localized value subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc(*mark); + (void)SvREFCNT_inc(*mark); } } } @@ -2068,8 +2231,10 @@ PP(pp_leavesublv) sv_2mortal(*MARK); } else { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ FREETMPS; - *MARK = sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } } else @@ -2093,10 +2258,11 @@ PP(pp_leavesublv) } PUTBACK; - POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; + LEAVESUB(sv); return pop_return(); } @@ -2118,15 +2284,17 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) && (gv = (GV*)*svp) ))) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ - sv_setsv(dbsv, newRV((SV*)cv)); + SV *tmp = newRV((SV*)cv); + sv_setsv(dbsv, tmp); + SvREFCNT_dec(tmp); } else { gv_efullname3(dbsv, gv, Nullch); } } else { - SvUPGRADE(dbsv, SVt_PVIV); - SvIOK_on(dbsv); + (void)SvUPGRADE(dbsv, SVt_PVIV); + (void)SvIOK_on(dbsv); SAVEIV(SvIVX(dbsv)); SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */ } @@ -2287,7 +2455,7 @@ try_autoload: DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n", thr, sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR(Perl_unlock_condpair, sv); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } MUTEX_LOCK(CvMUTEXP(cv)); } @@ -2332,7 +2500,7 @@ try_autoload: CvOWNER(cv) = thr; SvREFCNT_inc(cv); if (CvDEPTH(cv) == 0) - SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } else { /* (2) => grab ownership of cv. (3) => make clone */ @@ -2370,7 +2538,7 @@ try_autoload: DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", CvDEPTH(cv));); - SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } } #endif /* USE_THREADS */ @@ -2387,7 +2555,7 @@ try_autoload: SP--; } PL_stack_sp = mark + 1; - fp3 = (I32(*)(int,int,int)))CvXSUB(cv; + fp3 = (I32(*)(int,int,int))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, MARK - PL_stack_base + 1, items); @@ -2423,7 +2591,7 @@ try_autoload: } /* We assume first XSUB in &DB::sub is the called one. */ if (PL_curcopdb) { - SAVESPTR(PL_curcop); + SAVEVPTR(PL_curcop); PL_curcop = PL_curcopdb; PL_curcopdb = NULL; } @@ -2459,14 +2627,16 @@ try_autoload: if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ + 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 (svp[ix] != &PL_sv_undef) { + 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? */ @@ -2483,6 +2653,9 @@ try_autoload: 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); @@ -2511,7 +2684,7 @@ try_autoload: } } #endif /* USE_THREADS */ - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (hasargs) @@ -2525,11 +2698,18 @@ try_autoload: "%p entersub preparing @_\n", thr)); #endif av = (AV*)PL_curpad[0]; - assert(!AvREAL(av)); + if (AvREAL(av)) { + /* @_ is normally not REAL--this should only ever + * happen when DB::sub() calls things that modify @_ */ + av_clear(av); + 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->blk_sub.argarray = av; ++MARK; @@ -2686,7 +2866,6 @@ PP(pp_method_named) STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) { - djSP; SV* sv; SV* ob; GV* gv; @@ -2713,7 +2892,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) !(ob=(SV*)GvIO(iogv))) { if (!packname || - ((*(U8*)packname >= 0xc0 && IN_UTF8) + ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) )) @@ -2728,9 +2907,13 @@ S_method_common(pTHX_ SV* meth, U32* hashp) *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } - if (!ob || !SvOBJECT(ob)) + if (!ob || !(SvOBJECT(ob) + || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) + && SvOBJECT(ob)))) + { Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", name); + } stash = SvSTASH(ob); @@ -2751,6 +2934,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) char* leaf = name; char* sep = Nullch; char* p; + GV* gv; for (p = name; *p; p++) { if (*p == '\'') @@ -2759,16 +2943,25 @@ S_method_common(pTHX_ SV* meth, U32* hashp) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - packname = HvNAME(sep ? PL_curcop->cop_stash : stash); + packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash); packlen = strlen(packname); } else { packname = name; packlen = sep - name; } - Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"", - leaf, packname); + gv = gv_fetchpv(packname, 0, SVt_PVHV); + if (gv && isGV(gv)) { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"", + leaf, packname); + } + else { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"" + " (perhaps you forgot to load \"%s\"?)", + leaf, packname, packname); + } } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; }