X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=86bd41967d2b65ebf6ae4d22fe75a3f62aca26b3;hb=31686daff9c699afe57f28ff395bbc6d383a696c;hp=b07a1fbed37ad6d65315e9790f3a50939a1bc076;hpb=f472eb5c07ed95306a11c98250bda17aae994339;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index b07a1fb..86bd419 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.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,19 +22,6 @@ /* #define PL_OP_SLAB_ALLOC */ -/* XXXXXX testing */ -#ifdef USE_ITHREADS -# define OP_REFCNT_LOCK NOOP -# define OP_REFCNT_UNLOCK NOOP -# define OpREFCNT_set(o,n) ((o)->op_targ = (n)) -# define OpREFCNT_dec(o) (--(o)->op_targ) -#else -# define OP_REFCNT_LOCK NOOP -# define OP_REFCNT_UNLOCK NOOP -# define OpREFCNT_set(o,n) NOOP -# define OpREFCNT_dec(o) 0 -#endif - #ifdef PL_OP_SLAB_ALLOC #define SLAB_SIZE 8192 static char *PL_OpPtr = NULL; @@ -124,11 +111,10 @@ Perl_pad_allocmy(pTHX_ char *name) PADOFFSET off; SV *sv; - if (!( - PL_in_my == KEY_our || - isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || - name[1] == '_' && (int)strlen(name) > 2 )) + if (!(PL_in_my == KEY_our || + isALPHA(name[1]) || + (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || + (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ @@ -151,26 +137,43 @@ Perl_pad_allocmy(pTHX_ char *name) } yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } - if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) { + if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) { SV **svp = AvARRAY(PL_comppad_name); - for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) { + HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash); + PADOFFSET top = AvFILLp(PL_comppad_name); + for (off = top; off > PL_comppad_name_floor; off--) { if ((sv = svp[off]) && sv != &PL_sv_undef && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) + && (PL_in_my != KEY_our + || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)) && strEQ(name, SvPVX(sv))) { - if (PL_in_my != KEY_our - || GvSTASH(sv) == (PL_curstash ? PL_curstash : PL_defstash)) - { - Perl_warner(aTHX_ WARN_UNSAFE, - "\"%s\" variable %s masks earlier declaration in same %s", - (PL_in_my == KEY_our ? "our" : "my"), - name, - (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); - } + Perl_warner(aTHX_ WARN_MISC, + "\"%s\" variable %s masks earlier declaration in same %s", + (PL_in_my == KEY_our ? "our" : "my"), + name, + (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); + --off; break; } } + if (PL_in_my == KEY_our) { + do { + if ((sv = svp[off]) + && sv != &PL_sv_undef + && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) + && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) + && strEQ(name, SvPVX(sv))) + { + Perl_warner(aTHX_ WARN_MISC, + "\"our\" variable %s redeclared", name); + Perl_warner(aTHX_ WARN_MISC, + "\t(Did you mean \"local\" instead of \"our\"?)\n"); + break; + } + } while ( off-- > 0 ); + } } off = pad_alloc(OP_PADSV, SVs_PADMY); sv = NEWSV(1102,0); @@ -178,8 +181,8 @@ Perl_pad_allocmy(pTHX_ char *name) sv_setpv(sv, name); if (PL_in_my_stash) { if (*name != '$') - yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"my\"", - name)); + yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", + name, PL_in_my == KEY_our ? "our" : "my")); SvOBJECT_on(sv); (void)SvUPGRADE(sv, SVt_PVMG); SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash); @@ -187,7 +190,7 @@ Perl_pad_allocmy(pTHX_ char *name) } if (PL_in_my == KEY_our) { (void)SvUPGRADE(sv, SVt_PVGV); - GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? PL_curstash : PL_defstash); + GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash); SvFLAGS(sv) |= SVpad_OUR; } av_store(PL_comppad_name, off, sv); @@ -204,6 +207,31 @@ Perl_pad_allocmy(pTHX_ char *name) return off; } +STATIC PADOFFSET +S_pad_addlex(pTHX_ SV *proto_namesv) +{ + SV *namesv = NEWSV(1103,0); + PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY); + sv_upgrade(namesv, SVt_PVNV); + sv_setpv(namesv, SvPVX(proto_namesv)); + av_store(PL_comppad_name, newoff, namesv); + SvNVX(namesv) = (NV)PL_curcop->cop_seq; + SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */ + SvFAKE_on(namesv); /* A ref, not a real var */ + if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */ + SvFLAGS(namesv) |= SVpad_OUR; + (void)SvUPGRADE(namesv, SVt_PVGV); + GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv)); + } + if (SvOBJECT(proto_namesv)) { /* A typed var */ + SvOBJECT_on(namesv); + (void)SvUPGRADE(namesv, SVt_PVMG); + SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv)); + PL_sv_objcount++; + } + return newoff; +} + #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */ STATIC PADOFFSET @@ -246,28 +274,10 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } depth = 1; } - oldpad = (AV*)*av_fetch(curlist, depth, FALSE); + oldpad = (AV*)AvARRAY(curlist)[depth]; oldsv = *av_fetch(oldpad, off, TRUE); if (!newoff) { /* Not a mere clone operation. */ - SV *namesv = NEWSV(1103,0); - newoff = pad_alloc(OP_PADSV, SVs_PADMY); - sv_upgrade(namesv, SVt_PVNV); - sv_setpv(namesv, name); - av_store(PL_comppad_name, newoff, namesv); - SvNVX(namesv) = (NV)PL_curcop->cop_seq; - SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */ - SvFAKE_on(namesv); /* A ref, not a real var */ - if (SvOBJECT(sv)) { /* A typed var */ - SvOBJECT_on(namesv); - (void)SvUPGRADE(namesv, SVt_PVMG); - SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(sv)); - PL_sv_objcount++; - } - if (SvFLAGS(sv) & SVpad_OUR) { /* An "our" variable */ - SvFLAGS(namesv) |= SVpad_OUR; - (void)SvUPGRADE(namesv, SVt_PVGV); - GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(sv)); - } + newoff = pad_addlex(sv); if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) { /* "It's closures all the way down." */ CvCLONE_on(PL_compcv); @@ -281,8 +291,23 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, bcv && bcv != cv && !CvCLONE(bcv); bcv = CvOUTSIDE(bcv)) { - if (CvANON(bcv)) + if (CvANON(bcv)) { + /* install the missing pad entry in intervening + * nested subs and mark them cloneable. + * XXX fix pad_foo() to not use globals */ + AV *ocomppad_name = PL_comppad_name; + AV *ocomppad = PL_comppad; + SV **ocurpad = PL_curpad; + AV *padlist = CvPADLIST(bcv); + PL_comppad_name = (AV*)AvARRAY(padlist)[0]; + PL_comppad = (AV*)AvARRAY(padlist)[1]; + PL_curpad = AvARRAY(PL_comppad); + pad_addlex(sv); + PL_comppad_name = ocomppad_name; + PL_comppad = ocomppad; + PL_curpad = ocurpad; CvCLONE_on(bcv); + } else { if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(bcv) && !CvUNIQUE(cv)) @@ -297,9 +322,12 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } } else if (!CvUNIQUE(PL_compcv)) { - if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)) + if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv) + && !(SvFLAGS(sv) & SVpad_OUR)) + { Perl_warner(aTHX_ WARN_CLOSURE, "Variable \"%s\" will not stay shared", name); + } } } av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv)); @@ -331,8 +359,9 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, if (CxREALEVAL(cx)) saweval = i; break; + case OP_DOFILE: case OP_REQUIRE: - /* require must have its own scope */ + /* require/do must have their own scope */ return 0; } break; @@ -755,6 +784,7 @@ S_op_clear(pTHX_ OP *o) cSVOPo->op_sv = Nullsv; #endif break; + case OP_METHOD_NAMED: case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; @@ -814,8 +844,8 @@ S_cop_free(pTHX_ COP* cop) { Safefree(cop->cop_label); #ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXXXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXXXX share in a pvtable? */ + Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ + Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ #else /* NOTE: COP.cop_stash is not refcounted */ SvREFCNT_dec(CopFILEGV(cop)); @@ -937,7 +967,7 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - while (kid = kid->op_sibling) { + while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else @@ -1076,7 +1106,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GGRGID: case OP_GETLOGIN: func_ops: - if (!(o->op_private & OPpLVAL_INTRO)) + if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) useless = PL_op_desc[o->op_type]; break; @@ -1135,7 +1165,6 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: - case OP_SCALAR: if (!(o->op_flags & OPf_KIDS)) break; /* FALL THROUGH */ @@ -1154,6 +1183,8 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_REQUIRE: /* all requires must return a boolean value */ o->op_flags &= ~OPf_WANT; + /* FALL THROUGH */ + case OP_SCALAR: return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { @@ -1230,7 +1261,7 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - while (kid = kid->op_sibling) { + while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else @@ -1300,7 +1331,6 @@ Perl_mod(pTHX_ OP *o, I32 type) { dTHR; OP *kid; - SV *sv; STRLEN n_a; if (!o || PL_error_count) @@ -1373,18 +1403,19 @@ Perl_mod(pTHX_ OP *o, I32 type) if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { - OP *newop; + UNOP *newop; if (kid->op_sibling || kid->op_next != kid) { yyerror("panic: unexpected optree near method call"); break; } - NewOp(1101, newop, 1, OP); + NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; - newop->op_next = newop; - kid->op_sibling = newop; + newop->op_first = Nullop; + newop->op_next = (OP*)newop; + kid->op_sibling = (OP*)newop; newop->op_private |= OPpLVAL_INTRO; break; } @@ -1691,7 +1722,7 @@ Perl_ref(pTHX_ OP *o, I32 type) switch (o->op_type) { case OP_ENTERSUB: - if ((type == OP_DEFINED || type == OP_LOCK) && + if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; @@ -1796,7 +1827,6 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - OP *modname; /* for 'use' */ SV *stashsv; /* fake up C */ @@ -1806,22 +1836,52 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) stashsv = newSVpv(HvNAME(stash), 0); else stashsv = &PL_sv_no; + #define ATTRSMODULE "attributes" - modname = newSVOP(OP_CONST, 0, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); - modname->op_private |= OPpCONST_BARE; - /* that flag is required to make 'use' work right */ - utilize(1, start_subparse(FALSE, 0), - Nullop, /* version */ - modname, - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, newRV(target)), - dup_attrlist(attrs)))); + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); LEAVE; } +void +Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, + char *attrstr, STRLEN len) +{ + OP *attrs = Nullop; + + if (!len) { + len = strlen(attrstr); + } + + while (len) { + for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; + if (len) { + char *sstr = attrstr; + for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(sstr, attrstr-sstr))); + } + } + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV((SV*)cv)), + attrs))); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs) { @@ -1847,7 +1907,9 @@ S_my_kid(pTHX_ OP *o, OP *attrs) type != OP_PADHV && type != OP_PUSHMARK) { - yyerror(Perl_form(aTHX_ "Can't declare %s in my", PL_op_desc[o->op_type])); + yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", + PL_op_desc[o->op_type], + PL_in_my == KEY_our ? "our" : "my")); return o; } else if (attrs && type != OP_PUSHMARK) { @@ -1855,6 +1917,9 @@ S_my_kid(pTHX_ OP *o, OP *attrs) SV *padsv; SV **namesvp; + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + /* check for C when deciding package */ namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE); if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp))) @@ -1874,11 +1939,12 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) { if (o->op_flags & OPf_PARENS) list(o); - PL_in_my = FALSE; - PL_in_my_stash = Nullhv; if (attrs) SAVEFREEOP(attrs); - return my_kid(o, attrs); + o = my_kid(o, attrs); + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + return o; } OP * @@ -1901,7 +1967,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) dTHR; OP *o; - if (ckWARN(WARN_UNSAFE) && + if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || @@ -1912,16 +1978,19 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) const char *sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) ? "@array" : "%hash"); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_MISC, "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } - if (right->op_type == OP_MATCH || + if (!(right->op_flags & OPf_STACKED) && + (right->op_type == OP_MATCH || right->op_type == OP_SUBST || - right->op_type == OP_TRANS) { + right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if (right->op_type != OP_MATCH) + if (right->op_type != OP_MATCH && + ! (right->op_type == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL)) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -1986,12 +2055,11 @@ Perl_block_start(pTHX_ int full) int retval = PL_savestack_ix; SAVEI32(PL_comppad_name_floor); - if (full) { - if ((PL_comppad_name_fill = AvFILLp(PL_comppad_name)) > 0) - PL_comppad_name_floor = PL_comppad_name_fill; - else - PL_comppad_name_floor = 0; - } + PL_comppad_name_floor = AvFILLp(PL_comppad_name); + if (full) + PL_comppad_name_fill = PL_comppad_name_floor; + if (PL_comppad_name_floor < 0) + PL_comppad_name_floor = 0; SAVEI32(PL_min_intro_pending); SAVEI32(PL_max_intro_pending); PL_min_intro_pending = 0; @@ -2006,8 +2074,6 @@ Perl_block_start(pTHX_ int full) PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } - - return retval; } @@ -2092,16 +2158,18 @@ Perl_localize(pTHX_ OP *o, I32 lex) char *s; for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') - Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list", - lex ? "my" : "local"); + Perl_warner(aTHX_ WARN_PARENTHESIS, + "Parentheses missing around \"%s\" list", + lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); } } - PL_in_my = FALSE; - PL_in_my_stash = Nullhv; if (lex) - return my(o); + o = my(o); else - return mod(o, OP_NULL); /* a bit kludgey */ + o = mod(o, OP_NULL); /* a bit kludgey */ + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + return o; } OP * @@ -2310,8 +2378,11 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) if (!last) return first; - if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS) - return newLISTOP(type, 0, first, last); + if (first->op_type != type + || (type == OP_LIST && (first->op_flags & OPf_PARENS))) + { + return newLISTOP(type, 0, first, last); + } if (first->op_flags & OPf_KIDS) ((LISTOP*)first)->op_last->op_sibling = last; @@ -2537,6 +2608,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) complement = o->op_private & OPpTRANS_COMPLEMENT; del = o->op_private & OPpTRANS_DELETE; squash = o->op_private & OPpTRANS_SQUASH; + + if (SvUTF8(tstr)) + o->op_private |= OPpTRANS_FROM_UTF; + + if (SvUTF8(rstr)) + o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* listsv = newSVpvn("# comment\n",10); @@ -2557,12 +2634,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 grows = 0; I32 havefinal = 0; U32 final; - HV *hv; I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; I32 to_utf = o->op_private & OPpTRANS_TO_UTF; if (complement) { - U8 tmpbuf[10]; + U8 tmpbuf[UTF8_MAXLEN]; U8** cp; UV nextmin = 0; New(1109, cp, tlen, U8*); @@ -2609,15 +2685,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) r = t; rlen = tlen; rend = tend; } if (!squash) { - if (to_utf && from_utf) { /* only counting characters */ - if (t == r || (tlen == rlen && memEQ(t, r, tlen))) - o->op_private |= OPpTRANS_IDENTICAL; - } - else { /* straight latin-1 translation */ - if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) && - rlen == 4 && memEQ(r, "\0\377\303\277", 4)) + if (t == r || + (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) + { o->op_private |= OPpTRANS_IDENTICAL; - } + } } while (t < tend || tfirst <= tlast) { @@ -2664,15 +2736,19 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (rfirst == 0xffffffff) { diff = tdiff; /* oops, pretend rdiff is infinite */ if (diff > 0) - Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\tXXXX\n", tfirst, tlast); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", + (long)tfirst, (long)tlast); else - Perl_sv_catpvf(aTHX_ listsv, "%04x\t\tXXXX\n", tfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { if (diff > 0) - Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\t%04x\n", tfirst, tfirst + diff, rfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", + (long)tfirst, (long)(tfirst + diff), + (long)rfirst); else - Perl_sv_catpvf(aTHX_ listsv, "%04x\t\t%04x\n", tfirst, rfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", + (long)tfirst, (long)rfirst); if (rfirst + diff > max) max = rfirst + diff; @@ -2712,7 +2788,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SvREFCNT_dec(transv); if (!del && havefinal) - (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSViv((IV)final), 0); + (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, + newSVuv((UV)final), 0); if (grows && to_utf) o->op_private |= OPpTRANS_GROWS; @@ -2819,12 +2896,16 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } + if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE))) + pm->op_pmdynflags |= PMdf_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm); if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; op_free(expr); } else { + if (PL_hints & HINT_UTF8) + pm->op_pmdynflags |= PMdf_UTF8; if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET @@ -3042,7 +3123,6 @@ void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) { OP *pack; - OP *meth; OP *rqop; OP *imop; OP *veop; @@ -3053,45 +3133,55 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) veop = Nullop; - if(version != Nullop) { + if (version != Nullop) { SV *vesv = ((SVOP*)version)->op_sv; - if (arg == Nullop && !SvNIOK(vesv)) { + if (arg == Nullop && !SvNIOKp(vesv)) { arg = version; } else { OP *pack; + SV *meth; - if (version->op_type != OP_CONST || !SvNIOK(vesv)) + if (version->op_type != OP_CONST || !SvNIOKp(vesv)) Perl_croak(aTHX_ "Version number must be constant number"); /* Make copy of id so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); /* Fake up a method call to VERSION */ + meth = newSVpvn("VERSION",7); + sv_upgrade(meth, SVt_PVIV); + (void)SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(version)), - newSVOP(OP_METHOD_NAMED, 0, - newSVpvn("VERSION", 7)))); + prepend_elem(OP_LIST, pack, list(version)), + newSVOP(OP_METHOD_NAMED, 0, meth))); } } /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) imop = arg; /* no import on explicit () */ - else if(SvNIOK(((SVOP*)id)->op_sv)) { + else if (SvNIOKp(((SVOP*)id)->op_sv)) { imop = Nullop; /* use 5.0; */ } else { + SV *meth; + /* Make copy of id so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + + /* Fake up a method call to import/unimport */ + meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);; + sv_upgrade(meth, SVt_PVIV); + (void)SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(arg)), - newSVOP(OP_METHOD_NAMED, 0, - aver ? newSVpvn("import", 6) - : newSVpvn("unimport", 8)))); + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newSVOP(OP_METHOD_NAMED, 0, meth))); } /* Fake up a require, handle override, if any */ @@ -3126,6 +3216,65 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) PL_expect = XSTATE; } +void +Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#ifdef PERL_IMPLICIT_CONTEXT +void +Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) +{ + dTHX; + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} +#endif + +void +Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) +{ + OP *modname, *veop, *imop; + + modname = newSVOP(OP_CONST, 0, name); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = Nullop; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = Nullop; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + line_t ocopline = PL_copline; + int oexpect = PL_expect; + + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + PL_expect = oexpect; + PL_copline = ocopline; + } +} + OP * Perl_dofile(pTHX_ OP *term) { @@ -3210,6 +3359,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (list_assignment(left)) { dTHR; + OP *curop; + PL_modcount = 0; PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ left = mod(left, OP_AASSIGN); @@ -3220,12 +3371,19 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) op_free(right); return Nullop; } - o = newBINOP(OP_AASSIGN, flags, - list(force_list(right)), - list(force_list(left)) ); + curop = list(force_list(left)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); o->op_private = 0 | (flags >> 8); + for (curop = ((LISTOP*)curop)->op_first; + curop; curop = curop->op_sibling) + { + if (curop->op_type == OP_RV2HV && + ((UNOP*)curop)->op_first->op_type != OP_GV) { + o->op_private |= OPpASSIGN_HASH; + break; + } + } if (!(left->op_private & OPpLVAL_INTRO)) { - OP *curop; OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { @@ -3269,7 +3427,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) lastop = curop; } if (curop != o) - o->op_private = OPpASSIGN_COMMON; + o->op_private |= OPpASSIGN_COMMON; } if (right && right->op_type == OP_SPLIT) { OP* tmpop; @@ -3351,7 +3509,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } cop->op_flags = flags; - cop->op_private = (PL_hints & HINT_UTF8); + cop->op_private = (PL_hints & HINT_BYTE); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif @@ -3377,9 +3535,9 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) PL_copline = NOLINE; } #ifdef USE_ITHREADS - CopFILE_set(cop, CopFILE(PL_curcop)); /* XXXXX share in a pvtable? */ + CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else - CopFILEGV_set(cop, (GV*)SvREFCNT_inc(CopFILEGV(PL_curcop))); + CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif CopSTASH_set(cop, PL_curstash); @@ -3452,9 +3610,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } if (first->op_type == OP_CONST) { - if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE)) - Perl_warner(aTHX_ WARN_PRECEDENCE, "Probable precedence problem on %s", - PL_op_desc[type]); + if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); *firstp = Nullop; @@ -3472,7 +3629,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) else scalar(other); } - else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) { + else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; @@ -3501,7 +3658,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (warnop) { line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_MISC, "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) @@ -3702,6 +3859,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * OP *listop; OP *o; OP *condop; + U8 loopflags = 0; if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { @@ -3730,11 +3888,19 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (!block) block = newOP(OP_NULL, 0); + else if (cont) { + block = scope(block); + } - if (cont) + if (cont) { next = LINKLIST(cont); + loopflags |= OPpLOOP_CONTINUE; + } if (expr) { - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + OP *unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { PL_copline = whileline; cont = append_elem(OP_LINESEQ, cont, @@ -3757,8 +3923,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (listop) ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); - if (!next) - next = condop; } else o = listop; @@ -3775,6 +3939,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * loop->op_redoop = redo; loop->op_lastop = o; + o->op_private |= loopflags; if (next) loop->op_nextop = next; @@ -3790,7 +3955,6 @@ OP * Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) { LOOP *loop; - LOOP *tmp; OP *wop; int padoff = 0; I32 iterflags = 0; @@ -3865,9 +4029,12 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo append_elem(OP_LIST, expr, scalar(sv)))); assert(!loop->op_next); #ifdef PL_OP_SLAB_ALLOC - NewOp(1234,tmp,1,LOOP); - Copy(loop,tmp,1,LOOP); - loop = tmp; + { + LOOP *tmp; + NewOp(1234,tmp,1,LOOP); + Copy(loop,tmp,1,LOOP); + loop = tmp; + } #else Renew(loop, 1, LOOP); #endif @@ -4001,7 +4168,7 @@ S_cv_dump(pTHX_ CV *cv) if (SvPOK(pname[ix])) PerlIO_printf(Perl_debug_log, "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n", - ix, PTR2UV(ppad[ix]), + (int)ix, PTR2UV(ppad[ix]), SvFAKE(pname[ix]) ? "FAKE " : "", SvPVX(pname[ix]), (IV)I_32(SvNVX(pname[ix])), @@ -4029,16 +4196,14 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) assert(!CvUNIQUE(proto)); ENTER; - SAVEVPTR(PL_curpad); - SAVESPTR(PL_comppad); + SAVECOMPPAD(); SAVESPTR(PL_comppad_name); SAVESPTR(PL_compcv); cv = PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)cv, SvTYPE(proto)); + CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE; CvCLONED_on(cv); - if (CvANON(proto)) - CvANON_on(cv); #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); @@ -4160,7 +4325,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { dTHR; - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_UNSAFE)) { + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4168,7 +4333,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) gv_efullname3(name = sv_newmortal(), gv, Nullch); sv_setpv(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %_", name); + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); if (SvPOK(cv)) Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv)); sv_catpv(msg, " vs "); @@ -4176,7 +4341,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else sv_catpv(msg, "none"); - Perl_warner(aTHX_ WARN_UNSAFE, "%_", msg); + Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg); } } @@ -4193,10 +4358,10 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) { SV *sv = Nullsv; - if(!o) + if (!o) return Nullsv; - if(o->op_type == OP_LINESEQ && cLISTOPo->op_first) + if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) o = cLISTOPo->op_first->op_sibling; for (; o; o = o->op_next) { @@ -4251,14 +4416,26 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { dTHR; STRLEN n_a; - char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; - GV *gv = gv_fetchpv(name ? name : "__ANON__", - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV); + char *name; + char *aname; + GV *gv; char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; I32 ix; + name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; + if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { + SV *sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]", + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + aname = SvPVX(sv); + } + else + aname = Nullch; + gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"), + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV); + if (o) SAVEFREEOP(o); if (proto) @@ -4270,9 +4447,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) - && ckWARN_d(WARN_UNSAFE)) + && ckWARN_d(WARN_PROTOTYPE)) { - Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype"); + Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype"); } cv_ckproto((CV*)gv, NULL, ps); } @@ -4288,10 +4465,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!name || GvCVGEN(gv)) cv = Nullcv; - else if (cv = GvCV(gv)) { - cv_ckproto(cv, gv, ps); + else if ((cv = GvCV(gv))) { + bool exists = CvROOT(cv) || CvXSUB(cv); + /* if the subroutine doesn't exist and wasn't pre-declared + * with a prototype, assume it will be AUTOLOADed, + * skipping the prototype check + */ + if (exists || SvPOK(cv)) + cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ - if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + if (exists || GvASSUMECV(gv)) { SV* const_sv; bool const_changed = TRUE; if (!block && !attrs) { @@ -4304,13 +4487,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); if (!block) goto withattrs; - if(const_sv = cv_const_sv(cv)) + if ((const_sv = cv_const_sv(cv))) const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv)); - if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE) - && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && HvNAME(GvSTASH(CvGV(cv))) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), - "autouse"))) { + if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)) + { line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ WARN_REDEFINE, @@ -4465,14 +4645,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } - if (name) { + if (name || aname) { char *s; + char *tname = (name ? name : aname); if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV *sv = NEWSV(0,0); SV *tmpstr = sv_newmortal(); GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); - CV *cv; + CV *pcv; HV *hv; Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", @@ -4482,21 +4663,22 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) - && (cv = GvCV(db_postponed))) { + && (pcv = GvCV(db_postponed))) + { dSP; PUSHMARK(SP); XPUSHs(tmpstr); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)pcv, G_DISCARD); } } - if ((s = strrchr(name,':'))) + if ((s = strrchr(tname,':'))) s++; else - s = name; + s = tname; - if (*s != 'B' && *s != 'E' && *s != 'S' && *s != 'I') + if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') goto done; if (strEQ(s, "BEGIN")) { @@ -4510,8 +4692,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_beginav) PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; @@ -4523,23 +4705,27 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_endav = newAV(); DEBUG_x( dump_sub(gv) ); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } - else if (strEQ(s, "STOP") && !PL_error_count) { - if (!PL_stopav) - PL_stopav = newAV(); + else if (strEQ(s, "CHECK") && !PL_error_count) { + if (!PL_checkav) + PL_checkav = newAV(); DEBUG_x( dump_sub(gv) ); - av_unshift(PL_stopav, 1); - av_store(PL_stopav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); + av_unshift(PL_checkav, 1); + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT") && !PL_error_count) { if (!PL_initav) PL_initav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } @@ -4550,16 +4736,26 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } /* XXX unsafe for threads if eval_owner isn't held */ +/* +=for apidoc newCONSTSUB + +Creates a constant sub equivalent to Perl C which is +eligible for inlining at compile-time. + +=cut +*/ + void Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) { dTHR; ENTER; - SAVECOPLINE(PL_curcop); - SAVEHINTS(); + SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); + + SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { @@ -4584,6 +4780,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) LEAVE; } +/* +=for apidoc U||newXS + +Used by C to hook up XSUBs as Perl subs. + +=cut +*/ + CV * Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) { @@ -4591,7 +4795,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; - if (cv = (name ? GvCV(gv) : Nullcv)) { + if ((cv = (name ? GvCV(gv) : Nullcv))) { if (GvCVGEN(gv)) { /* just a cached method */ SvREFCNT_dec(cv); @@ -4642,34 +4846,38 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else s = name; - if (*s != 'B' && *s != 'E' && *s != 'S' && *s != 'I') + if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') goto done; if (strEQ(s, "BEGIN")) { if (!PL_beginav) PL_beginav = newAV(); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "END")) { if (!PL_endav) PL_endav = newAV(); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; - } - else if (strEQ(s, "STOP")) { - if (!PL_stopav) - PL_stopav = newAV(); - av_unshift(PL_stopav, 1); - av_store(PL_stopav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ + } + else if (strEQ(s, "CHECK")) { + if (!PL_checkav) + PL_checkav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); + av_unshift(PL_checkav, 1); + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } else @@ -4695,7 +4903,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); GvMULTI_on(gv); - if (cv = GvFORM(gv)) { + if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { line_t oldline = CopLINE(PL_curcop); @@ -5013,6 +5221,20 @@ Perl_ck_eval(pTHX_ OP *o) } OP * +Perl_ck_exit(pTHX_ OP *o) +{ +#ifdef VMS + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); + if (svp && *svp && SvTRUE(*svp)) + o->op_private |= OPpEXIT_VMSISH; + } +#endif + return ck_fun(o); +} + +OP * Perl_ck_exec(pTHX_ OP *o) { OP *kid; @@ -5033,7 +5255,14 @@ Perl_ck_exists(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type == OP_AELEM) + if (kid->op_type == OP_ENTERSUB) { + (void) ref(kid, o->op_type); + if (kid->op_type != OP_RV2CV && !PL_error_count) + Perl_croak(aTHX_ "%s argument is not a subroutine name", + PL_op_desc[o->op_type]); + o->op_private |= OPpEXISTS_SUB; + } + else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", @@ -5152,6 +5381,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + SvREFCNT_dec(PL_curpad[kPADOP->op_padix]); GvIN_PAD_on(gv); PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); #else @@ -5224,7 +5454,7 @@ Perl_ck_fun(pTHX_ OP *o) tokid = &cLISTOPo->op_first; kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || - kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK) + (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { tokid = &kid->op_sibling; kid = kid->op_sibling; @@ -5260,8 +5490,8 @@ Perl_ck_fun(pTHX_ OP *o) char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, "Array @%s missing the @ in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5280,8 +5510,8 @@ Perl_ck_fun(pTHX_ OP *o) char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, "Hash %%%s missing the %% in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5348,11 +5578,18 @@ Perl_ck_fun(pTHX_ OP *o) name = GvNAME(gv); len = GvNAMELEN(gv); } + else if (kid->op_type == OP_AELEM + || kid->op_type == OP_HELEM) + { + name = "__ANONIO__"; + len = 10; + mod(kid,type); + } if (name) { SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PL_curpad[targ]; - SvUPGRADE(namesv, SVt_PV); + (void)SvUPGRADE(namesv, SVt_PV); if (*name != '$') sv_setpvn(namesv, "$", 1); sv_catpvn(namesv, name, len); @@ -5400,6 +5637,7 @@ Perl_ck_glob(pTHX_ OP *o) { GV *gv; + o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) append_elem(OP_GLOB, o, newDEFSVOP()); @@ -5409,11 +5647,10 @@ Perl_ck_glob(pTHX_ OP *o) #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { - OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10)); - modname->op_private |= OPpCONST_BARE; ENTER; - utilize(1, start_subparse(FALSE, 0), Nullop, modname, - newSVOP(OP_CONST, 0, newSVpvn(":globally", 9))); + Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv, + /* null-terminated import list */ + newSVpvn(":globally", 9), Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); LEAVE; } @@ -5438,7 +5675,7 @@ Perl_ck_glob(pTHX_ OP *o) gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); scalarkids(o); - return ck_fun(o); + return o; } OP * @@ -5532,15 +5769,15 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ Perl_warner(aTHX_ WARN_DEPRECATED, "defined(@array) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: break; /* Globals via GV can be undef */ case OP_PADHV: Perl_warner(aTHX_ WARN_DEPRECATED, - "defined(%hash) is deprecated"); + "defined(%%hash) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ @@ -5615,7 +5852,9 @@ Perl_ck_sassign(pTHX_ OP *o) OP *kid = cLISTOPo->op_first; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) - && !(kid->op_flags & OPf_STACKED)) + && !(kid->op_flags & OPf_STACKED) + /* Cannot steal the second time! */ + && !(kid->op_private & OPpTARGET_MY)) { OP *kkid = kid->op_sibling; @@ -5664,8 +5903,8 @@ Perl_ck_method(pTHX_ OP *o) SV* sv = kSVOP->op_sv; if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { OP *cmop; - sv_upgrade(sv, SVt_PVIV); - SvIOK_on(sv); + (void)SvUPGRADE(sv, SVt_PVIV); + (void)SvIOK_on(sv); PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv)); cmop = newSVOP(OP_METHOD_NAMED, 0, sv); kSVOP->op_sv = Nullsv; @@ -5683,6 +5922,36 @@ Perl_ck_null(pTHX_ OP *o) } OP * +Perl_ck_open(pTHX_ OP *o) +{ + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp; + I32 mode; + svp = hv_fetch(table, "open_IN", 7, FALSE); + if (svp && *svp) { + mode = mode_from_discipline(*svp); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_IN_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_IN_CRLF; + } + + svp = hv_fetch(table, "open_OUT", 8, FALSE); + if (svp && *svp) { + mode = mode_from_discipline(*svp); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_OUT_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_OUT_CRLF; + } + } + if (o->op_type == OP_BACKTICK) + return o; + return ck_fun(o); +} + +OP * Perl_ck_repeat(pTHX_ OP *o) { if (cBINOPo->op_first->op_flags & OPf_PARENS) { @@ -5709,7 +5978,13 @@ Perl_ck_require(pTHX_ OP *o) --SvCUR(kid->op_sv); } } - sv_catpvn(kid->op_sv, ".pm", 3); + if (SvREADONLY(kid->op_sv)) { + SvREADONLY_off(kid->op_sv); + sv_catpvn(kid->op_sv, ".pm", 3); + SvREADONLY_on(kid->op_sv); + } + else + sv_catpvn(kid->op_sv, ".pm", 3); } } return ck_fun(o); @@ -5777,6 +6052,7 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { + OP *firstkid; o->op_private = 0; #ifdef USE_LOCALE if (PL_hints & HINT_LOCALE) @@ -5785,10 +6061,10 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k; - kid = kUNOP->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); @@ -5804,6 +6080,12 @@ Perl_ck_sort(pTHX_ OP *o) for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { if (k->op_next == kid) k->op_next = 0; + /* don't descend into loops */ + else if (k->op_type == OP_ENTERLOOP + || k->op_type == OP_ENTERITER) + { + k = cLOOPx(k)->op_lastop; + } } } else @@ -5812,17 +6094,26 @@ Perl_ck_sort(pTHX_ OP *o) } peep(k); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_type == OP_SORT) + kid = firstkid; + if (o->op_type == OP_SORT) { + /* provide scalar context for comparison function/block */ + kid = scalar(kid); kid->op_next = kid; + } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(cLISTOPo->op_first->op_sibling); + null(firstkid); + + firstkid = firstkid->op_sibling; } + /* provide list context for arguments */ + if (o->op_type == OP_SORT) + list(firstkid); + return o; } @@ -5862,7 +6153,7 @@ S_simplify_sort(pTHX_ OP *o) return; if (strEQ(GvNAME(gv), "a")) reversed = 0; - else if(strEQ(GvNAME(gv), "b")) + else if (strEQ(GvNAME(gv), "b")) reversed = 1; else return; @@ -5911,7 +6202,7 @@ Perl_ck_split(pTHX_ OP *o) cLISTOPo->op_last = kid; /* There was only one element previously */ } - if (kid->op_type != OP_MATCH) { + if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); @@ -6028,7 +6319,9 @@ Perl_ck_subr(pTHX_ OP *o) proto++; arg++; if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) - bad_type(arg, "block", gv_ename(namegv), o2); + bad_type(arg, + arg == 1 ? "block or sub {}" : "sub {}", + gv_ename(namegv), o2); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -6076,8 +6369,8 @@ Perl_ck_subr(pTHX_ OP *o) bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o2->op_type != OP_RV2CV) - bad_type(arg, "sub", gv_ename(namegv), o2); + if (o2->op_type != OP_ENTERSUB) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); goto wrapref; case '$': if (o2->op_type != OP_RV2SV @@ -6194,26 +6487,32 @@ Perl_peep(pTHX_ register OP *o) * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - SvREFCNT_dec(PL_curpad[ix]); - SvPADTMP_on(cSVOPo->op_sv); - PL_curpad[ix] = cSVOPo->op_sv; + if (SvPADTMP(cSVOPo->op_sv)) { + /* If op_sv is already a PADTMP then it is being used by + * another pad, so make a copy. */ + sv_setsv(PL_curpad[ix],cSVOPo->op_sv); + SvREADONLY_on(PL_curpad[ix]); + SvREFCNT_dec(cSVOPo->op_sv); + } + else { + SvREFCNT_dec(PL_curpad[ix]); + SvPADTMP_on(cSVOPo->op_sv); + PL_curpad[ix] = cSVOPo->op_sv; + } cSVOPo->op_sv = Nullsv; o->op_targ = ix; } #endif - /* FALL THROUGH */ - case OP_UC: - case OP_UCFIRST: - case OP_LC: - case OP_LCFIRST: + o->op_seq = PL_op_seqmax++; + break; + case OP_CONCAT: - case OP_JOIN: - case OP_QUOTEMETA: if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { if (o->op_next->op_private & OPpTARGET_MY) { if (o->op_flags & OPf_STACKED) /* chained concats */ goto ignore_optimization; else { + /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ o->op_targ = o->op_next->op_targ; o->op_next->op_targ = 0; o->op_private |= OPpTARGET_MY; @@ -6253,7 +6552,8 @@ Perl_peep(pTHX_ register OP *o) if (o->op_next->op_type == OP_RV2SV) { if (!(o->op_next->op_private & OPpDEREF)) { null(o->op_next); - o->op_private |= o->op_next->op_private & OPpLVAL_INTRO; + o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO + | OPpOUR_INTRO); o->op_next = o->op_next->op_next; o->op_type = OP_GVSV; o->op_ppaddr = PL_ppaddr[OP_GVSV]; @@ -6284,13 +6584,13 @@ Perl_peep(pTHX_ register OP *o) GvAVn(gv); } } - else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_UNSAFE)) { + else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { GV *gv = cGVOPo_gv; if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_PROTOTYPE, "%s() called too early to check prototype", SvPV_nolen(sv)); } @@ -6338,8 +6638,10 @@ Perl_peep(pTHX_ register OP *o) line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); - Perl_warner(aTHX_ WARN_SYNTAX, "Statement unlikely to be reached"); - Perl_warner(aTHX_ WARN_SYNTAX, "(Maybe you meant system() when you said exec()?)\n"); + Perl_warner(aTHX_ WARN_EXEC, + "Statement unlikely to be reached"); + Perl_warner(aTHX_ WARN_EXEC, + "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } } @@ -6349,11 +6651,12 @@ Perl_peep(pTHX_ register OP *o) UNOP *rop; SV *lexname; GV **fields; - SV **svp, **indsvp; + SV **svp, **indsvp, *sv; I32 ind; char *key; STRLEN keylen; + o->op_seq = PL_op_seqmax++; if ((o->op_private & (OPpLVAL_INTRO)) || ((BINOP*)o)->op_last->op_type != OP_CONST) break; @@ -6380,8 +6683,76 @@ Perl_peep(pTHX_ register OP *o) rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; o->op_type = OP_AELEM; o->op_ppaddr = PL_ppaddr[OP_AELEM]; + sv = newSViv(ind); + if (SvREADONLY(*svp)) + SvREADONLY_on(sv); + SvFLAGS(sv) |= (SvFLAGS(*svp) + & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); SvREFCNT_dec(*svp); - *svp = newSViv(ind); + *svp = sv; + break; + } + + case OP_HSLICE: { + UNOP *rop; + SV *lexname; + GV **fields; + SV **svp, **indsvp, *sv; + I32 ind; + char *key; + STRLEN keylen; + SVOP *first_key_op, *key_op; + + o->op_seq = PL_op_seqmax++; + if ((o->op_private & (OPpLVAL_INTRO)) + /* I bet there's always a pushmark... */ + || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) + /* hmmm, no optimization if list contains only one key. */ + break; + rop = (UNOP*)((LISTOP*)o)->op_last; + if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) + break; + lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); + if (!SvOBJECT(lexname)) + break; + fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); + if (!fields || !GvHV(*fields)) + break; + /* Again guessing that the pushmark can be jumped over.... */ + first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) + ->op_first->op_sibling; + /* Check that the key list contains only constants. */ + for (key_op = first_key_op; key_op; + key_op = (SVOP*)key_op->op_sibling) + if (key_op->op_type != OP_CONST) + break; + if (key_op) + break; + rop->op_type = OP_RV2AV; + rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; + o->op_type = OP_ASLICE; + o->op_ppaddr = PL_ppaddr[OP_ASLICE]; + for (key_op = first_key_op; key_op; + key_op = (SVOP*)key_op->op_sibling) { + svp = cSVOPx_svp(key_op); + key = SvPV(*svp, keylen); + indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + if (!indsvp) { + Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " + "in variable %s of type %s", + key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); + } + ind = SvIV(*indsvp); + if (ind < 1) + Perl_croak(aTHX_ "Bad index while coercing array into hash"); + sv = newSViv(ind); + if (SvREADONLY(*svp)) + SvREADONLY_on(sv); + SvFLAGS(sv) |= (SvFLAGS(*svp) + & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); + SvREFCNT_dec(*svp); + *svp = sv; + } break; }