X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=95aa4f27396cd5854385d5b72eb9218f102bb31e;hb=8e3f9bdf33f266c6e827493ca82149fc1598579a;hp=529506b90e28abd8e4aece801d4ac380d5966af4;hpb=eb64745eccc492010733ac012342c6cacc81e103;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 529506b..95aa4f2 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,42 @@ 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 + && ((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); @@ -187,7 +189,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); @@ -353,8 +355,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; @@ -959,7 +962,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 @@ -1098,7 +1101,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; @@ -1252,7 +1255,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 @@ -1322,7 +1325,6 @@ Perl_mod(pTHX_ OP *o, I32 type) { dTHR; OP *kid; - SV *sv; STRLEN n_a; if (!o || PL_error_count) @@ -1395,18 +1397,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; } @@ -1818,7 +1821,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 */ @@ -1828,19 +1830,18 @@ 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; } @@ -1929,7 +1930,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 || @@ -1940,7 +1941,7 @@ 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); } @@ -2337,8 +2338,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; @@ -2584,12 +2588,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*); @@ -2743,7 +2746,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; @@ -2850,12 +2854,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 @@ -3073,7 +3081,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; @@ -3084,45 +3091,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 */ @@ -3157,6 +3174,58 @@ 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*); + } + } + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +} + OP * Perl_dofile(pTHX_ OP *term) { @@ -3241,6 +3310,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); @@ -3251,12 +3322,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)) { @@ -3300,7 +3378,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; @@ -3382,7 +3460,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 @@ -3483,9 +3561,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; @@ -3503,7 +3580,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; @@ -3532,7 +3609,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) @@ -3733,6 +3810,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))) { @@ -3765,10 +3843,15 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * 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, @@ -3791,8 +3874,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; @@ -3809,6 +3890,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; @@ -3824,7 +3906,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; @@ -3899,9 +3980,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 @@ -4063,16 +4147,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); @@ -4194,7 +4276,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; @@ -4210,7 +4292,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, "%"SVf, msg); + Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg); } } @@ -4227,10 +4309,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) { @@ -4285,14 +4367,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) @@ -4304,9 +4398,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); } @@ -4322,7 +4416,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!name || GvCVGEN(gv)) cv = Nullcv; - else if (cv = GvCV(gv)) { + else if ((cv = GvCV(gv))) { cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { @@ -4338,13 +4432,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, @@ -4499,14 +4590,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", @@ -4516,21 +4608,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")) { @@ -4560,18 +4653,22 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) av_store(PL_endav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; } - 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)); + 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, SvREFCNT_inc(cv)); GvCV(gv) = 0; } else if (strEQ(s, "INIT") && !PL_error_count) { if (!PL_initav) PL_initav = newAV(); DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -4584,6 +4681,15 @@ 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) { @@ -4618,6 +4724,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) { @@ -4625,7 +4739,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); @@ -4676,7 +4790,7 @@ 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")) { @@ -4692,16 +4806,20 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) 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)); + 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, SvREFCNT_inc(cv)); GvCV(gv) = 0; } else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -4729,7 +4847,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); @@ -5047,6 +5165,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; @@ -5265,7 +5397,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; @@ -5301,8 +5433,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); @@ -5321,8 +5453,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); @@ -5389,11 +5521,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); @@ -5441,6 +5580,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()); @@ -5450,11 +5590,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; } @@ -5479,7 +5618,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 * @@ -5573,7 +5712,7 @@ 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 */ @@ -5581,7 +5720,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ Perl_warner(aTHX_ WARN_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 */ @@ -5656,7 +5795,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; @@ -5705,8 +5846,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; @@ -5724,6 +5865,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) { @@ -5750,7 +5921,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); @@ -5818,6 +5995,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) @@ -5826,10 +6004,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); @@ -5845,6 +6023,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 @@ -5853,17 +6037,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; } @@ -5903,7 +6096,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; @@ -6242,19 +6435,16 @@ Perl_peep(pTHX_ register OP *o) 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; @@ -6294,7 +6484,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]; @@ -6325,13 +6516,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)); } @@ -6382,7 +6573,7 @@ Perl_peep(pTHX_ register OP *o) Perl_warner(aTHX_ WARN_EXEC, "Statement unlikely to be reached"); Perl_warner(aTHX_ WARN_EXEC, - "(Maybe you meant system() when you said exec()?)\n"); + "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } } @@ -6392,11 +6583,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; @@ -6423,8 +6615,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; }