X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=7459ae6d4f6ecd09bdb36c12b7e4ccf27e5cb587;hb=e336de0d01f30cc4061b6d6a00d11df30fc67cd3;hp=b86227b1125c6037c36ce0cb0b25325f8d9d37e3;hpb=b35b24033ff5a2171d5dc795e027358506aa01ff;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index b86227b..7459ae6 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-1994, Larry Wall + * Copyright (c) 1991-1997, 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. @@ -18,116 +18,131 @@ #include "EXTERN.h" #include "perl.h" -#define USE_OP_MASK /* Turned on by default in 5.002beta1h */ - -#ifdef USE_OP_MASK /* - * In the following definition, the ", (OP *) op" is just to make the compiler + * In the following definition, the ", Nullop" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,o) \ - ((op_mask && op_mask[type]) \ - ? (croak("%s trapped by operation mask", op_desc[type]), (OP*)o) \ + ((op_mask && op_mask[type]) \ + ? ( op_free((OP*)o), \ + croak("%s trapped by operation mask", op_desc[type]), \ + Nullop ) \ : (*check[type])((OP*)o)) -#else -#define CHECKOP(type,o) (*check[type])(o) -#endif /* USE_OP_MASK */ static I32 list_assignment _((OP *o)); static void bad_type _((I32 n, char *t, char *name, OP *kid)); static OP *modkids _((OP *o, I32 type)); static OP *no_fh_allowed _((OP *o)); +static bool scalar_mod_type _((OP *o, I32 type)); static OP *scalarboolean _((OP *o)); static OP *too_few_arguments _((OP *o, char* name)); static OP *too_many_arguments _((OP *o, char* name)); static void null _((OP* o)); -static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, I32 seq, +static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)); +static OP *newDEFSVOP _((void)); +static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp)); static char* -CvNAME(cv) -CV* cv; +gv_ename(GV *gv) { SV* tmpsv = sv_newmortal(); - gv_efullname(tmpsv, CvGV(cv)); + gv_efullname3(tmpsv, gv, Nullch); return SvPV(tmpsv,na); } static OP * -no_fh_allowed(o) -OP *o; +no_fh_allowed(OP *o) { - sprintf(tokenbuf,"Missing comma after first argument to %s function", - op_desc[o->op_type]); - yyerror(tokenbuf); + yyerror(form("Missing comma after first argument to %s function", + op_desc[o->op_type])); return o; } static OP * -too_few_arguments(o, name) -OP* o; -char* name; +too_few_arguments(OP *o, char *name) { - sprintf(tokenbuf,"Not enough arguments for %s", name); - yyerror(tokenbuf); + yyerror(form("Not enough arguments for %s", name)); return o; } static OP * -too_many_arguments(o, name) -OP *o; -char* name; +too_many_arguments(OP *o, char *name) { - sprintf(tokenbuf,"Too many arguments for %s", name); - yyerror(tokenbuf); + yyerror(form("Too many arguments for %s", name)); return o; } static void -bad_type(n, t, name, kid) -I32 n; -char *t; -char *name; -OP *kid; +bad_type(I32 n, char *t, char *name, OP *kid) { - sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)", - (int) n, name, t, op_desc[kid->op_type]); - yyerror(tokenbuf); + yyerror(form("Type of arg %d to %s must be %s (not %s)", + (int)n, name, t, op_desc[kid->op_type])); } void -assertref(o) -OP *o; +assertref(OP *o) { int type = o->op_type; if (type != OP_AELEM && type != OP_HELEM) { - sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]); - yyerror(tokenbuf); - if (type == OP_RV2HV || type == OP_ENTERSUB) - warn("(Did you mean $ or @ instead of %c?)\n", - type == OP_RV2HV ? '%' : '&'); + yyerror(form("Can't use subscript on %s", op_desc[type])); + if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) { + dTHR; + SV *msg = sv_2mortal( + newSVpvf("(Did you mean $ or @ instead of %c?)\n", + type == OP_ENTERSUB ? '&' : '%')); + if (in_eval & 2) + warn("%_", msg); + else if (in_eval) + sv_catsv(GvSV(errgv), msg); + else + PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg)); + } } } /* "register" allocation */ PADOFFSET -pad_allocmy(name) -char *name; +pad_allocmy(char *name) { dTHR; PADOFFSET off; SV *sv; if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) { - if (!isprint(name[1])) - sprintf(name+1, "^%c", name[1] ^ 64); /* XXX is tokenbuf, really */ + if (!isPRINT(name[1])) { + name[3] = '\0'; + name[2] = toCTRL(name[1]); + name[1] = '^'; + } croak("Can't use global %s in \"my\"",name); } + if (dowarn && AvFILLp(comppad_name) >= 0) { + SV **svp = AvARRAY(comppad_name); + for (off = AvFILLp(comppad_name); off > comppad_name_floor; off--) { + if ((sv = svp[off]) + && sv != &sv_undef + && SvIVX(sv) == 999999999 /* var is in open scope */ + && strEQ(name, SvPVX(sv))) + { + warn("\"my\" variable %s masks earlier declaration in same scope", name); + break; + } + } + } off = pad_alloc(OP_PADSV, SVs_PADMY); sv = NEWSV(1102,0); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, name); + if (in_my_stash) { + if (*name != '$') + croak("Can't declare class for non-scalar %s in \"my\"",name); + SvOBJECT_on(sv); + (void)SvUPGRADE(sv, SVt_PVMG); + SvSTASH(sv) = (HV*)SvREFCNT_inc(in_my_stash); + sv_objcount++; + } av_store(comppad_name, off, sv); SvNVX(sv) = (double)999999999; SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ @@ -143,55 +158,86 @@ char *name; } static PADOFFSET -#ifndef CAN_PROTOTYPE -pad_findlex(name, newoff, seq, startcv, cx_ix) -char *name; -PADOFFSET newoff; -I32 seq; -CV* startcv; -I32 cx_ix; -#else -pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) -#endif +pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) { dTHR; CV *cv; I32 off; SV *sv; register I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; int saweval; for (cv = startcv; cv; cv = CvOUTSIDE(cv)) { - AV* curlist = CvPADLIST(cv); - SV** svp = av_fetch(curlist, 0, FALSE); + AV *curlist = CvPADLIST(cv); + SV **svp = av_fetch(curlist, 0, FALSE); AV *curname; + if (!svp || *svp == &sv_undef) continue; curname = (AV*)*svp; svp = AvARRAY(curname); - for (off = AvFILL(curname); off > 0; off--) { + for (off = AvFILLp(curname); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && + seq > I_32(SvNVX(sv)) && strEQ(SvPVX(sv), name)) { - I32 depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1; - AV *oldpad = (AV*)*av_fetch(curlist, depth, FALSE); - SV *oldsv = *av_fetch(oldpad, off, TRUE); + I32 depth; + AV *oldpad; + SV *oldsv; + + depth = CvDEPTH(cv); + if (!depth) { + if (newoff) { + if (SvFAKE(sv)) + continue; + return 0; /* don't clone from inactive stack frame */ + } + depth = 1; + } + oldpad = (AV*)*av_fetch(curlist, depth, FALSE); + oldsv = *av_fetch(oldpad, off, TRUE); if (!newoff) { /* Not a mere clone operation. */ - SV *sv = NEWSV(1103,0); + SV *namesv = NEWSV(1103,0); newoff = pad_alloc(OP_PADSV, SVs_PADMY); - sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv, name); - av_store(comppad_name, newoff, sv); - SvNVX(sv) = (double)curcop->cop_seq; - SvIVX(sv) = 999999999; /* A ref, intro immediately */ - SvFLAGS(sv) |= SVf_FAKE; + sv_upgrade(namesv, SVt_PVNV); + sv_setpv(namesv, name); + av_store(comppad_name, newoff, namesv); + SvNVX(namesv) = (double)curcop->cop_seq; + SvIVX(namesv) = 999999999; /* A ref, intro immediately */ + SvFAKE_on(namesv); /* A ref, not a real var */ + if (CvANON(compcv) || SvTYPE(compcv) == SVt_PVFM) { + /* "It's closures all the way down." */ + CvCLONE_on(compcv); + if (cv == startcv) { + if (CvANON(compcv)) + oldsv = Nullsv; /* no need to keep ref */ + } + else { + CV *bcv; + for (bcv = startcv; + bcv && bcv != cv && !CvCLONE(bcv); + bcv = CvOUTSIDE(bcv)) { + if (CvANON(bcv)) + CvCLONE_on(bcv); + else { + if (dowarn && !CvUNIQUE(cv)) + warn( + "Variable \"%s\" may be unavailable", + name); + break; + } + } + } + } + else if (!CvUNIQUE(compcv)) { + if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv)) + warn("Variable \"%s\" will not stay shared", name); + } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); - CvCLONE_on(compcv); return newoff; } } @@ -213,10 +259,14 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) } break; case CXt_EVAL: - if (cx->blk_eval.old_op_type != OP_ENTEREVAL && - cx->blk_eval.old_op_type != OP_ENTERTRY) - return 0; /* require must have its own scope */ - saweval = i; + switch (cx->blk_eval.old_op_type) { + case OP_ENTEREVAL: + saweval = i; + break; + case OP_REQUIRE: + /* require must have its own scope */ + return 0; + } break; case CXt_SUB: if (!saweval) @@ -235,14 +285,14 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) } PADOFFSET -pad_findmy(name) -char *name; +pad_findmy(char *name) { dTHR; I32 off; + I32 pendoff = 0; SV *sv; SV **svp = AvARRAY(comppad_name); - I32 seq = cop_seqmax; + U32 seq = cop_seqmax; #ifdef USE_THREADS /* @@ -258,28 +308,33 @@ char *name; #endif /* USE_THREADS */ /* The one we're looking for is probably just before comppad_name_fill. */ - for (off = AvFILL(comppad_name); off > 0; off--) { + for (off = AvFILLp(comppad_name); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && - seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && + (!SvIVX(sv) || + (seq <= SvIVX(sv) && + seq > I_32(SvNVX(sv)))) && strEQ(SvPVX(sv), name)) { - return (PADOFFSET)off; + if (SvIVX(sv)) + return (PADOFFSET)off; + pendoff = off; /* this pending def. will override import */ } } /* See if it's in a nested scope */ off = pad_findlex(name, 0, seq, CvOUTSIDE(compcv), cxstack_ix); - if (off) + if (off) { + /* If there is a pending local definition, this new alias must die */ + if (pendoff) + SvIVX(AvARRAY(comppad_name)[off]) = seq; return off; /* pad_findlex returns 0 for failure...*/ - + } return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */ } void -pad_leavemy(fill) -I32 fill; +pad_leavemy(I32 fill) { I32 off; SV **svp = AvARRAY(comppad_name); @@ -291,16 +346,14 @@ I32 fill; } } /* "Deintroduce" my variables that are leaving with this scope. */ - for (off = AvFILL(comppad_name); off > fill; off--) { + for (off = AvFILLp(comppad_name); off > fill; off--) { if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999) SvIVX(sv) = cop_seqmax; } } PADOFFSET -pad_alloc(optype,tmptype) -I32 optype; -U32 tmptype; +pad_alloc(I32 optype, U32 tmptype) { dTHR; SV *sv; @@ -312,55 +365,60 @@ U32 tmptype; pad_reset(); if (tmptype & SVs_PADMY) { do { - sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE); + sv = *av_fetch(comppad, AvFILLp(comppad) + 1, TRUE); } while (SvPADBUSY(sv)); /* need a fresh one */ - retval = AvFILL(comppad); + retval = AvFILLp(comppad); } else { - do { - sv = *av_fetch(comppad, ++padix, TRUE); - } while (SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)); + SV **names = AvARRAY(comppad_name); + SSize_t names_fill = AvFILLp(comppad_name); + for (;;) { + /* + * "foreach" index vars temporarily become aliases to non-"my" + * values. Thus we must skip, not just pad values that are + * marked as current pad values, but also those with names. + */ + if (++padix <= names_fill && + (sv = names[padix]) && sv != &sv_undef) + continue; + sv = *av_fetch(comppad, padix, TRUE); + if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY))) + break; + } retval = padix; } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); #ifdef USE_THREADS - DEBUG_X(fprintf(stderr, "0x%lx Pad 0x%lx alloc %ld for %s\n", - (unsigned long) thr, (unsigned long) curpad, - (long) retval, op_name[optype])); + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n", + (unsigned long) thr, (unsigned long) curpad, + (long) retval, op_name[optype])); #else - DEBUG_X(fprintf(stderr, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx alloc %ld for %s\n", + (unsigned long) curpad, + (long) retval, op_name[optype])); #endif /* USE_THREADS */ return (PADOFFSET)retval; } SV * -#ifndef CAN_PROTOTYPE -pad_sv(po) -PADOFFSET po; -#else pad_sv(PADOFFSET po) -#endif /* CAN_PROTOTYPE */ { dTHR; #ifdef USE_THREADS - DEBUG_X(fprintf(stderr, "0x%lx Pad 0x%lx sv %d\n", - (unsigned long) thr, (unsigned long) curpad, po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); #else if (!po) croak("panic: pad_sv po"); - DEBUG_X(fprintf(stderr, "Pad sv %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx sv %d\n", + (unsigned long) curpad, po)); #endif /* USE_THREADS */ return curpad[po]; /* eventually we'll turn this into a macro */ } void -#ifndef CAN_PROTOTYPE -pad_free(po) -PADOFFSET po; -#else pad_free(PADOFFSET po) -#endif /* CAN_PROTOTYPE */ { dTHR; if (!curpad) @@ -370,10 +428,11 @@ pad_free(PADOFFSET po) if (!po) croak("panic: pad_free po"); #ifdef USE_THREADS - DEBUG_X(fprintf(stderr, "0x%lx Pad 0x%lx free %d\n", - (unsigned long) thr, (unsigned long) curpad, po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); #else - DEBUG_X(fprintf(stderr, "Pad free %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx free %d\n", + (unsigned long) curpad, po)); #endif /* USE_THREADS */ if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); @@ -382,12 +441,7 @@ pad_free(PADOFFSET po) } void -#ifndef CAN_PROTOTYPE -pad_swipe(po) -PADOFFSET po; -#else pad_swipe(PADOFFSET po) -#endif /* CAN_PROTOTYPE */ { dTHR; if (AvARRAY(comppad) != curpad) @@ -395,10 +449,11 @@ pad_swipe(PADOFFSET po) if (!po) croak("panic: pad_swipe po"); #ifdef USE_THREADS - DEBUG_X(fprintf(stderr, "0x%lx Pad 0x%lx swipe %d\n", - (unsigned long) thr, (unsigned long) curpad, po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); #else - DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx swipe %d\n", + (unsigned long) curpad, po)); #endif /* USE_THREADS */ SvPADTMP_off(curpad[po]); curpad[po] = NEWSV(1107,0); @@ -407,39 +462,96 @@ pad_swipe(PADOFFSET po) padix = po - 1; } +/* XXX pad_reset() is currently disabled because it results in serious bugs. + * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed + * on the stack by OPs that use them, there are several ways to get an alias + * to a shared TARG. Such an alias will change randomly and unpredictably. + * We avoid doing this until we can think of a Better Way. + * GSAR 97-10-29 */ void -pad_reset() +pad_reset(void) { +#ifdef USE_BROKEN_PAD_RESET dTHR; register I32 po; if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); #ifdef USE_THREADS - DEBUG_X(fprintf(stderr, "0x%lx Pad 0x%lx reset\n", - (unsigned long) thr, (unsigned long) curpad)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n", + (unsigned long) thr, (unsigned long) curpad)); #else - DEBUG_X(fprintf(stderr, "Pad reset\n")); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx reset\n", + (unsigned long) curpad)); #endif /* USE_THREADS */ if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(comppad); po > padix_floor; po--) { - if (curpad[po] && curpad[po] != &sv_undef) + if (curpad[po] && !SvIMMORTAL(curpad[po])) SvPADTMP_off(curpad[po]); } padix = padix_floor; } +#endif pad_reset_pending = FALSE; } +#ifdef USE_THREADS +/* find_threadsv is not reentrant */ +PADOFFSET +find_threadsv(char *name) +{ + dTHR; + char *p; + PADOFFSET key; + SV **svp; + /* We currently only handle names of a single character */ + p = strchr(threadsv_names, *name); + if (!p) + return NOT_IN_PAD; + key = p - threadsv_names; + svp = av_fetch(thr->threadsv, key, FALSE); + if (!svp) { + SV *sv = NEWSV(0, 0); + av_store(thr->threadsv, key, sv); + thr->threadsvp = AvARRAY(thr->threadsv); + /* + * Some magic variables used to be automagically initialised + * in gv_fetchpv. Those which are now per-thread magicals get + * initialised here instead. + */ + switch (*name) { + case '_': + break; + case ';': + sv_setpv(sv, "\034"); + sv_magic(sv, 0, 0, name, 1); + break; + case '&': + case '`': + case '\'': + sawampersand = TRUE; + SvREADONLY_on(sv); + /* FALL THROUGH */ + default: + sv_magic(sv, 0, 0, name, 1); + } + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "find_threadsv: new SV %p for $%s%c\n", + sv, (*name < 32) ? "^" : "", + (*name < 32) ? toCTRL(*name) : *name)); + } + return key; +} +#endif /* USE_THREADS */ + /* Destructor */ void -op_free(o) -OP *o; +op_free(OP *o) { register OP *kid, *nextkid; - if (!o) + if (!o || o->op_seq == (U16)-1) return; if (o->op_flags & OPf_KIDS) { @@ -456,12 +568,23 @@ OP *o; case OP_ENTEREVAL: o->op_targ = 0; /* Was holding hints. */ break; +#ifdef USE_THREADS + case OP_THREADSV: + o->op_targ = 0; /* Was holding index into thr->threadsv AV. */ + break; +#endif /* USE_THREADS */ + default: + if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst)) + break; + /* FALL THROUGH */ case OP_GVSV: case OP_GV: + case OP_AELEMFAST: SvREFCNT_dec(cGVOPo->op_gv); break; case OP_NEXTSTATE: case OP_DBSTATE: + Safefree(cCOPo->cop_label); SvREFCNT_dec(cCOPo->cop_filegv); break; case OP_CONST: @@ -482,10 +605,7 @@ OP *o; /* FALL THROUGH */ case OP_PUSHRE: case OP_MATCH: - pregfree(cPMOPo->op_pmregexp); - SvREFCNT_dec(cPMOPo->op_pmshort); - break; - default: + ReREFCNT_dec(cPMOPo->op_pmregexp); break; } @@ -496,10 +616,9 @@ OP *o; } static void -null(o) -OP* o; +null(OP *o) { - if (o->op_type != OP_NULL && o->op_targ > 0) + if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0) pad_free(o->op_targ); o->op_targ = o->op_type; o->op_type = OP_NULL; @@ -511,8 +630,7 @@ OP* o; #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) OP * -linklist(o) -OP *o; +linklist(OP *o) { register OP *kid; @@ -536,8 +654,7 @@ OP *o; } OP * -scalarkids(o) -OP *o; +scalarkids(OP *o) { OP *kid; if (o && o->op_flags & OPf_KIDS) { @@ -548,11 +665,11 @@ OP *o; } static OP * -scalarboolean(o) -OP *o; +scalarboolean(OP *o) { if (dowarn && o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { + dTHR; line_t oldline = curcop->cop_line; if (copline != NOLINE) @@ -564,17 +681,16 @@ OP *o; } OP * -scalar(o) -OP *o; +scalar(OP *o) { OP *kid; /* assumes no premature commitment */ - if (!o || (o->op_flags & OPf_KNOW) || error_count) + if (!o || (o->op_flags & OPf_WANT) || error_count + || o->op_type == OP_RETURN) return o; - o->op_flags &= ~OPf_LIST; - o->op_flags |= OPf_KNOW; + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; switch (o->op_type) { case OP_REPEAT: @@ -605,8 +721,16 @@ OP *o; break; case OP_LEAVE: case OP_LEAVETRY: - scalar(cLISTOPo->op_first); - /* FALL THROUGH */ + kid = cLISTOPo->op_first; + scalar(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + scalar(kid); + } + WITH_THR(curcop = &compiling); + break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: @@ -616,31 +740,32 @@ OP *o; else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; } return o; } OP * -scalarvoid(o) -OP *o; +scalarvoid(OP *o) { OP *kid; char* useless = 0; SV* sv; - if (!o || error_count) - return o; - if (o->op_flags & OPf_LIST) + /* assumes no premature commitment */ + if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count + || o->op_type == OP_RETURN) return o; - o->op_flags |= OPf_KNOW; + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (o->op_type) { default: if (!(opargs[o->op_type] & OA_FOLDCONST)) break; + /* FALL THROUGH */ + case OP_REPEAT: if (o->op_flags & OPf_STACKED) break; /* FALL THROUGH */ @@ -667,8 +792,6 @@ OP *o; case OP_AELEM: case OP_AELEMFAST: case OP_ASLICE: - case OP_VALUES: - case OP_KEYS: case OP_HELEM: case OP_HSLICE: case OP_UNPACK: @@ -729,7 +852,7 @@ OP *o; case OP_NEXTSTATE: case OP_DBSTATE: - curcop = ((COP*)o); /* for warning below */ + WITH_THR(curcop = ((COP*)o)); /* for warning below */ break; case OP_CONST: @@ -759,46 +882,47 @@ OP *o; o->op_ppaddr = ppaddr[OP_PREDEC]; break; - case OP_REPEAT: - scalarvoid(cBINOPo->op_first); - useless = op_desc[o->op_type]; - break; - case OP_OR: case OP_AND: case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_NULL: if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - curcop = ((COP*)o); /* for warning below */ + WITH_THR(curcop = ((COP*)o)); /* for warning below */ if (o->op_flags & OPf_STACKED) break; + /* FALL THROUGH */ case OP_ENTERTRY: case OP_ENTER: case OP_SCALAR: if (!(o->op_flags & OPf_KIDS)) break; + /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: - o->op_private |= OPpLEAVE_VOID; case OP_LINESEQ: case OP_LIST: for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_ENTEREVAL: + scalarkids(o); + break; + case OP_REQUIRE: + /* all requires must return a boolean value */ + o->op_flags &= ~OPf_WANT; + return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) deprecate("implicit split to @_"); } break; - case OP_DELETE: - o->op_private |= OPpLEAVE_VOID; - break; } if (useless && dowarn) warn("Useless use of %s in void context", useless); @@ -806,8 +930,7 @@ OP *o; } OP * -listkids(o) -OP *o; +listkids(OP *o) { OP *kid; if (o && o->op_flags & OPf_KIDS) { @@ -818,16 +941,16 @@ OP *o; } OP * -list(o) -OP *o; +list(OP *o) { OP *kid; /* assumes no premature commitment */ - if (!o || (o->op_flags & OPf_KNOW) || error_count) + if (!o || (o->op_flags & OPf_WANT) || error_count + || o->op_type == OP_RETURN) return o; - o->op_flags |= (OPf_KNOW | OPf_LIST); + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (o->op_type) { case OP_FLOP: @@ -855,8 +978,16 @@ OP *o; break; case OP_LEAVE: case OP_LEAVETRY: - list(cLISTOPo->op_first); - /* FALL THROUGH */ + kid = cLISTOPo->op_first; + list(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + list(kid); + } + WITH_THR(curcop = &compiling); + break; case OP_SCOPE: case OP_LINESEQ: for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { @@ -865,15 +996,18 @@ OP *o; else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; + case OP_REQUIRE: + /* all requires must return a boolean value */ + o->op_flags &= ~OPf_WANT; + return scalar(o); } return o; } OP * -scalarseq(o) -OP *o; +scalarseq(OP *o) { OP *kid; @@ -883,6 +1017,7 @@ OP *o; o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { + dTHR; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); @@ -900,9 +1035,7 @@ OP *o; } static OP * -modkids(o, type) -OP *o; -I32 type; +modkids(OP *o, I32 type) { OP *kid; if (o && o->op_flags & OPf_KIDS) { @@ -915,19 +1048,19 @@ I32 type; static I32 modcount; OP * -mod(o, type) -OP *o; -I32 type; +mod(OP *o, I32 type) { dTHR; OP *kid; SV *sv; - char mtype; if (!o || error_count) return o; switch (o->op_type) { + case OP_UNDEF: + modcount++; + return o; case OP_CONST: if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; @@ -944,6 +1077,10 @@ I32 type; else croak("That use of $[ is unsupported"); break; + case OP_STUB: + if (o->op_flags & OPf_PARENS) + break; + goto nomod; case OP_ENTERSUB: if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { @@ -959,10 +1096,9 @@ I32 type; /* grep, foreach, subcalls, refgen */ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) break; - sprintf(tokenbuf, "Can't modify %s in %s", - op_desc[o->op_type], - type ? op_desc[type] : "local"); - yyerror(tokenbuf); + yyerror(form("Can't modify %s in %s", + op_desc[o->op_type], + type ? op_desc[type] : "local")); return o; case OP_PREINC: @@ -997,12 +1133,16 @@ I32 type; case OP_RV2AV: case OP_RV2HV: + if (!type && cUNOPo->op_first->op_type != OP_GV) + croak("Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { modcount = 10000; return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: + if (scalar_mod_type(o, type)) + goto nomod; ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_AASSIGN: @@ -1016,12 +1156,12 @@ I32 type; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) - croak("Can't localize a reference"); - ref(cUNOPo->op_first, o->op_type); + croak("Can't localize through a reference"); + ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ - case OP_UNDEF: case OP_GV: case OP_AV2ARYLEN: + hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_AELEMFAST: modcount++; @@ -1030,6 +1170,10 @@ I32 type; case OP_PADAV: case OP_PADHV: modcount = 10000; + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) + return o; /* Treat \(@foo) like ordinary list. */ + if (scalar_mod_type(o, type)) + goto nomod; /* FALL THROUGH */ case OP_PADSV: modcount++; @@ -1038,24 +1182,25 @@ I32 type; SvPV(*av_fetch(comppad_name, o->op_targ, 4), na)); break; +#ifdef USE_THREADS + case OP_THREADSV: + modcount++; /* XXX ??? */ + break; +#endif /* USE_THREADS */ + case OP_PUSHMARK: break; + case OP_KEYS: + if (type != OP_SASSIGN) + goto nomod; + /* FALL THROUGH */ case OP_POS: - mtype = '.'; - goto makelv; case OP_VEC: - mtype = 'v'; - goto makelv; case OP_SUBSTR: - mtype = 'x'; - makelv: pad_free(o->op_targ); o->op_targ = pad_alloc(o->op_type, SVs_PADMY); - sv = PAD_SV(o->op_targ); - sv_upgrade(sv, SVt_PVLV); - sv_magic(sv, Nullsv, mtype, Nullch, 0); - curpad[o->op_targ] = sv; + assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); if (o->op_flags & OPf_KIDS) mod(cBINOPo->op_first->op_sibling, type); break; @@ -1063,6 +1208,9 @@ I32 type; case OP_AELEM: case OP_HELEM: ref(cBINOPo->op_first, o->op_type); + if (type == OP_ENTERSUB && + !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) + o->op_private |= OPpLVAL_DEFER; modcount++; break; @@ -1099,10 +1247,52 @@ I32 type; return o; } +static bool +scalar_mod_type(OP *o, I32 type) +{ + switch (type) { + case OP_SASSIGN: + if (o->op_type == OP_RV2GV) + return FALSE; + /* FALL THROUGH */ + case OP_PREINC: + case OP_PREDEC: + case OP_POSTINC: + case OP_POSTDEC: + case OP_I_PREINC: + case OP_I_PREDEC: + case OP_I_POSTINC: + case OP_I_POSTDEC: + case OP_POW: + case OP_MULTIPLY: + case OP_DIVIDE: + case OP_MODULO: + case OP_REPEAT: + case OP_ADD: + case OP_SUBTRACT: + case OP_I_MULTIPLY: + case OP_I_DIVIDE: + case OP_I_MODULO: + case OP_I_ADD: + case OP_I_SUBTRACT: + case OP_LEFT_SHIFT: + case OP_RIGHT_SHIFT: + case OP_BIT_AND: + case OP_BIT_XOR: + case OP_BIT_OR: + case OP_CONCAT: + case OP_SUBST: + case OP_TRANS: + case OP_ANDASSIGN: /* may work later */ + case OP_ORASSIGN: /* may work later */ + return TRUE; + default: + return FALSE; + } +} + OP * -refkids(o, type) -OP *o; -I32 type; +refkids(OP *o, I32 type) { OP *kid; if (o && o->op_flags & OPf_KIDS) { @@ -1113,9 +1303,7 @@ I32 type; } OP * -ref(o, type) -OP *o; -I32 type; +ref(OP *o, I32 type) { OP *kid; @@ -1124,7 +1312,7 @@ I32 type; switch (o->op_type) { case OP_ENTERSUB: - if ((type == OP_DEFINED) && + if ((type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = ppaddr[OP_RV2CV]; @@ -1133,7 +1321,7 @@ I32 type; o->op_flags |= OPf_SPECIAL; } break; - + case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) ref(kid, type); @@ -1142,15 +1330,21 @@ I32 type; ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_PADSV: - if (type == OP_RV2AV || type == OP_RV2HV) { - o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); o->op_flags |= OPf_MOD; } break; + case OP_THREADSV: + o->op_flags |= OPf_MOD; /* XXX ??? */ + break; + case OP_RV2AV: case OP_RV2HV: - o->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: ref(cUNOPo->op_first, o->op_type); @@ -1158,9 +1352,9 @@ I32 type; case OP_PADAV: case OP_PADHV: - o->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; break; - + case OP_SCALAR: case OP_NULL: if (!(o->op_flags & OPf_KIDS)) @@ -1170,8 +1364,10 @@ I32 type; case OP_AELEM: case OP_HELEM: ref(cBINOPo->op_first, o->op_type); - if (type == OP_RV2AV || type == OP_RV2HV) { - o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); o->op_flags |= OPf_MOD; } break; @@ -1192,8 +1388,7 @@ I32 type; } OP * -my(o) -OP *o; +my(OP *o) { OP *kid; I32 type; @@ -1205,14 +1400,14 @@ OP *o; if (type == OP_LIST) { for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my(kid); - } - else if (type != OP_PADSV && + } else if (type == OP_UNDEF) { + return o; + } else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) { - sprintf(tokenbuf, "Can't declare %s in my", op_desc[o->op_type]); - yyerror(tokenbuf); + yyerror(form("Can't declare %s in my", op_desc[o->op_type])); return o; } o->op_flags |= OPf_MOD; @@ -1221,8 +1416,7 @@ OP *o; } OP * -sawparens(o) -OP *o; +sawparens(OP *o) { if (o) o->op_flags |= OPf_PARENS; @@ -1230,13 +1424,24 @@ OP *o; } OP * -bind_match(type, left, right) -I32 type; -OP *left; -OP *right; +bind_match(I32 type, OP *left, OP *right) { OP *o; + if (dowarn && + (left->op_type == OP_RV2AV || + left->op_type == OP_RV2HV || + left->op_type == OP_PADAV || + left->op_type == OP_PADHV)) { + char *desc = op_desc[(right->op_type == OP_SUBST || + right->op_type == OP_TRANS) + ? right->op_type : OP_MATCH]; + char *sample = ((left->op_type == OP_RV2AV || + left->op_type == OP_PADAV) + ? "@array" : "%hash"); + warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample); + } + if (right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS) { @@ -1257,8 +1462,7 @@ OP *right; } OP * -invert(o) -OP *o; +invert(OP *o) { if (!o) return o; @@ -1267,11 +1471,10 @@ OP *o; } OP * -scope(o) -OP *o; +scope(OP *o) { if (o) { - if (o->op_flags & OPf_PARENS || perldb || tainting) { + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = ppaddr[OP_LEAVE]; @@ -1295,77 +1498,96 @@ OP *o; } int -block_start() +block_start(int full) { dTHR; int retval = savestack_ix; - comppad_name_fill = AvFILL(comppad_name); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); + SAVEI32(comppad_name_floor); + if (full) { + if ((comppad_name_fill = AvFILLp(comppad_name)) > 0) + comppad_name_floor = comppad_name_fill; + else + comppad_name_floor = 0; + } + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); min_intro_pending = 0; - SAVEINT(comppad_name_fill); - SAVEINT(padix_floor); + SAVEI32(comppad_name_fill); + SAVEI32(padix_floor); padix_floor = padix; pad_reset_pending = FALSE; - SAVEINT(hints); + SAVEI32(hints); hints &= ~HINT_BLOCK_SCOPE; return retval; } OP* -block_end(line, floor, seq) -int line; -int floor; -OP* seq; +block_end(I32 floor, OP *seq) { dTHR; int needblockscope = hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); - if (copline > (line_t)line) - copline = line; LEAVE_SCOPE(floor); pad_reset_pending = FALSE; if (needblockscope) hints |= HINT_BLOCK_SCOPE; /* propagate out */ pad_leavemy(comppad_name_fill); + cop_seqmax++; return retval; } +static OP * +newDEFSVOP(void) +{ +#ifdef USE_THREADS + OP *o = newOP(OP_THREADSV, 0); + o->op_targ = find_threadsv("_"); + return o; +#else + return newSVREF(newGVOP(OP_GV, 0, defgv)); +#endif /* USE_THREADS */ +} + void -newPROG(o) -OP *o; +newPROG(OP *o) { dTHR; if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, 0, o); + eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), o); eval_start = linklist(eval_root); eval_root->op_next = 0; peep(eval_start); } else { - if (!o) { - main_start = 0; + if (!o) return; - } main_root = scope(sawparens(scalarvoid(o))); curcop = &compiling; main_start = LINKLIST(main_root); main_root->op_next = 0; peep(main_start); - main_cv = compcv; compcv = 0; + + /* Register with debugger */ + if (PERLDB_INTER) { + CV *cv = perl_get_cv("DB::postponed", FALSE); + if (cv) { + dSP; + PUSHMARK(SP); + XPUSHs((SV*)compiling.cop_filegv); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } + } } } OP * -localize(o, lex) -OP *o; -I32 lex; +localize(OP *o, I32 lex) { if (o->op_flags & OPf_PARENS) list(o); else { - scalar(o); if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; @@ -1374,6 +1596,7 @@ I32 lex; } } in_my = FALSE; + in_my_stash = Nullhv; if (lex) return my(o); else @@ -1381,21 +1604,23 @@ I32 lex; } OP * -jmaybe(o) -OP *o; +jmaybe(OP *o) { if (o->op_type == OP_LIST) { - o = convert(OP_JOIN, 0, - prepend_elem(OP_LIST, - newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), - o)); + OP *o2; +#ifdef USE_THREADS + o2 = newOP(OP_THREADSV, 0); + o2->op_targ = find_threadsv(";"); +#else + o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), +#endif /* USE_THREADS */ + o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; } OP * -fold_constants(o) -register OP *o; +fold_constants(register OP *o) { dTHR; register OP *curop; @@ -1413,6 +1638,22 @@ register OP *o; if (!(opargs[type] & OA_FOLDCONST)) goto nope; + switch (type) { + case OP_SPRINTF: + case OP_UCFIRST: + case OP_LCFIRST: + case OP_UC: + case OP_LC: + case OP_SLT: + case OP_SGT: + case OP_SLE: + case OP_SGE: + case OP_SCMP: + + if (o->op_private & OPpLOCALE) + goto nope; + } + if (error_count) goto nope; /* Don't try to run w/ errors */ @@ -1439,7 +1680,7 @@ register OP *o; } op_free(o); if (type == OP_RV2GV) - return newGVOP(OP_GV, 0, sv); + return newGVOP(OP_GV, 0, (GV*)sv); else { if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) { IV iv = SvIV(sv); @@ -1447,43 +1688,28 @@ register OP *o; SvREFCNT_dec(sv); sv = newSViv(iv); } + else + SvIOK_off(sv); /* undo SvIV() damage */ } return newSVOP(OP_CONST, 0, sv); } - + nope: if (!(opargs[type] & OA_OTHERINT)) return o; if (!(hints & HINT_INTEGER)) { - int vars = 0; - if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS)) return o; for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) { if (curop->op_type == OP_CONST) { - if (SvIOK(((SVOP*)curop)->op_sv)) { - if (SvIVX(((SVOP*)curop)->op_sv) <= 0 && vars++) - return o; /* negatives truncate wrong way, alas */ + if (SvIOK(((SVOP*)curop)->op_sv)) continue; - } return o; } if (opargs[curop->op_type] & OA_RETINTEGER) continue; - if (curop->op_type == OP_PADSV || curop->op_type == OP_RV2SV) { - if (vars++) - return o; - if (((o->op_type == OP_LT || o->op_type == OP_GE) && - curop == ((BINOP*)o)->op_first ) || - ((o->op_type == OP_GT || o->op_type == OP_LE) && - curop == ((BINOP*)o)->op_last )) - { - /* Allow "$i < 100" and variants to integerize */ - continue; - } - } return o; } o->op_ppaddr = ppaddr[++(o->op_type)]; @@ -1493,8 +1719,7 @@ register OP *o; } OP * -gen_constant_list(o) -register OP *o; +gen_constant_list(register OP *o) { dTHR; register OP *curop; @@ -1522,10 +1747,7 @@ register OP *o; } OP * -convert(type, flags, o) -I32 type; -I32 flags; -OP* o; +convert(I32 type, I32 flags, OP *o) { OP *kid; OP *last = 0; @@ -1533,7 +1755,7 @@ OP* o; if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, Nullop); else - o->op_flags &= ~(OPf_KNOW|OPf_LIST); + o->op_flags &= ~OPf_WANT; if (!(opargs[type] & OA_MARK)) null(cLISTOPo->op_first); @@ -1559,10 +1781,7 @@ OP* o; /* List constructors */ OP * -append_elem(type, first, last) -I32 type; -OP* first; -OP* last; +append_elem(I32 type, OP *first, OP *last) { if (!first) return last; @@ -1585,10 +1804,7 @@ OP* last; } OP * -append_list(type, first, last) -I32 type; -LISTOP* first; -LISTOP* last; +append_list(I32 type, LISTOP *first, LISTOP *last) { if (!first) return (OP*)last; @@ -1613,10 +1829,7 @@ LISTOP* last; } OP * -prepend_elem(type, first, last) -I32 type; -OP* first; -OP* last; +prepend_elem(I32 type, OP *first, OP *last) { if (!first) return last; @@ -1647,14 +1860,13 @@ OP* last; /* Constructors */ OP * -newNULLLIST() +newNULLLIST(void) { return newOP(OP_STUB, 0); } OP * -force_list(o) -OP *o; +force_list(OP *o) { if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, Nullop); @@ -1663,11 +1875,7 @@ OP *o; } OP * -newLISTOP(type, flags, first, last) -I32 type; -I32 flags; -OP* first; -OP* last; +newLISTOP(I32 type, I32 flags, OP *first, OP *last) { LISTOP *listop; @@ -1702,9 +1910,7 @@ OP* last; } OP * -newOP(type, flags) -I32 type; -I32 flags; +newOP(I32 type, I32 flags) { OP *o; Newz(1101, o, 1, OP); @@ -1722,15 +1928,12 @@ I32 flags; } OP * -newUNOP(type, flags, first) -I32 type; -I32 flags; -OP* first; +newUNOP(I32 type, I32 flags, OP *first) { UNOP *unop; if (!first) - first = newOP(OP_STUB, 0); + first = newOP(OP_STUB, 0); if (opargs[type] & OA_MARK) first = force_list(first); @@ -1740,7 +1943,12 @@ OP* first; unop->op_first = first; unop->op_flags = flags | OPf_KIDS; unop->op_private = 1 | (flags >> 8); - +#if 1 + if(type == OP_STUDY && first->op_type == OP_MATCH) { + first->op_type = OP_PUSHRE; + first->op_ppaddr = ppaddr[OP_PUSHRE]; + } +#endif unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; @@ -1749,11 +1957,7 @@ OP* first; } OP * -newBINOP(type, flags, first, last) -I32 type; -I32 flags; -OP* first; -OP* last; +newBINOP(I32 type, I32 flags, OP *first, OP *last) { BINOP *binop; Newz(1101, binop, 1, BINOP); @@ -1784,10 +1988,7 @@ OP* last; } OP * -pmtrans(o, expr, repl) -OP *o; -OP *expr; -OP *repl; +pmtrans(OP *o, OP *expr, OP *repl) { SV *tstr = ((SVOP*)expr)->op_sv; SV *rstr = ((SVOP*)repl)->op_sv; @@ -1797,14 +1998,15 @@ OP *repl; register U8 *r = (U8*)SvPV(rstr, rlen); register I32 i; register I32 j; - I32 delete; + I32 Delete; I32 complement; + I32 squash; register short *tbl; tbl = (short*)cPVOPo->op_pv; complement = o->op_private & OPpTRANS_COMPLEMENT; - delete = o->op_private & OPpTRANS_DELETE; - /* squash = o->op_private & OPpTRANS_SQUASH; */ + Delete = o->op_private & OPpTRANS_DELETE; + squash = o->op_private & OPpTRANS_SQUASH; if (complement) { Zero(tbl, 256, short); @@ -1813,7 +2015,7 @@ OP *repl; for (i = 0, j = 0; i < 256; i++) { if (!tbl[i]) { if (j >= rlen) { - if (delete) + if (Delete) tbl[i] = -2; else if (rlen) tbl[i] = r[j-1]; @@ -1826,14 +2028,16 @@ OP *repl; } } else { - if (!rlen && !delete) { + if (!rlen && !Delete) { r = t; rlen = tlen; + if (!squash) + o->op_private |= OPpTRANS_COUNTONLY; } for (i = 0; i < 256; i++) tbl[i] = -1; for (i = 0, j = 0; i < tlen; i++,j++) { if (j >= rlen) { - if (delete) { + if (Delete) { if (tbl[t[i]] == -1) tbl[t[i]] = -2; continue; @@ -1851,9 +2055,7 @@ OP *repl; } OP * -newPMOP(type, flags) -I32 type; -I32 flags; +newPMOP(I32 type, I32 flags) { dTHR; PMOP *pmop; @@ -1864,6 +2066,9 @@ I32 flags; pmop->op_flags = flags; pmop->op_private = 0 | (flags >> 8); + if (hints & HINT_LOCALE) + pmop->op_pmpermflags = (pmop->op_pmflags |= PMf_LOCALE); + /* link into pm list */ if (type != OP_TRANS && curstash) { pmop->op_pmnext = HvPMROOT(curstash); @@ -1874,10 +2079,7 @@ I32 flags; } OP * -pmruntime(o, expr, repl) -OP *o; -OP *expr; -OP *repl; +pmruntime(OP *o, OP *expr, OP *repl) { PMOP *pm; LOGOP *rcop; @@ -1885,6 +2087,7 @@ OP *repl; if (o->op_type == OP_TRANS) return pmtrans(o, expr, repl); + hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; if (expr->op_type == OP_CONST) { @@ -1897,9 +2100,8 @@ OP *repl; pm->op_pmflags |= PMf_SKIPWHITE; } pm->op_pmregexp = pregcomp(p, p + plen, pm); - if (strEQ("\\s+", pm->op_pmregexp->precomp)) + if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; - hoistmust(pm); op_free(expr); } else { @@ -1932,17 +2134,32 @@ OP *repl; OP *curop; if (pm->op_pmflags & PMf_EVAL) curop = 0; +#ifdef USE_THREADS + else if (repl->op_type == OP_THREADSV + && strchr("&`'123456789+", + threadsv_names[repl->op_targ])) + { + curop = 0; + } +#endif /* USE_THREADS */ else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = 0; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (opargs[curop->op_type] & OA_DANGEROUS) { +#ifdef USE_THREADS + if (curop->op_type == OP_THREADSV + && strchr("&`'123456789+", curop->op_private)) { + break; + } +#else if (curop->op_type == OP_GV) { GV *gv = ((GVOP*)curop)->op_gv; if (strchr("&`'123456789+", *GvENAME(gv))) break; } +#endif /* USE_THREADS */ else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || @@ -1992,10 +2209,7 @@ OP *repl; } OP * -newSVOP(type, flags, sv) -I32 type; -I32 flags; -SV *sv; +newSVOP(I32 type, I32 flags, SV *sv) { SVOP *svop; Newz(1101, svop, 1, SVOP); @@ -2012,10 +2226,7 @@ SV *sv; } OP * -newGVOP(type, flags, gv) -I32 type; -I32 flags; -GV *gv; +newGVOP(I32 type, I32 flags, GV *gv) { dTHR; GVOP *gvop; @@ -2033,10 +2244,7 @@ GV *gv; } OP * -newPVOP(type, flags, pv) -I32 type; -I32 flags; -char *pv; +newPVOP(I32 type, I32 flags, char *pv) { PVOP *pvop; Newz(1101, pvop, 1, PVOP); @@ -2053,8 +2261,7 @@ char *pv; } void -package(o) -OP *o; +package(OP *o) { dTHR; SV *sv; @@ -2066,7 +2273,7 @@ OP *o; char *name; sv = cSVOPo->op_sv; name = SvPV(sv, len); - curstash = gv_stashpv(name,TRUE); + curstash = gv_stashpvn(name,len,TRUE); sv_setpvn(curstname, name, len); op_free(o); } @@ -2079,27 +2286,53 @@ OP *o; } void -utilize(aver, floor, id, arg) -int aver; -I32 floor; -OP *id; -OP *arg; +utilize(int aver, I32 floor, OP *version, OP *id, OP *arg) { OP *pack; OP *meth; OP *rqop; OP *imop; + OP *veop; if (id->op_type != OP_CONST) croak("Module name must be constant"); + veop = Nullop; + + if(version != Nullop) { + SV *vesv = ((SVOP*)version)->op_sv; + + if (arg == Nullop && !SvNIOK(vesv)) { + arg = version; + } + else { + OP *pack; + OP *meth; + + if (version->op_type != OP_CONST || !SvNIOK(vesv)) + croak("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 = newSVOP(OP_CONST, 0, newSVpv("VERSION", 7)); + veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(version)), + newUNOP(OP_METHOD, 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)) { + imop = Nullop; /* use 5.0; */ + } else { /* Make copy of id so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); - meth = newSVOP(OP_CONST, 0, aver ? newSVpv("import", 6) @@ -2119,7 +2352,9 @@ OP *arg; newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)), Nullop, append_elem(OP_LINESEQ, - newSTATEOP(0, Nullch, rqop), + append_elem(OP_LINESEQ, + newSTATEOP(0, Nullch, rqop), + newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); copline = NOLINE; @@ -2127,10 +2362,7 @@ OP *arg; } OP * -newSLICEOP(flags, subscript, listval) -I32 flags; -OP *subscript; -OP *listval; +newSLICEOP(I32 flags, OP *subscript, OP *listval) { return newBINOP(OP_LSLICE, flags, list(force_list(subscript)), @@ -2138,8 +2370,7 @@ OP *listval; } static I32 -list_assignment(o) -register OP *o; +list_assignment(register OP *o) { if (!o) return TRUE; @@ -2173,11 +2404,7 @@ register OP *o; } OP * -newASSIGNOP(flags, left, optype, right) -I32 flags; -OP *left; -I32 optype; -OP *right; +newASSIGNOP(I32 flags, OP *left, I32 optype, OP *right) { OP *o; @@ -2267,7 +2494,7 @@ OP *right; tmpop->op_sibling = Nullop; /* don't free split */ right->op_next = tmpop->op_next; /* fix starting loc */ op_free(o); /* blow off assign */ - right->op_flags &= ~(OPf_KNOW|OPf_LIST); + right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ return right; } @@ -2306,31 +2533,14 @@ OP *right; } OP * -newSTATEOP(flags, label, o) -I32 flags; -char *label; -OP *o; +newSTATEOP(I32 flags, char *label, OP *o) { dTHR; + U32 seq = intro_my(); register COP *cop; - /* Introduce my variables. */ - if (min_intro_pending) { - SV **svp = AvARRAY(comppad_name); - I32 i; - SV *sv; - for (i = min_intro_pending; i <= max_intro_pending; i++) { - if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) { - SvIVX(sv) = 999999999; /* Don't know scope end yet. */ - SvNVX(sv) = (double)cop_seqmax; - } - } - min_intro_pending = 0; - comppad_name_fill = max_intro_pending; /* Needn't search higher */ - } - Newz(1101, cop, 1, COP); - if (perldb && curcop->cop_line && curstash != debstash) { + if (PERLDB_LINE && curcop->cop_line && curstash != debstash) { cop->op_type = OP_DBSTATE; cop->op_ppaddr = ppaddr[ OP_DBSTATE ]; } @@ -2340,13 +2550,16 @@ OP *o; } cop->op_flags = flags; cop->op_private = 0 | (flags >> 8); +#ifdef NATIVE_HINTS + cop->op_private |= NATIVE_HINTS; +#endif cop->op_next = (OP*)cop; if (label) { cop->cop_label = label; hints |= HINT_BLOCK_SCOPE; } - cop->cop_seq = cop_seqmax++; + cop->cop_seq = seq; cop->cop_arybase = curcop->cop_arybase; if (copline == NOLINE) @@ -2355,10 +2568,10 @@ OP *o; cop->cop_line = copline; copline = NOLINE; } - cop->cop_filegv = SvREFCNT_inc(curcop->cop_filegv); + cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv); cop->cop_stash = curstash; - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE); if (svp && *svp != &sv_undef && !SvIOK(*svp)) { (void)SvIOK_on(*svp); @@ -2370,16 +2583,43 @@ OP *o; return prepend_elem(OP_LINESEQ, (OP*)cop, o); } +/* "Introduce" my variables to visible status. */ +U32 +intro_my(void) +{ + SV **svp; + SV *sv; + I32 i; + + if (! min_intro_pending) + return cop_seqmax; + + svp = AvARRAY(comppad_name); + for (i = min_intro_pending; i <= max_intro_pending; i++) { + if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) { + SvIVX(sv) = 999999999; /* Don't know scope end yet. */ + SvNVX(sv) = (double)cop_seqmax; + } + } + min_intro_pending = 0; + comppad_name_fill = max_intro_pending; /* Needn't search higher */ + return cop_seqmax++; +} + OP * -newLOGOP(type, flags, first, other) -I32 type; -I32 flags; -OP* first; -OP* other; +newLOGOP(I32 type, I32 flags, OP *first, OP *other) +{ + return new_logop(type, flags, &first, &other); +} + +static OP * +new_logop(I32 type, I32 flags, OP** firstp, OP** otherp) { dTHR; LOGOP *logop; OP *o; + OP *first = *firstp; + OP *other = *otherp; if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); @@ -2393,7 +2633,7 @@ OP* other; else type = OP_AND; o = first; - first = cUNOPo->op_first; + first = *firstp = cUNOPo->op_first; if (o->op_next) first->op_next = o->op_next; cUNOPo->op_first = Nullop; @@ -2405,10 +2645,12 @@ OP* other; warn("Probable precedence problem on %s", op_desc[type]); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); + *firstp = Nullop; return other; } else { op_free(other); + *otherp = Nullop; return first; } } @@ -2418,6 +2660,36 @@ OP* other; else scalar(other); } + else if (dowarn && (first->op_flags & OPf_KIDS)) { + OP *k1 = ((UNOP*)first)->op_first; + OP *k2 = k1->op_sibling; + OPCODE warnop = 0; + switch (first->op_type) + { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV)) + warnop = k2->op_type; + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || k1->op_type == OP_EACH) + warnop = k1->op_type; + break; + } + if (warnop) { + line_t oldline = curcop->cop_line; + curcop->cop_line = copline; + warn("Value of %s%s can be \"0\"; test with defined()", + op_desc[warnop], + ((warnop == OP_READLINE || warnop == OP_GLOB) + ? " construct" : "() operator")); + curcop->cop_line = oldline; + } + } if (!other) return first; @@ -2446,37 +2718,33 @@ OP* other; } OP * -newCONDOP(flags, first, true, false) -I32 flags; -OP* first; -OP* true; -OP* false; +newCONDOP(I32 flags, OP *first, OP *trueop, OP *falseop) { dTHR; CONDOP *condop; OP *o; - if (!false) - return newLOGOP(OP_AND, 0, first, true); - if (!true) - return newLOGOP(OP_OR, 0, first, false); + if (!falseop) + return newLOGOP(OP_AND, 0, first, trueop); + if (!trueop) + return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); if (first->op_type == OP_CONST) { if (SvTRUE(((SVOP*)first)->op_sv)) { op_free(first); - op_free(false); - return true; + op_free(falseop); + return trueop; } else { op_free(first); - op_free(true); - return false; + op_free(trueop); + return falseop; } } else if (first->op_type == OP_WANTARRAY) { - list(true); - scalar(false); + list(trueop); + scalar(falseop); } Newz(1101, condop, 1, CONDOP); @@ -2484,29 +2752,26 @@ OP* false; condop->op_ppaddr = ppaddr[OP_COND_EXPR]; condop->op_first = first; condop->op_flags = flags | OPf_KIDS; - condop->op_true = LINKLIST(true); - condop->op_false = LINKLIST(false); + condop->op_true = LINKLIST(trueop); + condop->op_false = LINKLIST(falseop); condop->op_private = 1 | (flags >> 8); /* establish postfix order */ condop->op_next = LINKLIST(first); first->op_next = (OP*)condop; - first->op_sibling = true; - true->op_sibling = false; + first->op_sibling = trueop; + trueop->op_sibling = falseop; o = newUNOP(OP_NULL, 0, (OP*)condop); - true->op_next = o; - false->op_next = o; + trueop->op_next = o; + falseop->op_next = o; return o; } OP * -newRANGE(flags, left, right) -I32 flags; -OP *left; -OP *right; +newRANGE(I32 flags, OP *left, OP *right) { dTHR; CONDOP *condop; @@ -2551,11 +2816,7 @@ OP *right; } OP * -newLOOPOP(flags, debuggable, expr, block) -I32 flags; -I32 debuggable; -OP *expr; -OP *block; +newLOOPOP(I32 flags, I32 debuggable, OP *expr, OP *block) { dTHR; OP* listop; @@ -2566,14 +2827,18 @@ OP *block; if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ - else if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) - expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr); + if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { + expr = newUNOP(OP_DEFINED, 0, + newASSIGNOP(0, newDEFSVOP(), 0, expr) ); + } } listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); - o = newLOGOP(OP_AND, 0, expr, listop); + o = new_logop(OP_AND, 0, &expr, &listop); - ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); + if (listop) + ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); if (once && o != listop) o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; @@ -2588,13 +2853,7 @@ OP *block; } OP * -newWHILEOP(flags, debuggable, loop, expr, block, cont) -I32 flags; -I32 debuggable; -LOOP *loop; -OP *expr; -OP *block; -OP *cont; +newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) { dTHR; OP *redo; @@ -2603,9 +2862,10 @@ OP *cont; OP *o; OP *condop; - if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) { + if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { expr = newUNOP(OP_DEFINED, 0, - newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); + newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } if (!block) @@ -2613,21 +2873,30 @@ OP *cont; if (cont) next = LINKLIST(cont); - if (expr) + if (expr) { cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + if ((line_t)whileline != NOLINE) { + copline = whileline; + cont = append_elem(OP_LINESEQ, cont, + newSTATEOP(0, Nullch, Nullop)); + } + } listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); redo = LINKLIST(listop); if (expr) { - o = newLOGOP(OP_AND, 0, expr, scalar(listop)); + copline = whileline; + scalar(listop); + o = new_logop(OP_AND, 0, &expr, &listop); if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { op_free(expr); /* oops, it's a while (0) */ op_free((OP*)loop); - return Nullop; /* (listop already freed by newLOGOP) */ + return Nullop; /* listop already freed by new_logop */ } - ((LISTOP*)listop)->op_last->op_next = condop = - (o == listop ? redo : LINKLIST(o)); + if (listop) + ((LISTOP*)listop)->op_last->op_next = condop = + (o == listop ? redo : LINKLIST(o)); if (!next) next = condop; } @@ -2658,24 +2927,13 @@ OP *cont; } OP * -#ifndef CAN_PROTOTYPE -newFOROP(flags,label,forline,sv,expr,block,cont) -I32 flags; -char *label; -line_t forline; -OP* sv; -OP* expr; -OP*block; -OP*cont; -#else newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) -#endif /* CAN_PROTOTYPE */ { LOOP *loop; + OP *wop; int padoff = 0; I32 iterflags = 0; - copline = forline; if (sv) { if (sv->op_type == OP_RV2SV) { /* symbol table variable */ sv->op_type = OP_RV2GV; @@ -2686,13 +2944,24 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont op_free(sv); sv = Nullop; } + else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ + padoff = sv->op_targ; + iterflags |= OPf_SPECIAL; + op_free(sv); + sv = Nullop; + } else croak("Can't use %s for loop variable", op_desc[sv->op_type]); } else { +#ifdef USE_THREADS + padoff = find_threadsv("_"); + iterflags |= OPf_SPECIAL; +#else sv = newGVOP(OP_GV, 0, defgv); +#endif } - if (expr->op_type == OP_RV2AV) { + if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { expr = scalar(ref(expr, OP_ITER)); iterflags |= OPf_STACKED; } @@ -2702,22 +2971,25 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont assert(!loop->op_next); Renew(loop, 1, LOOP); loop->op_targ = padoff; - return newSTATEOP(0, label, newWHILEOP(flags, 1, loop, - newOP(OP_ITER, 0), block, cont)); + wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); + copline = forline; + return newSTATEOP(0, label, wop); } OP* -newLOOPEX(type, label) -I32 type; -OP* label; +newLOOPEX(I32 type, OP *label) { dTHR; OP *o; if (type != OP_GOTO || label->op_type == OP_CONST) { - o = newPVOP(type, 0, savepv( - label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, na) - : "" )); + /* "last()" means "last" */ + if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) + o = newOP(type, OPf_SPECIAL); + else { + o = newPVOP(type, 0, savepv(label->op_type == OP_CONST + ? SvPVx(((SVOP*)label)->op_sv, na) + : "")); + } op_free(label); } else { @@ -2730,16 +3002,14 @@ OP* label; } void -cv_undef(cv) -CV *cv; +cv_undef(CV *cv) { dTHR; #ifdef USE_THREADS - MUTEX_DESTROY(CvMUTEXP(cv)); - Safefree(CvMUTEXP(cv)); - if (CvCONDP(cv)) { - COND_DESTROY(CvCONDP(cv)); - Safefree(CvCONDP(cv)); + if (CvMUTEXP(cv)) { + MUTEX_DESTROY(CvMUTEXP(cv)); + Safefree(CvMUTEXP(cv)); + CvMUTEXP(cv) = 0; } #endif /* USE_THREADS */ @@ -2761,25 +3031,83 @@ CV *cv; CvROOT(cv) = Nullop; LEAVE; } + SvPOK_off((SV*)cv); /* forget prototype */ + CvFLAGS(cv) = 0; SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; if (CvPADLIST(cv)) { - I32 i = AvFILL(CvPADLIST(cv)); - while (i >= 0) { - SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); - if (svp) - SvREFCNT_dec(*svp); + /* may be during global destruction */ + if (SvREFCNT(CvPADLIST(cv))) { + I32 i = AvFILLp(CvPADLIST(cv)); + while (i >= 0) { + SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); + SV* sv = svp ? *svp : Nullsv; + if (!sv) + continue; + if (sv == (SV*)comppad_name) + comppad_name = Nullav; + else if (sv == (SV*)comppad) { + comppad = Nullav; + curpad = Null(SV**); + } + SvREFCNT_dec(sv); + } + SvREFCNT_dec((SV*)CvPADLIST(cv)); } - SvREFCNT_dec((SV*)CvPADLIST(cv)); CvPADLIST(cv) = Nullav; } } -CV * -cv_clone(proto) -CV* proto; +#ifdef DEBUG_CLOSURES +static void +cv_dump(cv) +CV* cv; +{ + CV *outside = CvOUTSIDE(cv); + AV* padlist = CvPADLIST(cv); + AV* pad_name; + AV* pad; + SV** pname; + SV** ppad; + I32 ix; + + PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n", + cv, + (CvANON(cv) ? "ANON" + : (cv == main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), + outside, + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + + if (!padlist) + return; + + pad_name = (AV*)*av_fetch(padlist, 0, FALSE); + pad = (AV*)*av_fetch(padlist, 1, FALSE); + pname = AvARRAY(pad_name); + ppad = AvARRAY(pad); + + for (ix = 1; ix <= AvFILLp(pad_name); ix++) { + if (SvPOK(pname[ix])) + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n", + ix, ppad[ix], + SvFAKE(pname[ix]) ? "FAKE " : "", + SvPVX(pname[ix]), + (long)I_32(SvNVX(pname[ix])), + (long)SvIVX(pname[ix])); + } +} +#endif /* DEBUG_CLOSURES */ + +static CV * +cv_clone2(CV *proto, CV *outside) { dTHR; AV* av; @@ -2787,42 +3115,55 @@ CV* proto; AV* protopadlist = CvPADLIST(proto); AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE); AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); - SV** svp = AvARRAY(protopad); + SV** pname = AvARRAY(protopad_name); + SV** ppad = AvARRAY(protopad); + I32 fname = AvFILLp(protopad_name); + I32 fpad = AvFILLp(protopad); AV* comppadlist; CV* cv; + assert(!CvUNIQUE(proto)); + ENTER; SAVESPTR(curpad); SAVESPTR(comppad); + SAVESPTR(comppad_name); SAVESPTR(compcv); cv = compcv = (CV*)NEWSV(1104,0); - sv_upgrade((SV *)cv, SVt_PVCV); + sv_upgrade((SV *)cv, SvTYPE(proto)); CvCLONED_on(cv); + if (CvANON(proto)) + CvANON_on(cv); #ifdef USE_THREADS - New(666, CvMUTEXP(cv), 1, pthread_mutex_t); + New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, pthread_cond_t); - COND_INIT(CvCONDP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILEGV(cv) = CvFILEGV(proto); - CvGV(cv) = SvREFCNT_inc(CvGV(proto)); + CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); CvSTASH(cv) = CvSTASH(proto); CvROOT(cv) = CvROOT(proto); CvSTART(cv) = CvSTART(proto); - if (CvOUTSIDE(proto)) - CvOUTSIDE(cv) = (CV*)SvREFCNT_inc((SV*)CvOUTSIDE(proto)); + if (outside) + CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); + + if (SvPOK(proto)) + sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto)); + + comppad_name = newAV(); + for (ix = fname; ix >= 0; ix--) + av_store(comppad_name, ix, SvREFCNT_inc(pname[ix])); comppad = newAV(); comppadlist = newAV(); AvREAL_off(comppadlist); - av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_name)); + av_store(comppadlist, 0, (SV*)comppad_name); av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(cv) = comppadlist; - av_extend(comppad, AvFILL(protopad)); + av_fill(comppad, AvFILLp(protopad)); curpad = AvARRAY(comppad); av = newAV(); /* will be @_ */ @@ -2830,71 +3171,185 @@ CV* proto; av_store(comppad, 0, (SV*)av); AvFLAGS(av) = AVf_REIFY; - svp = AvARRAY(protopad_name); - for ( ix = AvFILL(protopad); ix > 0; ix--) { - SV *sv; - if (svp[ix] != &sv_undef) { - char *name = SvPVX(svp[ix]); /* XXX */ - if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* lexical from outside? */ - I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto), - cxstack_ix); - if (off != ix) + for (ix = fpad; ix > 0; ix--) { + SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; + if (namesv && namesv != &sv_undef) { + char *name = SvPVX(namesv); /* XXX */ + if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */ + I32 off = pad_findlex(name, ix, SvIVX(namesv), + CvOUTSIDE(cv), cxstack_ix); + if (!off) + curpad[ix] = SvREFCNT_inc(ppad[ix]); + else if (off != ix) croak("panic: cv_clone: %s", name); } else { /* our own lexical */ - if (*name == '@') - av_store(comppad, ix, sv = (SV*)newAV()); + SV* sv; + if (*name == '&') { + /* anon code -- we'll come back for it */ + sv = SvREFCNT_inc(ppad[ix]); + } + else if (*name == '@') + sv = (SV*)newAV(); else if (*name == '%') - av_store(comppad, ix, sv = (SV*)newHV()); + sv = (SV*)newHV(); else - av_store(comppad, ix, sv = NEWSV(0,0)); - SvPADMY_on(sv); + sv = NEWSV(0,0); + if (!SvPADBUSY(sv)) + SvPADMY_on(sv); + curpad[ix] = sv; } } else { - av_store(comppad, ix, sv = NEWSV(0,0)); + SV* sv = NEWSV(0,0); SvPADTMP_on(sv); + curpad[ix] = sv; + } + } + + /* Now that vars are all in place, clone nested closures. */ + + for (ix = fpad; ix > 0; ix--) { + SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; + if (namesv + && namesv != &sv_undef + && !(SvFLAGS(namesv) & SVf_FAKE) + && *SvPVX(namesv) == '&' + && CvCLONE(ppad[ix])) + { + CV *kid = cv_clone2((CV*)ppad[ix], cv); + SvREFCNT_dec(ppad[ix]); + CvCLONE_on(kid); + SvPADMY_on(kid); + curpad[ix] = (SV*)kid; } } +#ifdef DEBUG_CLOSURES + PerlIO_printf(Perl_debug_log, "Cloned inside:\n"); + cv_dump(outside); + PerlIO_printf(Perl_debug_log, " from:\n"); + cv_dump(proto); + PerlIO_printf(Perl_debug_log, " to:\n"); + cv_dump(cv); +#endif + LEAVE; return cv; } CV * -newSUB(floor,o,proto,block) -I32 floor; -OP *o; -OP *proto; -OP *block; +cv_clone(CV *proto) +{ + return cv_clone2(proto, CvOUTSIDE(proto)); +} + +void +cv_ckproto(CV *cv, GV *gv, char *p) +{ + if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) { + SV* msg = sv_newmortal(); + SV* name = Nullsv; + + if (gv) + gv_efullname3(name = sv_newmortal(), gv, Nullch); + sv_setpv(msg, "Prototype mismatch:"); + if (name) + sv_catpvf(msg, " sub %_", name); + if (SvPOK(cv)) + sv_catpvf(msg, " (%s)", SvPVX(cv)); + sv_catpv(msg, " vs "); + if (p) + sv_catpvf(msg, "(%s)", p); + else + sv_catpv(msg, "none"); + warn("%_", msg); + } +} + +SV * +cv_const_sv(CV *cv) +{ + OP *o; + SV *sv; + + if (!cv || !SvPOK(cv) || SvCUR(cv)) + return Nullsv; + + sv = Nullsv; + for (o = CvSTART(cv); o; o = o->op_next) { + OPCODE type = o->op_type; + + if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) + continue; + if (type == OP_LEAVESUB || type == OP_RETURN) + break; + if (sv) + return Nullsv; + if (type == OP_CONST) + sv = cSVOPo->op_sv; + else if (type == OP_PADSV) { + AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); + sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; + if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) + return Nullsv; + } + else + return Nullsv; + } + if (sv) + SvREADONLY_on(sv); + return sv; +} + +CV * +newSUB(I32 floor, OP *o, OP *proto, OP *block) { dTHR; + char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch; + GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); + char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; register CV *cv; - char *name = o ? SvPVx(cSVOPo->op_sv, na) : "__ANON__"; - GV* gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV); - AV* av; - char *s; I32 ix; if (o) - sub_generation++; - if (cv = GvCV(gv)) { - if (GvCVGEN(gv)) - cv = 0; /* just a cached method */ - else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { - if (dowarn) { /* already defined (or promised)? */ + SAVEFREEOP(o); + if (proto) + SAVEFREEOP(proto); + + if (!name || GvCVGEN(gv)) + cv = Nullcv; + else if (cv = GvCV(gv)) { + cv_ckproto(cv, gv, ps); + /* already defined (or promised)? */ + if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + SV* const_sv; + if (!block) { + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(compcv); + goto done; + } + /* ahem, death to those who redefine active sort subs */ + if (curstackinfo->si_type == SI_SORT && sortcop == CvSTART(cv)) + croak("Can't redefine active sort subroutine %s", name); + const_sv = cv_const_sv(cv); + if (const_sv || dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv)) + && HvNAME(GvSTASH(CvGV(cv))) + && strEQ(HvNAME(GvSTASH(CvGV(cv))), + "autouse"))) { line_t oldline = curcop->cop_line; - curcop->cop_line = copline; - warn("Subroutine %s redefined",name); + warn(const_sv ? "Constant subroutine %s redefined" + : "Subroutine %s redefined", name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); - cv = 0; + cv = Nullcv; } } if (cv) { /* must reuse cv if autoloaded */ cv_undef(cv); + CvFLAGS(cv) = CvFLAGS(compcv); CvOUTSIDE(cv) = CvOUTSIDE(compcv); CvOUTSIDE(compcv) = 0; CvPADLIST(cv) = CvPADLIST(compcv); @@ -2905,144 +3360,208 @@ OP *block; } else { cv = compcv; + if (name) { + GvCV(gv) = cv; + GvCVGEN(gv) = 0; + sub_generation++; + } } - GvCV(gv) = cv; - GvCVGEN(gv) = 0; + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; - CvGV(cv) = SvREFCNT_inc(gv); CvSTASH(cv) = curstash; #ifdef USE_THREADS CvOWNER(cv) = 0; - New(666, CvMUTEXP(cv), 1, pthread_mutex_t); + New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, pthread_cond_t); - COND_INIT(CvCONDP(cv)); #endif /* USE_THREADS */ - if (proto) { - char *p = SvPVx(((SVOP*)proto)->op_sv, na); - if (SvPOK(cv) && strNE(SvPV((SV*)cv,na), p)) - warn("Prototype mismatch: (%s) vs (%s)", SvPV((SV*)cv, na), p); - sv_setpv((SV*)cv, p); - op_free(proto); - } + if (ps) + sv_setpv((SV*)cv, ps); if (error_count) { op_free(block); block = Nullop; + if (name) { + char *s = strrchr(name, ':'); + s = s ? s+1 : name; + if (strEQ(s, "BEGIN")) { + char *not_safe = + "BEGIN not safe after errors--compilation aborted"; + if (in_eval & 4) + croak(not_safe); + else { + /* force display of errors found but not reported */ + sv_catpv(ERRSV, not_safe); + croak("%s", SvPVx(ERRSV, na)); + } + } + } } if (!block) { - CvROOT(cv) = 0; - op_free(o); copline = NOLINE; LEAVE_SCOPE(floor); return cv; } - av = newAV(); /* Will be @_ */ - av_extend(av, 0); - av_store(comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; + if (AvFILLp(comppad_name) < AvFILLp(comppad)) + av_store(comppad_name, AvFILLp(comppad), Nullsv); - for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) - SvPADTMP_on(curpad[ix]); + if (CvCLONE(cv)) { + SV **namep = AvARRAY(comppad_name); + for (ix = AvFILLp(comppad); ix > 0; ix--) { + SV *namesv; + + if (SvIMMORTAL(curpad[ix])) + continue; + /* + * The only things that a clonable function needs in its + * pad are references to outer lexicals and anonymous subs. + * The rest are created anew during cloning. + */ + if (!((namesv = namep[ix]) != Nullsv && + namesv != &sv_undef && + (SvFAKE(namesv) || + *SvPVX(namesv) == '&'))) + { + SvREFCNT_dec(curpad[ix]); + curpad[ix] = Nullsv; + } + } } + else { + AV *av = newAV(); /* Will be @_ */ + av_extend(av, 0); + av_store(comppad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; - if (AvFILL(comppad_name) < AvFILL(comppad)) - av_store(comppad_name, AvFILL(comppad), Nullsv); + for (ix = AvFILLp(comppad); ix > 0; ix--) { + if (SvIMMORTAL(curpad[ix])) + continue; + if (!SvPADMY(curpad[ix])) + SvPADTMP_on(curpad[ix]); + } + } CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - if (s = strrchr(name,':')) - s++; - else - s = name; - if (strEQ(s, "BEGIN") && !error_count) { - line_t oldline = compiling.cop_line; - SV *oldrs = rs; - ENTER; - SAVESPTR(compiling.cop_filegv); - SAVEI32(perldb); - if (!beginav) - beginav = newAV(); - av_push(beginav, (SV *)cv); - DEBUG_x( dump_sub(gv) ); - rs = SvREFCNT_inc(nrs); - GvCV(gv) = 0; - calllist(beginav); - SvREFCNT_dec(rs); - rs = oldrs; - curcop = &compiling; - curcop->cop_line = oldline; /* might have recursed to yylex */ - LEAVE; - } - else if (strEQ(s, "END") && !error_count) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(cv)); - } - if (perldb && curstash != debstash) { - SV *sv; - SV *tmpstr = sv_newmortal(); + if (name) { + char *s; + + if (PERLDB_SUBLINE && curstash != debstash) { + SV *sv = NEWSV(0,0); + SV *tmpstr = sv_newmortal(); + GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); + CV *cv; + HV *hv; + + sv_setpvf(sv, "%_:%ld-%ld", + GvSV(curcop->cop_filegv), + (long)subline, (long)curcop->cop_line); + gv_efullname3(tmpstr, gv, Nullch); + hv_store(GvHV(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))) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } + } - sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), (long)subline); - sv = newSVpv(buf,0); - sv_catpv(sv,"-"); - sprintf(buf,"%ld",(long)curcop->cop_line); - sv_catpv(sv,buf); - gv_efullname(tmpstr,gv); - hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + if ((s = strrchr(name,':'))) + s++; + else + s = name; + if (strEQ(s, "BEGIN")) { + I32 oldscope = scopestack_ix; + ENTER; + SAVESPTR(compiling.cop_filegv); + SAVEI16(compiling.cop_line); + SAVEI32(perldb); + save_svref(&rs); + sv_setsv(rs, nrs); + + if (!beginav) + beginav = newAV(); + DEBUG_x( dump_sub(gv) ); + av_push(beginav, (SV *)cv); + GvCV(gv) = 0; + call_list(oldscope, beginav); + + curcop = &compiling; + LEAVE; + } + else if (strEQ(s, "END") && !error_count) { + if (!endav) + endav = newAV(); + av_unshift(endav, 1); + av_store(endav, 0, (SV *)cv); + GvCV(gv) = 0; + } + else if (strEQ(s, "INIT") && !error_count) { + if (!initav) + initav = newAV(); + av_push(initav, SvREFCNT_inc(cv)); + } } - op_free(o); + + done: copline = NOLINE; LEAVE_SCOPE(floor); - if (!o) { - GvCV(gv) = 0; /* Will remember in SVOP instead. */ - CvANON_on(cv); - } return cv; } -#ifdef DEPRECATED -CV * -newXSUB(name, ix, subaddr, filename) -char *name; -I32 ix; -I32 (*subaddr)(); -char *filename; -{ - CV* cv = newXS(name, (void(*)())subaddr, filename); - CvOLDSTYLE_on(cv); - CvXSUBANY(cv).any_i32 = ix; - return cv; +void +newCONSTSUB(HV *stash, char *name, SV *sv) +{ + dTHR; + U32 oldhints = hints; + HV *old_cop_stash = curcop->cop_stash; + HV *old_curstash = curstash; + line_t oldline = curcop->cop_line; + curcop->cop_line = copline; + + hints &= ~HINT_BLOCK_SCOPE; + if(stash) + curstash = curcop->cop_stash = stash; + + newSUB( + start_subparse(FALSE, 0), + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + hints = oldhints; + curcop->cop_stash = old_cop_stash; + curstash = old_curstash; + curcop->cop_line = oldline; } -#endif CV * -newXS(name, subaddr, filename) -char *name; -void (*subaddr) _((CV*)); -char *filename; +newXS(char *name, void (*subaddr) (CV *), char *filename) { dTHR; + GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; - GV *gv = gv_fetchpv((name ? name : "__ANON__"), GV_ADDMULTI, SVt_PVCV); - char *s; - - if (name) - sub_generation++; - if (cv = GvCV(gv)) { - if (GvCVGEN(gv)) - cv = 0; /* just a cached method */ - else if (CvROOT(cv) || CvXSUB(cv)) { /* already defined? */ - if (dowarn) { - line_t oldline = curcop->cop_line; + if (cv = (name ? GvCV(gv) : Nullcv)) { + if (GvCVGEN(gv)) { + /* just a cached method */ + SvREFCNT_dec(cv); + cv = 0; + } + else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + /* already defined (or promised) */ + if (dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv)) + && HvNAME(GvSTASH(CvGV(cv))) + && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { + line_t oldline = curcop->cop_line; curcop->cop_line = copline; warn("Subroutine %s redefined",name); curcop->cop_line = oldline; @@ -3051,55 +3570,60 @@ char *filename; cv = 0; } } - if (cv) { /* must reuse cv if autoloaded */ - assert(SvREFCNT(CvGV(cv)) > 1); - SvREFCNT_dec(CvGV(cv)); - } + + if (cv) /* must reuse cv if autoloaded */ + cv_undef(cv); else { cv = (CV*)NEWSV(1105,0); sv_upgrade((SV *)cv, SVt_PVCV); + if (name) { + GvCV(gv) = cv; + GvCVGEN(gv) = 0; + sub_generation++; + } } - GvCV(gv) = cv; - CvGV(cv) = SvREFCNT_inc(gv); - GvCVGEN(gv) = 0; + CvGV(cv) = (GV*)SvREFCNT_inc(gv); #ifdef USE_THREADS - New(666, CvMUTEXP(cv), 1, pthread_mutex_t); + New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, pthread_cond_t); - COND_INIT(CvCONDP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILEGV(cv) = gv_fetchfile(filename); CvXSUB(cv) = subaddr; - if (!name) - s = "__ANON__"; - else if (s = strrchr(name,':')) - s++; + + if (name) { + char *s = strrchr(name,':'); + if (s) + s++; + else + s = name; + if (strEQ(s, "BEGIN")) { + if (!beginav) + beginav = newAV(); + av_push(beginav, (SV *)cv); + GvCV(gv) = 0; + } + else if (strEQ(s, "END")) { + if (!endav) + endav = newAV(); + av_unshift(endav, 1); + av_store(endav, 0, (SV *)cv); + GvCV(gv) = 0; + } + else if (strEQ(s, "INIT")) { + if (!initav) + initav = newAV(); + av_push(initav, (SV *)cv); + } + } else - s = name; - if (strEQ(s, "BEGIN")) { - if (!beginav) - beginav = newAV(); - av_push(beginav, SvREFCNT_inc(gv)); - } - else if (strEQ(s, "END")) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(gv)); - } - if (!name) { - GvCV(gv) = 0; /* Will remember elsewhere instead. */ CvANON_on(cv); - } + return cv; } void -newFORM(floor,o,block) -I32 floor; -OP *o; -OP *block; +newFORM(I32 floor, OP *o, OP *block) { dTHR; register CV *cv; @@ -3125,11 +3649,11 @@ OP *block; } cv = compcv; GvFORM(gv) = cv; - CvGV(cv) = SvREFCNT_inc(gv); + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; - for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) + for (ix = AvFILLp(comppad); ix > 0; ix--) { + if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix])) SvPADTMP_on(curpad[ix]); } @@ -3137,41 +3661,34 @@ OP *block; CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - FmLINES(cv) = 0; op_free(o); copline = NOLINE; LEAVE_SCOPE(floor); } OP * -newANONLIST(o) -OP* o; +newANONLIST(OP *o) { return newUNOP(OP_REFGEN, 0, mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); } OP * -newANONHASH(o) -OP* o; +newANONHASH(OP *o) { return newUNOP(OP_REFGEN, 0, mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); } OP * -newANONSUB(floor, proto, block) -I32 floor; -OP *proto; -OP *block; +newANONSUB(I32 floor, OP *proto, OP *block) { return newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block))); } OP * -oopsAV(o) -OP *o; +oopsAV(OP *o) { switch (o->op_type) { case OP_PADSV: @@ -3193,8 +3710,7 @@ OP *o; } OP * -oopsHV(o) -OP *o; +oopsHV(OP *o) { switch (o->op_type) { case OP_PADSV: @@ -3218,8 +3734,7 @@ OP *o; } OP * -newAVREF(o) -OP *o; +newAVREF(OP *o) { if (o->op_type == OP_PADANY) { o->op_type = OP_PADAV; @@ -3230,9 +3745,7 @@ OP *o; } OP * -newGVREF(type,o) -I32 type; -OP *o; +newGVREF(I32 type, OP *o) { if (type == OP_MAPSTART) return newUNOP(OP_NULL, 0, o); @@ -3240,8 +3753,7 @@ OP *o; } OP * -newHVREF(o) -OP *o; +newHVREF(OP *o) { if (o->op_type == OP_PADANY) { o->op_type = OP_PADHV; @@ -3252,8 +3764,7 @@ OP *o; } OP * -oopsCV(o) -OP *o; +oopsCV(OP *o) { croak("NOT IMPL LINE %d",__LINE__); /* STUB */ @@ -3261,30 +3772,57 @@ OP *o; } OP * -newCVREF(flags, o) -I32 flags; -OP *o; +newCVREF(I32 flags, OP *o) { return newUNOP(OP_RV2CV, flags, scalar(o)); } OP * -newSVREF(o) -OP *o; +newSVREF(OP *o) { if (o->op_type == OP_PADANY) { o->op_type = OP_PADSV; o->op_ppaddr = ppaddr[OP_PADSV]; return o; } + else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { + o->op_flags |= OPpDONE_SVREF; + return o; + } return newUNOP(OP_RV2SV, 0, scalar(o)); } /* Check routines. */ OP * -ck_concat(o) -OP *o; +ck_anoncode(OP *o) +{ + PADOFFSET ix; + SV* name; + + name = NEWSV(1106,0); + sv_upgrade(name, SVt_PVNV); + sv_setpvn(name, "&", 1); + SvIVX(name) = -1; + SvNVX(name) = 1; + ix = pad_alloc(o->op_type, SVs_PADMY); + av_store(comppad_name, ix, name); + av_store(comppad, ix, cSVOPo->op_sv); + SvPADMY_on(cSVOPo->op_sv); + cSVOPo->op_sv = Nullsv; + cSVOPo->op_targ = ix; + return o; +} + +OP * +ck_bitop(OP *o) +{ + o->op_private = hints; + return o; +} + +OP * +ck_concat(OP *o) { if (cUNOPo->op_first->op_type == OP_CONCAT) o->op_flags |= OPf_STACKED; @@ -3292,13 +3830,13 @@ OP *o; } OP * -ck_spair(o) -OP *o; +ck_spair(OP *o) { if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; - o = modkids(ck_fun(o), o->op_type); + OPCODE type = o->op_type; + o = modkids(ck_fun(o), type); kid = cUNOPo->op_first; newop = kUNOP->op_first->op_sibling; if (newop && @@ -3306,7 +3844,7 @@ OP *o; !(opargs[newop->op_type] & OA_RETSCALAR) || newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { - + return o; } op_free(kUNOP->op_first); @@ -3317,22 +3855,24 @@ OP *o; } OP * -ck_delete(o) -OP *o; +ck_delete(OP *o) { o = ck_fun(o); + o->op_private = 0; if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type != OP_HELEM) - croak("%s argument is not a HASH element", op_desc[o->op_type]); + if (kid->op_type == OP_HSLICE) + o->op_private |= OPpSLICE; + else if (kid->op_type != OP_HELEM) + croak("%s argument is not a HASH element or slice", + op_desc[o->op_type]); null(kid); } return o; } OP * -ck_eof(o) -OP *o; +ck_eof(OP *o) { I32 type = o->op_type; @@ -3340,7 +3880,7 @@ OP *o; if (cLISTOPo->op_first->op_type == OP_STUB) { op_free(o); o = newUNOP(type, OPf_SPECIAL, - newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE, SVt_PVAV))); + newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV))); } return ck_fun(o); } @@ -3348,8 +3888,7 @@ OP *o; } OP * -ck_eval(o) -OP *o; +ck_eval(OP *o) { hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { @@ -3380,18 +3919,19 @@ OP *o; enter->op_other = o; return o; } + else + scalar((OP*)kid); } else { op_free(o); - o = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); + o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); } o->op_targ = (PADOFFSET)hints; return o; } OP * -ck_exec(o) -OP *o; +ck_exec(OP *o) { OP *kid; if (o->op_flags & OPf_STACKED) { @@ -3406,8 +3946,20 @@ OP *o; } OP * -ck_gvconst(o) -register OP *o; +ck_exists(OP *o) +{ + o = ck_fun(o); + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; + if (kid->op_type != OP_HELEM) + croak("%s argument is not a HASH element", op_desc[o->op_type]); + null(kid); + } + return o; +} + +OP * +ck_gvconst(register OP *o) { o = fold_constants(o); if (o->op_type == OP_CONST) @@ -3416,27 +3968,47 @@ register OP *o; } OP * -ck_rvconst(o) -register OP *o; +ck_rvconst(register OP *o) { dTHR; SVOP *kid = (SVOP*)cUNOPo->op_first; o->op_private |= (hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { - int iscv = (o->op_type==OP_RV2CV)*2; - GV *gv = 0; - kid->op_type = OP_GV; - for (gv = 0; !gv; iscv++) { - /* - * This is a little tricky. We only want to add the symbol if we - * didn't add it in the lexer. Otherwise we get duplicate strict - * warnings. But if we didn't add it in the lexer, we must at - * least pretend like we wanted to add it even if it existed before, - * or we get possible typo warnings. OPpCONST_ENTERED says - * whether the lexer already added THIS instance of this symbol. - */ - gv = gv_fetchpv(SvPVx(kid->op_sv, na), + char *name; + int iscv; + GV *gv; + + name = SvPV(kid->op_sv, na); + if ((hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { + char *badthing = Nullch; + switch (o->op_type) { + case OP_RV2SV: + badthing = "a SCALAR"; + break; + case OP_RV2AV: + badthing = "an ARRAY"; + break; + case OP_RV2HV: + badthing = "a HASH"; + break; + } + if (badthing) + croak( + "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", + name, badthing); + } + /* + * This is a little tricky. We only want to add the symbol if we + * didn't add it in the lexer. Otherwise we get duplicate strict + * warnings. But if we didn't add it in the lexer, we must at + * least pretend like we wanted to add it even if it existed before, + * or we get possible typo warnings. OPpCONST_ENTERED says + * whether the lexer already added THIS instance of this symbol. + */ + iscv = (o->op_type == OP_RV2CV) * 2; + do { + gv = gv_fetchpv(name, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV @@ -3447,23 +4019,18 @@ register OP *o; : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); + } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); + if (gv) { + kid->op_type = OP_GV; + SvREFCNT_dec(kid->op_sv); + kid->op_sv = SvREFCNT_inc(gv); } - SvREFCNT_dec(kid->op_sv); - kid->op_sv = SvREFCNT_inc(gv); } return o; } OP * -ck_formline(o) -OP *o; -{ - return ck_fun(o); -} - -OP * -ck_ftst(o) -OP *o; +ck_ftst(OP *o) { dTHR; I32 type = o->op_type; @@ -3484,17 +4051,16 @@ OP *o; else { op_free(o); if (type == OP_FTTTY) - return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE, + return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE, SVt_PVIO)); else - return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); + return newUNOP(type, 0, newDEFSVOP()); } return o; } OP * -ck_fun(o) -OP *o; +ck_fun(OP *o) { dTHR; register OP *kid; @@ -3503,7 +4069,7 @@ OP *o; I32 numargs = 0; int type = o->op_type; register I32 oa = opargs[type] >> OASHIFT; - + if (o->op_flags & OPf_STACKED) { if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) oa &= ~OA_OPTIONAL; @@ -3521,7 +4087,7 @@ OP *o; kid = kid->op_sibling; } if (!kid && opargs[type] & OA_DEFGV) - *tokid = kid = newSVREF(newGVOP(OP_GV, 0, defgv)); + *tokid = kid = newDEFSVOP(); while (oa && kid) { numargs++; @@ -3545,8 +4111,8 @@ OP *o; OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); if (dowarn) - warn("Array @%s missing the @ in argument %d of %s()", - name, numargs, op_desc[type]); + warn("Array @%s missing the @ in argument %ld of %s()", + name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -3563,8 +4129,8 @@ OP *o; OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); if (dowarn) - warn("Hash %%%s missing the %% in argument %d of %s()", - name, numargs, op_desc[type]); + warn("Hash %%%s missing the %% in argument %ld of %s()", + name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -3619,7 +4185,7 @@ OP *o; } else if (opargs[type] & OA_DEFGV) { op_free(o); - return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); + return newUNOP(type, 0, newDEFSVOP()); } if (oa) { @@ -3632,10 +4198,34 @@ OP *o; } OP * -ck_glob(o) -OP *o; +ck_glob(OP *o) { - GV *gv = newGVgen("main"); + GV *gv; + + if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) + append_elem(OP_GLOB, o, newDEFSVOP()); + + if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); + + if (gv && GvIMPORTED_CV(gv)) { + static int glob_index; + + append_elem(OP_GLOB, o, + newSVOP(OP_CONST, 0, newSViv(glob_index++))); + o->op_type = OP_LIST; + o->op_ppaddr = ppaddr[OP_LIST]; + cLISTOPo->op_first->op_type = OP_PUSHMARK; + cLISTOPo->op_first->op_ppaddr = ppaddr[OP_PUSHMARK]; + o = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, o, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv))))); + o = newUNOP(OP_NULL, 0, ck_subr(o)); + o->op_targ = OP_GLOB; /* hint at what it used to be */ + return o; + } + gv = newGVgen("main"); gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); scalarkids(o); @@ -3643,8 +4233,7 @@ OP *o; } OP * -ck_grep(o) -OP *o; +ck_grep(OP *o) { LOGOP *gwop; OP *kid; @@ -3652,7 +4241,7 @@ OP *o; o->op_ppaddr = ppaddr[OP_GREPSTART]; Newz(1101, gwop, 1, LOGOP); - + if (o->op_flags & OPf_STACKED) { OP* k; o = ck_sort(o); @@ -3671,7 +4260,7 @@ OP *o; o = ck_fun(o); if (error_count) return o; - kid = cLISTOPo->op_first->op_sibling; + kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) croak("panic: ck_grep"); kid = kUNOP->op_first; @@ -3695,8 +4284,7 @@ OP *o; } OP * -ck_index(o) -OP *o; +ck_index(OP *o) { if (o->op_flags & OPf_KIDS) { OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ @@ -3707,33 +4295,31 @@ OP *o; } OP * -ck_lengthconst(o) -OP *o; +ck_lengthconst(OP *o) { /* XXX length optimization goes here */ return ck_fun(o); } OP * -ck_lfun(o) -OP *o; +ck_lfun(OP *o) { - return modkids(ck_fun(o), o->op_type); + OPCODE type = o->op_type; + return modkids(ck_fun(o), type); } OP * -ck_rfun(o) -OP *o; +ck_rfun(OP *o) { - return refkids(ck_fun(o), o->op_type); + OPCODE type = o->op_type; + return refkids(ck_fun(o), type); } OP * -ck_listiob(o) -OP *o; +ck_listiob(OP *o) { register OP *kid; - + kid = cLISTOPo->op_first; if (!kid) { o = force_list(o); @@ -3754,30 +4340,60 @@ OP *o; } if (!kid) - append_elem(o->op_type, o, newSVREF(newGVOP(OP_GV, 0, defgv)) ); + append_elem(o->op_type, o, newDEFSVOP()); + + o = listkids(o); + + o->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + o->op_private |= OPpLOCALE; +#endif - return listkids(o); + return o; } OP * -ck_match(o) -OP *o; +ck_fun_locale(OP *o) { - cPMOPo->op_pmflags |= PMf_RUNTIME; - cPMOPo->op_pmpermflags |= PMf_RUNTIME; + o = ck_fun(o); + + o->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + o->op_private |= OPpLOCALE; +#endif + return o; } OP * -ck_null(o) -OP *o; +ck_scmp(OP *o) { + o->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + o->op_private |= OPpLOCALE; +#endif + return o; } OP * -ck_repeat(o) -OP *o; +ck_match(OP *o) +{ + o->op_private |= OPpRUNTIME; + return o; +} + +OP * +ck_null(OP *o) +{ + return o; +} + +OP * +ck_repeat(OP *o) { if (cBINOPo->op_first->op_flags & OPf_PARENS) { o->op_private |= OPpREPEAT_DOLIST; @@ -3789,8 +4405,7 @@ OP *o; } OP * -ck_require(o) -OP *o; +ck_require(OP *o) { if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP *kid = (SVOP*)cUNOPo->op_first; @@ -3811,8 +4426,7 @@ OP *o; } OP * -ck_retarget(o) -OP *o; +ck_retarget(OP *o) { croak("NOT IMPL LINE %d",__LINE__); /* STUB */ @@ -3820,8 +4434,7 @@ OP *o; } OP * -ck_select(o) -OP *o; +ck_select(OP *o) { OP* kid; if (o->op_flags & OPf_KIDS) { @@ -3841,25 +4454,43 @@ OP *o; } OP * -ck_shift(o) -OP *o; +ck_shift(OP *o) { I32 type = o->op_type; if (!(o->op_flags & OPf_KIDS)) { + OP *argop; + op_free(o); - return newUNOP(type, 0, - scalar(newUNOP(OP_RV2AV, 0, +#ifdef USE_THREADS + if (!CvUNIQUE(compcv)) { + argop = newOP(OP_PADAV, OPf_REF); + argop->op_targ = 0; /* curpad[0] is @_ */ + } + else { + argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, - gv_fetchpv((subline ? "_" : "ARGV"), TRUE, SVt_PVAV) ))))); + gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); + } +#else + argop = newUNOP(OP_RV2AV, 0, + scalar(newGVOP(OP_GV, 0, !CvUNIQUE(compcv) ? + defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); +#endif /* USE_THREADS */ + return newUNOP(type, 0, scalar(argop)); } return scalar(modkids(ck_fun(o), type)); } OP * -ck_sort(o) -OP *o; +ck_sort(OP *o) { + o->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + o->op_private |= OPpLOCALE; +#endif + if (o->op_flags & OPf_STACKED) { OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; @@ -3896,16 +4527,15 @@ OP *o; o->op_flags |= OPf_SPECIAL; } } + return o; } OP * -ck_split(o) -OP *o; +ck_split(OP *o) { register OP *kid; - PMOP* pm; - + if (o->op_flags & OPf_STACKED) return no_fh_allowed(o); @@ -3929,18 +4559,13 @@ OP *o; cLISTOPo->op_first = kid; kid->op_sibling = sibl; } - pm = (PMOP*)kid; - if (pm->op_pmshort && !(pm->op_pmflags & PMf_ALL)) { - SvREFCNT_dec(pm->op_pmshort); /* can't use substring to optimize */ - pm->op_pmshort = 0; - } kid->op_type = OP_PUSHRE; kid->op_ppaddr = ppaddr[OP_PUSHRE]; scalar(kid); if (!kid->op_sibling) - append_elem(OP_SPLIT, o, newSVREF(newGVOP(OP_GV, 0, defgv)) ); + append_elem(OP_SPLIT, o, newDEFSVOP()); kid = kid->op_sibling; scalar(kid); @@ -3958,8 +4583,7 @@ OP *o; } OP * -ck_subr(o) -OP *o; +ck_subr(OP *o) { dTHR; OP *prev = ((cUNOPo->op_first->op_sibling) @@ -3968,6 +4592,7 @@ OP *o; OP *cvop; char *proto = 0; CV *cv = 0; + GV *namegv = 0; int optional = 0; I32 arg = 0; @@ -3978,19 +4603,21 @@ OP *o; null(cvop); /* disable rv2cv */ tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV) { - cv = GvCV(tmpop->op_sv); - if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) - proto = SvPV((SV*)cv,na); + cv = GvCVu(tmpop->op_sv); + if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) { + namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv); + proto = SvPV((SV*)cv, na); + } } } o->op_private |= (hints & HINT_STRICT_REFS); - if (perldb && curstash != debstash) + if (PERLDB_SUB && curstash != debstash) o->op_private |= OPpENTERSUB_DB; while (o2 != cvop) { if (proto) { switch (*proto) { case '\0': - return too_many_arguments(o, CvNAME(cv)); + return too_many_arguments(o, gv_ename(namegv)); case ';': optional = 1; proto++; @@ -4009,7 +4636,7 @@ OP *o; proto++; arg++; if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) - bad_type(arg, "block", CvNAME(cv), o2); + bad_type(arg, "block", gv_ename(namegv), o2); break; case '*': proto++; @@ -4018,10 +4645,11 @@ OP *o; goto wrapref; { OP* kid = o2; - o2 = newUNOP(OP_RV2GV, 0, kid); - o2->op_sibling = kid->op_sibling; + OP* sib = kid->op_sibling; kid->op_sibling = 0; - prev->op_sibling = o; + o2 = newUNOP(OP_RV2GV, 0, kid); + o2->op_sibling = sib; + prev->op_sibling = o2; } goto wrapref; case '\\': @@ -4030,39 +4658,43 @@ OP *o; switch (*proto++) { case '*': if (o2->op_type != OP_RV2GV) - bad_type(arg, "symbol", CvNAME(cv), o2); + bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': if (o2->op_type != OP_RV2CV) - bad_type(arg, "sub", CvNAME(cv), o2); + bad_type(arg, "sub", gv_ename(namegv), o2); goto wrapref; case '$': if (o2->op_type != OP_RV2SV && o2->op_type != OP_PADSV) - bad_type(arg, "scalar", CvNAME(cv), o2); + bad_type(arg, "scalar", gv_ename(namegv), o2); goto wrapref; case '@': if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV) - bad_type(arg, "array", CvNAME(cv), o2); + bad_type(arg, "array", gv_ename(namegv), o2); goto wrapref; case '%': if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV) - bad_type(arg, "hash", CvNAME(cv), o2); + bad_type(arg, "hash", gv_ename(namegv), o2); wrapref: { OP* kid = o2; - o2 = newUNOP(OP_REFGEN, 0, kid); - o2->op_sibling = kid->op_sibling; + OP* sib = kid->op_sibling; kid->op_sibling = 0; - prev->op_sibling = o; + o2 = newUNOP(OP_REFGEN, 0, kid); + o2->op_sibling = sib; + prev->op_sibling = o2; } break; default: goto oops; } break; + case ' ': + proto++; + continue; default: oops: croak("Malformed prototype for %s: %s", - CvNAME(cv),SvPV((SV*)cv,na)); + gv_ename(namegv), SvPV((SV*)cv, na)); } } else @@ -4071,22 +4703,21 @@ OP *o; prev = o2; o2 = o2->op_sibling; } - if (proto && !optional && *proto == '$') - return too_few_arguments(o, CvNAME(cv)); + if (proto && !optional && + (*proto && *proto != '@' && *proto != '%' && *proto != ';')) + return too_few_arguments(o, gv_ename(namegv)); return o; } OP * -ck_svconst(o) -OP *o; +ck_svconst(OP *o) { SvREADONLY_on(cSVOPo->op_sv); return o; } OP * -ck_trunc(o) -OP *o; +ck_trunc(OP *o) { if (o->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOPo->op_first; @@ -4103,15 +4734,14 @@ OP *o; /* A peephole optimizer. We visit the ops in the order they're to execute. */ void -peep(o) -register OP* o; +peep(register OP *o) { dTHR; register OP* oldop = 0; if (!o || o->op_seq) return; ENTER; - SAVESPTR(op); + SAVEOP(); SAVESPTR(curcop); for (; o; o = o->op_next) { if (o->op_seq) @@ -4134,19 +4764,19 @@ register OP* o; case OP_LC: case OP_LCFIRST: case OP_QUOTEMETA: - if (o->op_next->op_type == OP_STRINGIFY) + if (o->op_next && o->op_next->op_type == OP_STRINGIFY) null(o->op_next); o->op_seq = op_seqmax++; break; case OP_STUB: - if ((o->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) { + if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { o->op_seq = op_seqmax++; - break; /* Scalar stub must produce undef. List stub is noop */ + break; /* Scalar stub must produce undef. List stub is noop */ } goto nothin; case OP_NULL: if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - curcop = ((COP*)op); + curcop = ((COP*)o); goto nothin; case OP_SCALAR: case OP_LINESEQ: @@ -4161,7 +4791,7 @@ register OP* o; case OP_GV: if (o->op_next->op_type == OP_RV2SV) { - if (!(o->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) { + if (!(o->op_next->op_private & OPpDEREF)) { null(o->op_next); o->op_private |= o->op_next->op_private & OPpLVAL_INTRO; o->op_next = o->op_next->op_next; @@ -4176,7 +4806,7 @@ register OP* o; (op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & - (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)) && + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase) <= 255 && i >= 0) @@ -4190,17 +4820,37 @@ register OP* o; o->op_type = OP_AELEMFAST; o->op_ppaddr = ppaddr[OP_AELEMFAST]; o->op_private = (U8)i; - GvAVn((GV*)(((SVOP*)o)->op_sv)); + GvAVn(((GVOP*)o)->op_gv); } } o->op_seq = op_seqmax++; break; + case OP_PADAV: + if (o->op_next->op_type == OP_RV2AV + && (o->op_next->op_flags && OPf_REF)) + { + null(o->op_next); + o->op_next = o->op_next->op_next; + } + break; + + case OP_PADHV: + if (o->op_next->op_type == OP_RV2HV + && (o->op_next->op_flags && OPf_REF)) + { + null(o->op_next); + o->op_next = o->op_next->op_next; + } + break; + case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: case OP_OR: o->op_seq = op_seqmax++; + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); break; @@ -4237,6 +4887,47 @@ register OP* o; } } break; + + case OP_HELEM: { + UNOP *rop; + SV *lexname; + GV **fields; + SV **svp, **indsvp; + I32 ind; + char *key; + STRLEN keylen; + + if (o->op_private & (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO) + || ((BINOP*)o)->op_last->op_type != OP_CONST) + break; + rop = (UNOP*)((BINOP*)o)->op_first; + if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) + break; + lexname = *av_fetch(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; + svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv; + key = SvPV(*svp, keylen); + indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + if (!indsvp) { + croak("No such field \"%s\" in variable %s of type %s", + key, SvPV(lexname, na), HvNAME(SvSTASH(lexname))); + } + ind = SvIV(*indsvp); + if (ind < 1) + croak("Bad index while coercing array into hash"); + rop->op_type = OP_RV2AV; + rop->op_ppaddr = ppaddr[OP_RV2AV]; + o->op_type = OP_AELEM; + o->op_ppaddr = ppaddr[OP_AELEM]; + SvREFCNT_dec(*svp); + *svp = newSViv(ind); + break; + } + default: o->op_seq = op_seqmax++; break;