X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=75d7583b18f5566cf8f7f8e458d0e941ff02748b;hb=7b05b7e32c22894360c5332cd30232bdea49f5a8;hp=327ea8a567a7d3586357d6e35d40d71ef1bdf702;hpb=8ebc5c0145d2e3559bce3073437e6d027dcdffcc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 327ea8a..75d7583 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. @@ -26,8 +26,10 @@ * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,op) \ - ((op_mask && op_mask[type]) \ - ? (croak("%s trapped by operation mask", op_desc[type]), (OP*)op) \ + ((op_mask && op_mask[type]) \ + ? ( op_free((OP*)op), \ + croak("%s trapped by operation mask", op_desc[type]), \ + Nullop ) \ : (*check[type])((OP*)op)) #else #define CHECKOP(type,op) (*check[type])(op) @@ -37,6 +39,7 @@ static I32 list_assignment _((OP *op)); static OP *bad_type _((I32 n, char *t, char *name, OP *kid)); static OP *modkids _((OP *op, I32 type)); static OP *no_fh_allowed _((OP *op)); +static bool scalar_mod_type _((OP *op, I32 type)); static OP *scalarboolean _((OP *op)); static OP *too_few_arguments _((OP *op, char* name)); static OP *too_many_arguments _((OP *op, char* name)); @@ -45,11 +48,11 @@ static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)); static char* -CvNAME(cv) -CV* cv; +gv_ename(gv) +GV* gv; { SV* tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, CvGV(cv), Nullch); + gv_efullname3(tmpsv, gv, Nullch); return SvPV(tmpsv,na); } @@ -57,9 +60,8 @@ static OP * no_fh_allowed(op) OP *op; { - sprintf(tokenbuf,"Missing comma after first argument to %s function", - op_desc[op->op_type]); - yyerror(tokenbuf); + yyerror(form("Missing comma after first argument to %s function", + op_desc[op->op_type])); return op; } @@ -68,8 +70,7 @@ too_few_arguments(op, name) OP* op; char* name; { - sprintf(tokenbuf,"Not enough arguments for %s", name); - yyerror(tokenbuf); + yyerror(form("Not enough arguments for %s", name)); return op; } @@ -78,8 +79,7 @@ too_many_arguments(op, name) OP *op; char* name; { - sprintf(tokenbuf,"Too many arguments for %s", name); - yyerror(tokenbuf); + yyerror(form("Too many arguments for %s", name)); return op; } @@ -90,9 +90,8 @@ 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])); return op; } @@ -102,8 +101,7 @@ OP *op; { int type = op->op_type; if (type != OP_AELEM && type != OP_HELEM) { - sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]); - yyerror(tokenbuf); + yyerror(form("Can't use subscript on %s", op_desc[type])); if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) warn("(Did you mean $ or @ instead of %c?)\n", type == OP_ENTERSUB ? '&' : '%'); @@ -120,8 +118,11 @@ char *name; SV *sv; if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) { - if (!isPRINT(name[1])) - sprintf(name+1, "^%c", toCTRL(name[1])); /* XXX 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 (AvFILL(comppad_name) >= 0) { @@ -175,9 +176,10 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) 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; @@ -195,29 +197,51 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) depth = CvDEPTH(cv); if (!depth) { - if (newoff && !CvUNIQUE(cv)) - return 0; /* don't clone inactive sub's stack frame */ + 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; - /* "It's closures all the way down." */ - CvCLONE_on(compcv); - if (cv != startcv) { - CV *bcv; - for (bcv = startcv; - bcv && bcv != cv && !CvCLONE(bcv); - bcv = CvOUTSIDE(bcv)) - CvCLONE_on(bcv); + 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)); @@ -242,10 +266,14 @@ pad_findlex(char *name, PADOFFSET newoff, U32 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) @@ -268,6 +296,7 @@ pad_findmy(name) char *name; { I32 off; + I32 pendoff = 0; SV *sv; SV **svp = AvARRAY(comppad_name); U32 seq = cop_seqmax; @@ -276,18 +305,25 @@ char *name; for (off = AvFILL(comppad_name); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && - seq <= SvIVX(sv) && - seq > I_32(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; + } return 0; } @@ -364,7 +400,7 @@ pad_sv(PADOFFSET po) { if (!po) croak("panic: pad_sv po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %lu\n", (unsigned long)po)); return curpad[po]; /* eventually we'll turn this into a macro */ } @@ -382,8 +418,8 @@ pad_free(PADOFFSET po) croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po)); - if (curpad[po] && curpad[po] != &sv_undef) + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %lu\n", (unsigned long)po)); + if (curpad[po] && !SvIMMORTAL(curpad[po])) SvPADTMP_off(curpad[po]); if ((I32)po < padix) padix = po - 1; @@ -401,7 +437,7 @@ pad_swipe(PADOFFSET po) croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %lu\n", (unsigned long)po)); SvPADTMP_off(curpad[po]); curpad[po] = NEWSV(1107,0); SvPADTMP_on(curpad[po]); @@ -419,7 +455,7 @@ pad_reset() DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n")); 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; @@ -570,12 +606,11 @@ OP *op; OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN - || error_count) + if (!op || (op->op_flags & OPf_WANT) || error_count + || op->op_type == OP_RETURN) return op; - op->op_flags &= ~OPf_LIST; - op->op_flags |= OPf_KNOW; + op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; switch (op->op_type) { case OP_REPEAT: @@ -606,8 +641,16 @@ OP *op; break; case OP_LEAVE: case OP_LEAVETRY: - scalar(cLISTOP->op_first); - /* FALL THROUGH */ + kid = cLISTOP->op_first; + scalar(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + scalar(kid); + } + curcop = &compiling; + break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: @@ -631,12 +674,12 @@ OP *op; char* useless = 0; SV* sv; - if (!op || error_count) - return op; - if (op->op_flags & OPf_LIST) + /* assumes no premature commitment */ + if (!op || (op->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count + || op->op_type == OP_RETURN) return op; - op->op_flags |= OPf_KNOW; + op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (op->op_type) { default: @@ -670,8 +713,6 @@ OP *op; case OP_AELEM: case OP_AELEMFAST: case OP_ASLICE: - case OP_VALUES: - case OP_KEYS: case OP_HELEM: case OP_HSLICE: case OP_UNPACK: @@ -768,35 +809,38 @@ OP *op; for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_NULL: if (op->op_targ == OP_NEXTSTATE || op->op_targ == OP_DBSTATE) curcop = ((COP*)op); /* for warning below */ if (op->op_flags & OPf_STACKED) break; + /* FALL THROUGH */ case OP_ENTERTRY: case OP_ENTER: case OP_SCALAR: if (!(op->op_flags & OPf_KIDS)) break; + /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: - op->op_private |= OPpLEAVE_VOID; case OP_LINESEQ: case OP_LIST: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_REQUIRE: + /* since all requires must return a value, they're never void */ + op->op_flags &= ~OPf_WANT; + return scalar(op); case OP_SPLIT: if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) deprecate("implicit split to @_"); } break; - case OP_DELETE: - op->op_private |= OPpLEAVE_VOID; - break; } if (useless && dowarn) warn("Useless use of %s in void context", useless); @@ -822,11 +866,11 @@ OP *op; OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN - || error_count) + if (!op || (op->op_flags & OPf_WANT) || error_count + || op->op_type == OP_RETURN) return op; - op->op_flags |= (OPf_KNOW | OPf_LIST); + op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (op->op_type) { case OP_FLOP: @@ -854,8 +898,16 @@ OP *op; break; case OP_LEAVE: case OP_LEAVETRY: - list(cLISTOP->op_first); - /* FALL THROUGH */ + kid = cLISTOP->op_first; + list(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + list(kid); + } + curcop = &compiling; + break; case OP_SCOPE: case OP_LINESEQ: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { @@ -925,6 +977,8 @@ I32 type; return op; switch (op->op_type) { + case OP_UNDEF: + return op; case OP_CONST: if (!(op->op_private & (OPpCONST_ARYBASE))) goto nomod; @@ -960,10 +1014,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[op->op_type], - type ? op_desc[type] : "local"); - yyerror(tokenbuf); + yyerror(form("Can't modify %s in %s", + op_desc[op->op_type], + type ? op_desc[type] : "local")); return op; case OP_PREINC: @@ -1004,6 +1057,8 @@ I32 type; } /* FALL THROUGH */ case OP_RV2GV: + if (scalar_mod_type(op, type)) + goto nomod; ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ case OP_AASSIGN: @@ -1020,7 +1075,6 @@ I32 type; croak("Can't localize a reference"); ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ - case OP_UNDEF: case OP_GV: case OP_AV2ARYLEN: case OP_SASSIGN: @@ -1033,6 +1087,8 @@ I32 type; modcount = 10000; if (type == OP_REFGEN && op->op_flags & OPf_PARENS) return op; /* Treat \(@foo) like ordinary list. */ + if (scalar_mod_type(op, type)) + goto nomod; /* FALL THROUGH */ case OP_PADSV: modcount++; @@ -1061,6 +1117,9 @@ I32 type; case OP_AELEM: case OP_HELEM: ref(cBINOP->op_first, op->op_type); + if (type == OP_ENTERSUB && + !(op->op_private & (OPpLVAL_INTRO | OPpDEREF))) + op->op_private |= OPpLVAL_DEFER; modcount++; break; @@ -1097,6 +1156,52 @@ I32 type; return op; } +static bool +scalar_mod_type(op, type) +OP *op; +I32 type; +{ + switch (type) { + case OP_SASSIGN: + if (op->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(op, type) OP *op; @@ -1213,8 +1318,7 @@ OP *op; type != OP_PADHV && type != OP_PUSHMARK) { - sprintf(tokenbuf, "Can't declare %s in my", op_desc[op->op_type]); - yyerror(tokenbuf); + yyerror(form("Can't declare %s in my", op_desc[op->op_type])); return op; } op->op_flags |= OPf_MOD; @@ -1239,6 +1343,20 @@ OP *right; { OP *op; + 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) { @@ -1347,17 +1465,26 @@ OP *op; peep(eval_start); } else { - if (!op) { - main_start = 0; + if (!op) return; - } main_root = scope(sawparens(scalarvoid(op))); 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) { + 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); + } + } } } @@ -1520,7 +1647,7 @@ OP* op; if (!op || op->op_type != OP_LIST) op = newLISTOP(OP_LIST, 0, op, Nullop); else - op->op_flags &= ~(OPf_KNOW|OPf_LIST); + op->op_flags &= ~OPf_WANT; if (!(opargs[type] & OA_MARK)) null(cLISTOP->op_first); @@ -2287,7 +2414,7 @@ OP *right; tmpop->op_sibling = Nullop; /* don't free split */ right->op_next = tmpop->op_next; /* fix starting loc */ op_free(op); /* 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; } @@ -2345,6 +2472,9 @@ OP *op; } 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) { @@ -2360,7 +2490,7 @@ OP *op; cop->cop_line = copline; copline = NOLINE; } - cop->cop_filegv = GvREFCNT_inc(curcop->cop_filegv); + cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv); cop->cop_stash = curstash; if (perldb && curstash != debstash) { @@ -2459,16 +2589,20 @@ OP* other; break; case OP_SASSIGN: - if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB) + 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 construct can be \"0\"; test with defined()", - op_desc[warnop]); - curcop->cop_line = oldline; + 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; } } @@ -2616,8 +2750,10 @@ 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 = newUNOP(OP_DEFINED, 0, + newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); + } } listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); @@ -2794,6 +2930,8 @@ 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)); @@ -2804,8 +2942,16 @@ CV *cv; I32 i = AvFILL(CvPADLIST(cv)); while (i >= 0) { SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); - if (svp) - SvREFCNT_dec(*svp); + 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)); } @@ -2820,10 +2966,10 @@ CV* cv; { CV *outside = CvOUTSIDE(cv); AV* padlist = CvPADLIST(cv); - AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE); - AV* pad = (AV*)*av_fetch(padlist, 1, FALSE); - SV** pname = AvARRAY(pad_name); - SV** ppad = AvARRAY(pad); + AV* pad_name; + AV* pad; + SV** pname; + SV** ppad; I32 ix; PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n", @@ -2831,18 +2977,28 @@ CV* cv; (CvANON(cv) ? "ANON" : (cv == main_cv) ? "MAIN" : CvUNIQUE(outside) ? "UNIQUE" - : CvGV(cv) ? GvNAME(CvGV(cv)) : "?mystery?"), + : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), outside, (!outside ? "null" : CvANON(outside) ? "ANON" : (outside == main_cv) ? "MAIN" : CvUNIQUE(outside) ? "UNIQUE" - : CvGV(outside) ? GvNAME(CvGV(outside)) : "?mystery?")); + : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + + if (!padlist) + return; - for (ix = 1; ix <= AvFILL(pad); ix++) { + 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 <= AvFILL(pad_name); ix++) { if (SvPOK(pname[ix])) - PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (\"%s\" %ld-%ld)\n", - ix, ppad[ix], SvPVX(pname[ix]), + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (%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])); } @@ -2861,6 +3017,8 @@ CV* outside; AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); SV** pname = AvARRAY(protopad_name); SV** ppad = AvARRAY(protopad); + I32 fname = AvFILL(protopad_name); + I32 fpad = AvFILL(protopad); AV* comppadlist; CV* cv; @@ -2869,27 +3027,35 @@ CV* outside; 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); CvFILEGV(cv) = CvFILEGV(proto); - CvGV(cv) = GvREFCNT_inc(CvGV(proto)); + CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); CvSTASH(cv) = CvSTASH(proto); CvROOT(cv) = CvROOT(proto); CvSTART(cv) = CvSTART(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_fill(comppad, AvFILL(protopad)); @@ -2900,12 +3066,12 @@ CV* outside; av_store(comppad, 0, (SV*)av); AvFLAGS(av) = AVf_REIFY; - for (ix = AvFILL(protopad); ix > 0; ix--) { - SV* sv; - if (pname[ix] != &sv_undef) { - char *name = SvPVX(pname[ix]); /* XXX */ - if (SvFLAGS(pname[ix]) & SVf_FAKE) { /* lexical from outside? */ - I32 off = pad_findlex(name, ix, SvIVX(pname[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]); @@ -2913,6 +3079,7 @@ CV* outside; croak("panic: cv_clone: %s", name); } else { /* our own lexical */ + SV* sv; if (*name == '&') { /* anon code -- we'll come back for it */ sv = SvREFCNT_inc(ppad[ix]); @@ -2929,7 +3096,7 @@ CV* outside; } } else { - sv = NEWSV(0,0); + SV* sv = NEWSV(0,0); SvPADTMP_on(sv); curpad[ix] = sv; } @@ -2937,10 +3104,12 @@ CV* outside; /* Now that vars are all in place, clone nested closures. */ - for (ix = AvFILL(protopad); ix > 0; ix--) { - if (pname[ix] != &sv_undef - && !(SvFLAGS(pname[ix]) & SVf_FAKE) - && *SvPVX(pname[ix]) == '&' + 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); @@ -2971,27 +3140,65 @@ CV* proto; return cv_clone2(proto, CvOUTSIDE(proto)); } +void +cv_ckproto(cv, gv, p) +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 *cv; +CV* cv; { OP *o; - SV *sv = Nullsv; + SV *sv; - if(cv && SvPOK(cv) && !SvCUR(cv)) { - 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 (type != OP_CONST || sv) - return Nullsv; + 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 = ((SVOP*)o)->op_sv; + else if (type == OP_PADSV) { + AV* pad = (AV*)(AvARRAY(CvPADLIST(cv))[1]); + sv = pad ? AvARRAY(pad)[o->op_targ] : Nullsv; + if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) + return Nullsv; } + else + return Nullsv; } + if (sv) + SvREADONLY_on(sv); return sv; } @@ -3002,49 +3209,47 @@ OP *op; OP *proto; OP *block; { + char *name = op ? SvPVx(cSVOP->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 = op ? SvPVx(cSVOP->op_sv, na) : "__ANON__"; - GV* gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV); - AV* av; - char *s; I32 ix; - if (op) { + if (op) SAVEFREEOP(op); - sub_generation++; - } - if (cv = GvCV(gv)) { - if (GvCVGEN(gv)) { - /* just a cached method */ - SvREFCNT_dec(cv); - cv = 0; - } - else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { - SV* const_sv = cv_const_sv(cv); - - char *p = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; - - if((!proto != !SvPOK(cv)) || (p && strNE(SvPV((SV*)cv,na), p))) { - warn("Prototype mismatch: (%s) vs (%s)", - SvPOK(cv) ? SvPV((SV*)cv,na) : "none", - p ? p : "none"); + 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; } - - if ((const_sv || dowarn) && strNE(name, "BEGIN")) {/* already defined (or promised)? */ + /* ahem, death to those who redefine active sort subs */ + if (curstack == sortstack && sortcop == CvSTART(cv)) + croak("Can't redefine active sort subroutine %s", name); + const_sv = cv_const_sv(cv); + if (const_sv || dowarn) { line_t oldline = curcop->cop_line; - curcop->cop_line = copline; warn(const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined",name); + : "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(cv)&~CVf_CLONE) | (CvFLAGS(compcv)&CVf_CLONE); + CvFLAGS(cv) = CvFLAGS(compcv); CvOUTSIDE(cv) = CvOUTSIDE(compcv); CvOUTSIDE(compcv) = 0; CvPADLIST(cv) = CvPADLIST(compcv); @@ -3055,114 +3260,150 @@ 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) = GvREFCNT_inc(gv); CvSTASH(cv) = curstash; - if (proto) { - char *p = SvPVx(((SVOP*)proto)->op_sv, na); - 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(GvSV(errgv), not_safe); + croak("%s", SvPVx(GvSV(errgv), na)); + } + } + } } if (!block) { - CvROOT(cv) = 0; copline = NOLINE; LEAVE_SCOPE(floor); return cv; } - /* XXX: Named functions at file scope cannot be closures */ - if (op && CvUNIQUE(CvOUTSIDE(cv))) - CvCLONE_off(cv); + if (AvFILL(comppad_name) < AvFILL(comppad)) + av_store(comppad_name, AvFILL(comppad), Nullsv); - av = newAV(); /* Will be @_ */ - av_extend(av, 0); - av_store(comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; + if (CvCLONE(cv)) { + SV **namep = AvARRAY(comppad_name); + for (ix = AvFILL(comppad); ix > 0; ix--) { + SV *namesv; - for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) - SvPADTMP_on(curpad[ix]); + 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 = AvFILL(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) { - 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; - calllist(beginav); + if (name) { + char *s; + + if (perldb && curstash != debstash) { + SV *sv = NEWSV(0,0); + SV *tmpstr = sv_newmortal(); + static GV *db_postponed; + 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); + if (!db_postponed) { + db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); + } + 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); + } + } - 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; - } + 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); - if (perldb && curstash != debstash) { - SV *sv; - SV *tmpstr = sv_newmortal(); - static GV *db_postponed; - CV *cv; - HV *hv; - - 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_efullname3(tmpstr, gv, Nullch); - hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); - if (!db_postponed) { - db_postponed = gv_fetchpv("DB::postponed", TRUE, SVt_PVHV); + curcop = &compiling; + LEAVE; } - 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); + else if (strEQ(s, "END") && !error_count) { + if (!endav) + endav = newAV(); + av_unshift(endav, 1); + av_store(endav, 0, (SV *)cv); + GvCV(gv) = 0; } } - if (!op) { - GvCV(gv) = 0; /* Will remember in SVOP instead. */ - CvANON_on(cv); - } + done: copline = NOLINE; LEAVE_SCOPE(floor); return cv; @@ -3189,19 +3430,19 @@ char *name; void (*subaddr) _((CV*)); char *filename; { + 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 (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) { line_t oldline = curcop->cop_line; - curcop->cop_line = copline; warn("Subroutine %s redefined",name); curcop->cop_line = oldline; @@ -3210,40 +3451,45 @@ 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) = GvREFCNT_inc(gv); - GvCVGEN(gv) = 0; + CvGV(cv) = (GV*)SvREFCNT_inc(gv); 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 - 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; } @@ -3276,11 +3522,11 @@ OP *block; } cv = compcv; GvFORM(gv) = cv; - CvGV(cv) = GvREFCNT_inc(gv); + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) + if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix])) SvPADTMP_on(curpad[ix]); } @@ -3288,7 +3534,6 @@ OP *block; CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - FmLINES(cv) = 0; op_free(op); copline = NOLINE; LEAVE_SCOPE(floor); @@ -3622,9 +3867,31 @@ register OP *op; op->op_private |= (hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { - int iscv = (op->op_type==OP_RV2CV)*2; - GV *gv = 0; + 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 (op->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); + } kid->op_type = OP_GV; + iscv = (op->op_type == OP_RV2CV) * 2; for (gv = 0; !gv; iscv++) { /* * This is a little tricky. We only want to add the symbol if we @@ -3634,7 +3901,7 @@ register OP *op; * 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), + gv = gv_fetchpv(name, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV @@ -3734,8 +4001,8 @@ OP *op; 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; @@ -3752,8 +4019,8 @@ OP *op; 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; @@ -3827,14 +4094,22 @@ OP *op; GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV); if (gv && GvIMPORTED_CV(gv)) { + static int glob_index; + + append_elem(OP_GLOB, op, + newSVOP(OP_CONST, 0, newSViv(glob_index++))); op->op_type = OP_LIST; op->op_ppaddr = ppaddr[OP_LIST]; + ((LISTOP*)op)->op_first->op_type = OP_PUSHMARK; + ((LISTOP*)op)->op_first->op_ppaddr = ppaddr[OP_PUSHMARK]; op = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, op, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); return ck_subr(op); } + if ((op->op_flags & OPf_KIDS) && !cLISTOP->op_first->op_sibling) + append_elem(OP_GLOB, op, newSVREF(newGVOP(OP_GV, 0, defgv))); gv = newGVgen("main"); gv_IOadd(gv); append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv)); @@ -4213,6 +4488,7 @@ OP *op; OP *cvop; char *proto = 0; CV *cv = 0; + GV *namegv = 0; int optional = 0; I32 arg = 0; @@ -4224,8 +4500,10 @@ OP *op; tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV) { cv = GvCVu(tmpop->op_sv); - if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) - proto = SvPV((SV*)cv,na); + if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) { + namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv); + proto = SvPV((SV*)cv, na); + } } } op->op_private |= (hints & HINT_STRICT_REFS); @@ -4235,7 +4513,7 @@ OP *op; if (proto) { switch (*proto) { case '\0': - return too_many_arguments(op, CvNAME(cv)); + return too_many_arguments(op, gv_ename(namegv)); case ';': optional = 1; proto++; @@ -4254,7 +4532,7 @@ OP *op; proto++; arg++; if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF) - bad_type(arg, "block", CvNAME(cv), o); + bad_type(arg, "block", gv_ename(namegv), o); break; case '*': proto++; @@ -4275,23 +4553,23 @@ OP *op; switch (*proto++) { case '*': if (o->op_type != OP_RV2GV) - bad_type(arg, "symbol", CvNAME(cv), o); + bad_type(arg, "symbol", gv_ename(namegv), o); goto wrapref; case '&': if (o->op_type != OP_RV2CV) - bad_type(arg, "sub", CvNAME(cv), o); + bad_type(arg, "sub", gv_ename(namegv), o); goto wrapref; case '$': if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV) - bad_type(arg, "scalar", CvNAME(cv), o); + bad_type(arg, "scalar", gv_ename(namegv), o); goto wrapref; case '@': if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV) - bad_type(arg, "array", CvNAME(cv), o); + bad_type(arg, "array", gv_ename(namegv), o); goto wrapref; case '%': if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV) - bad_type(arg, "hash", CvNAME(cv), o); + bad_type(arg, "hash", gv_ename(namegv), o); wrapref: { OP* kid = o; @@ -4310,7 +4588,7 @@ OP *op; default: oops: croak("Malformed prototype for %s: %s", - CvNAME(cv),SvPV((SV*)cv,na)); + gv_ename(namegv), SvPV((SV*)cv, na)); } } else @@ -4320,7 +4598,7 @@ OP *op; o = o->op_sibling; } if (proto && !optional && *proto == '$') - return too_few_arguments(op, CvNAME(cv)); + return too_few_arguments(op, gv_ename(namegv)); return op; } @@ -4386,9 +4664,9 @@ register OP* o; 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: @@ -4422,7 +4700,8 @@ register OP* o; if (pop->op_type == OP_CONST && (op = pop->op_next) && pop->op_next->op_type == OP_AELEM && - !(pop->op_next->op_private & (OPpDEREF|OPpLVAL_INTRO)) && + !(pop->op_next->op_private & + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase) <= 255 && i >= 0)