X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=5b1156724ca0cb613638105565c89dc15b8a7956;hb=b178108dc470b74242476037c9116c4f327f151d;hp=b19abeaf982625afc0c9e81f87e59fbe3f7b8b31;hpb=1cc8b4c566f7901a54e4b576f09608beb4c81f86;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index b19abea..5b11567 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, 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. @@ -15,6 +15,7 @@ * either way, as the saying is, if you follow me." --the Gaffer */ + #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" @@ -22,28 +23,75 @@ #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) -/* #define PL_OP_SLAB_ALLOC */ +#if defined(PL_OP_SLAB_ALLOC) -#ifdef PL_OP_SLAB_ALLOC -#define SLAB_SIZE 8192 -static char *PL_OpPtr = NULL; -static int PL_OpSpace = 0; -#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \ - var = (type *)(PL_OpPtr -= c*sizeof(type)); \ - else \ - var = (type *) Slab_Alloc(m,c*sizeof(type)); \ - } while (0) +#ifndef PERL_SLAB_SIZE +#define PERL_SLAB_SIZE 2048 +#endif + +#define NewOp(m,var,c,type) \ + STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END + +#define FreeOp(p) Slab_Free(p) STATIC void * S_Slab_Alloc(pTHX_ int m, size_t sz) { - Newz(m,PL_OpPtr,SLAB_SIZE,char); - PL_OpSpace = SLAB_SIZE - sz; - return PL_OpPtr += PL_OpSpace; + /* + * To make incrementing use count easy PL_OpSlab is an I32 * + * To make inserting the link to slab PL_OpPtr is I32 ** + * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments + * Add an overhead for pointer to slab and round up as a number of pointers + */ + sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); + if ((PL_OpSpace -= sz) < 0) { + PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); + if (!PL_OpPtr) { + return NULL; + } + Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); + /* We reserve the 0'th I32 sized chunk as a use count */ + PL_OpSlab = (I32 *) PL_OpPtr; + /* Reduce size by the use count word, and by the size we need. + * Latter is to mimic the '-=' in the if() above + */ + PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; + /* Allocation pointer starts at the top. + Theory: because we build leaves before trunk allocating at end + means that at run time access is cache friendly upward + */ + PL_OpPtr += PERL_SLAB_SIZE; + } + assert( PL_OpSpace >= 0 ); + /* Move the allocation pointer down */ + PL_OpPtr -= sz; + assert( PL_OpPtr > (I32 **) PL_OpSlab ); + *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ + (*PL_OpSlab)++; /* Increment use count of slab */ + assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); + assert( *PL_OpSlab > 0 ); + return (void *)(PL_OpPtr + 1); +} + +STATIC void +S_Slab_Free(pTHX_ void *op) +{ + I32 **ptr = (I32 **) op; + I32 *slab = ptr[-1]; + assert( ptr-1 > (I32 **) slab ); + assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); + assert( *slab > 0 ); + if (--(*slab) == 0) { + PerlMemShared_free(slab); + if (slab == PL_OpSlab) { + PL_OpSpace = 0; + } + } } #else #define NewOp(m, var, c, type) Newz(m, var, c, type) +#define FreeOp(p) Safefree(p) #endif /* * In the following definition, the ", Nullop" is just to make the compiler @@ -734,14 +782,7 @@ Perl_op_free(pTHX_ OP *o) cop_free((COP*)o); op_clear(o); - -#ifdef PL_OP_SLAB_ALLOC - if ((char *) o == PL_OpPtr) - { - } -#else - Safefree(o); -#endif + FreeOp(o); } void @@ -813,10 +854,10 @@ Perl_op_clear(pTHX_ OP *o) goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS - if ((PADOFFSET)cPMOPo->op_pmreplroot) { + if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { if (PL_curpad) { - GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot]; - pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot); + GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)]; + pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)); /* No GvIN_PAD_off(gv) here, because other references may still * exist on the pad */ SvREFCNT_dec(gv); @@ -846,11 +887,7 @@ clear_pmop: pmop = pmop->op_pmnext; } } -#ifdef USE_ITHREADS - Safefree(PmopSTASHPV(cPMOPo)); -#else - /* NOTE: PMOP.op_pmstash is not refcounted */ -#endif + PmopSTASH_free(cPMOPo); } cPMOPo->op_pmreplroot = Nullop; /* we use the "SAFE" version of the PM_ macros here @@ -867,7 +904,7 @@ clear_pmop: SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); } -#endif +#endif break; } @@ -881,18 +918,22 @@ clear_pmop: STATIC void S_cop_free(pTHX_ COP* cop) { - Safefree(cop->cop_label); -#ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ -#else - /* NOTE: COP.cop_stash is not refcounted */ - SvREFCNT_dec(CopFILEGV(cop)); -#endif + Safefree(cop->cop_label); /* FIXME: treaddead ??? */ + CopFILE_free(cop); + CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); - if (! specialCopIO(cop->cop_io)) + if (! specialCopIO(cop->cop_io)) { +#ifdef USE_ITHREADS + STRLEN len; + char *s = SvPV(cop->cop_io,len); +#if 0 + Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ +#endif +#else SvREFCNT_dec(cop->cop_io); +#endif + } } void @@ -988,7 +1029,7 @@ Perl_scalar(pTHX_ OP *o) case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) - deprecate("implicit split to @_"); + deprecate_old("implicit split to @_"); } /* FALL THROUGH */ case OP_MATCH: @@ -1024,6 +1065,9 @@ Perl_scalar(pTHX_ OP *o) } WITH_THR(PL_curcop = &PL_compiling); break; + case OP_SORT: + if (ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context"); } return o; } @@ -1232,7 +1276,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) - deprecate("implicit split to @_"); + deprecate_old("implicit split to @_"); } break; } @@ -1413,6 +1457,8 @@ Perl_mod(pTHX_ OP *o, I32 type) op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } + else if (o->op_private & OPpENTERSUB_NOMOD) + return o; else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; PL_modcount = RETURN_UNLIMITED_NUMBER; @@ -1431,8 +1477,8 @@ Perl_mod(pTHX_ OP *o, I32 type) if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " - "args: type/targ %ld:%ld", - (long)kid->op_type,kid->op_targ); + "args: type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; skip_kids: while (kid->op_sibling) @@ -1444,11 +1490,6 @@ Perl_mod(pTHX_ OP *o, I32 type) { UNOP *newop; - if (kid->op_sibling || kid->op_next != kid) { - yyerror("panic: unexpected optree near method call"); - break; - } - NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; @@ -1458,25 +1499,25 @@ Perl_mod(pTHX_ OP *o, I32 type) newop->op_private |= OPpLVAL_INTRO; break; } - + if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " - "entry via type/targ %ld:%ld", - (long)kid->op_type,kid->op_targ); + "entry via type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); kid->op_private |= OPpLVAL_INTRO; break; /* Postpone until runtime */ } - - okid = kid; + + okid = kid; kid = kUNOP->op_first; if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) kid = kUNOP->op_first; - if (kid->op_type == OP_NULL) + if (kid->op_type == OP_NULL) Perl_croak(aTHX_ "Unexpected constant lvalue entersub " - "entry via type/targ %ld:%ld", - (long)kid->op_type,kid->op_targ); + "entry via type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { /* Restore RV2CV to check lvalueness */ restore_2cv: @@ -1492,7 +1533,7 @@ Perl_mod(pTHX_ OP *o, I32 type) okid->op_private |= OPpLVAL_INTRO; break; } - + cv = GvCV(kGVOP_gv); if (!cv) goto restore_2cv; @@ -1539,7 +1580,7 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; PL_modcount++; break; - + case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); @@ -1610,7 +1651,7 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PUSHMARK: break; - + case OP_KEYS: if (type != OP_SASSIGN) goto nomod; @@ -1670,6 +1711,14 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; break; /* mod()ing was handled by ck_return() */ } + + /* [20011101.069] File test operators interpret OPf_REF to mean that + their argument is a filehandle; thus \stat(".") should not set + it. AMS 20011102 */ + if (type == OP_REFGEN && + PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) + return o; + if (type != OP_LEAVESUBLV) o->op_flags |= OPf_MOD; @@ -1880,7 +1929,7 @@ S_dup_attrlist(pTHX_ OP *o) } STATIC void -S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) +S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) { SV *stashsv; @@ -1893,19 +1942,99 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) stashsv = &PL_sv_no; #define ATTRSMODULE "attributes" +#define ATTRSMODULE_PM "attributes.pm" - Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), - Nullsv, - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, - newRV(target)), - dup_attrlist(attrs)))); + if (for_my) { + SV **svp; + /* Don't force the C if we don't need it. */ + svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, + sizeof(ATTRSMODULE_PM)-1, 0); + if (svp && *svp != &PL_sv_undef) + ; /* already in %INC */ + else + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv); + } + else { + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); + } LEAVE; } +STATIC void +S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) +{ + OP *pack, *imop, *arg; + SV *meth, *stashsv; + + if (!attrs) + return; + + assert(target->op_type == OP_PADSV || + target->op_type == OP_PADHV || + target->op_type == OP_PADAV); + + /* Ensure that attributes.pm is loaded. */ + apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE); + + /* Need package name for method call. */ + pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); + + /* Build up the real arg-list. */ + if (stash) + stashsv = newSVpv(HvNAME(stash), 0); + else + stashsv = &PL_sv_no; + arg = newOP(OP_PADSV, 0); + arg->op_targ = target->op_targ; + arg = prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newUNOP(OP_REFGEN, 0, + mod(arg, OP_REFGEN)), + dup_attrlist(attrs))); + + /* Fake up a method call to import */ + meth = newSVpvn("import", 6); + (void)SvUPGRADE(meth, SVt_PVIV); + (void)SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); + imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newSVOP(OP_METHOD_NAMED, 0, meth))); + imop->op_private |= OPpENTERSUB_NOMOD; + + /* Combine the ops. */ + *imopsp = append_elem(OP_LIST, *imopsp, imop); +} + +/* +=notfor apidoc apply_attrs_string + +Attempts to apply a list of attributes specified by the C and +C arguments to the subroutine identified by the C argument which +is expected to be associated with the package identified by the C +argument (see L). It gets this wrong, though, in that it +does not correctly identify the boundaries of the individual attribute +specifications within C. This is not really intended for the +public API, but has to be listed here for systems such as AIX which +need an explicit export list for symbols. (It's called from XS code +in support of the C keyword from F.) Patches to fix it +to respect attribute syntax properly would be welcome. + +=cut +*/ + void Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, char *attrstr, STRLEN len) @@ -1938,7 +2067,7 @@ Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, } STATIC OP * -S_my_kid(pTHX_ OP *o, OP *attrs) +S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { OP *kid; I32 type; @@ -1949,12 +2078,15 @@ S_my_kid(pTHX_ OP *o, OP *attrs) type = o->op_type; if (type == OP_LIST) { for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - my_kid(kid, attrs); + my_kid(kid, attrs, imopsp); } else if (type == OP_UNDEF) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ + if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ + yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o))); + } if (attrs) { GV *gv = cGVOPx_gv(cUNOPo->op_first); PL_in_my = FALSE; @@ -1963,11 +2095,12 @@ S_my_kid(pTHX_ OP *o, OP *attrs) (type == OP_RV2SV ? GvSV(gv) : type == OP_RV2AV ? (SV*)GvAV(gv) : type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), - attrs); + attrs, FALSE); } o->op_private |= OPpOUR_INTRO; return o; - } else if (type != OP_PADSV && + } + else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) @@ -1979,7 +2112,6 @@ S_my_kid(pTHX_ OP *o, OP *attrs) } else if (attrs && type != OP_PUSHMARK) { HV *stash; - SV *padsv; SV **namesvp; PL_in_my = FALSE; @@ -1991,8 +2123,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs) stash = SvSTASH(*namesvp); else stash = PL_curstash; - padsv = PAD_SV(o->op_targ); - apply_attrs(stash, padsv, attrs); + apply_attrs_my(stash, o, attrs, imopsp); } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; @@ -2002,11 +2133,24 @@ S_my_kid(pTHX_ OP *o, OP *attrs) OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { + OP *rops = Nullop; + int maybe_scalar = 0; + if (o->op_flags & OPf_PARENS) list(o); + else + maybe_scalar = 1; if (attrs) SAVEFREEOP(attrs); - o = my_kid(o, attrs); + o = my_kid(o, attrs, &rops); + if (rops) { + if (maybe_scalar && o->op_type == OP_PADSV) { + o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); + o->op_private |= OPpLVAL_INTRO; + } + else + o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); + } PL_in_my = FALSE; PL_in_my_stash = Nullhv; return o; @@ -2015,7 +2159,7 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) OP * Perl_my(pTHX_ OP *o) { - return my_kid(o, Nullop); + return my_attrs(o, Nullop); } OP * @@ -2047,20 +2191,21 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) desc, sample, sample); } + if (right->op_type == OP_CONST && + cSVOPx(right)->op_private & OPpCONST_BARE && + cSVOPx(right)->op_private & OPpCONST_STRICT) + { + no_bareword_allowed(right); + } + if (!(right->op_flags & OPf_STACKED) && (right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if ((right->op_type != OP_MATCH && - ! (right->op_type == OP_TRANS && - right->op_private & OPpTRANS_IDENTICAL)) || - /* if SV has magic, then match on original SV, not on its copy. - see note in pp_helem() */ - (right->op_type == OP_MATCH && - (left->op_type == OP_AELEM || - left->op_type == OP_HELEM || - left->op_type == OP_AELEMFAST))) + if (right->op_type != OP_MATCH && + ! (right->op_type == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL)) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -2155,7 +2300,10 @@ OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { int needblockscope = PL_hints & HINT_BLOCK_SCOPE; - OP* retval = scalarseq(seq); + line_t copline = PL_copline; + /* there should be a nextstate in every block */ + OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq); + PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ LEAVE_SCOPE(floor); PL_pad_reset_pending = FALSE; PL_compiling.op_private = PL_hints; @@ -2352,30 +2500,6 @@ Perl_fold_constants(pTHX_ register OP *o) } nope: - if (!(PL_opargs[type] & OA_OTHERINT)) - return o; - - if (!(PL_hints & HINT_INTEGER)) { - if (type == OP_MODULO - || 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)) - continue; - return o; - } - if (PL_opargs[curop->op_type] & OA_RETINTEGER) - continue; - return o; - } - o->op_ppaddr = PL_ppaddr[++(o->op_type)]; - } - return o; } @@ -2400,6 +2524,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; + o->op_seq = 0; /* needs to be revisited in peep() */ curop = ((UNOP*)o)->op_first; ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); op_free(curop); @@ -2475,10 +2600,8 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) first->op_last = last->op_last; first->op_flags |= (last->op_flags & OPf_KIDS); -#ifdef PL_OP_SLAB_ALLOC -#else - Safefree(last); -#endif + FreeOp(last); + return (OP*)first; } @@ -2762,7 +2885,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) U8 range_mark = UTF_TO_NATIVE(0xff); sv_catpvn(transv, (char *)&range_mark, 1); } - t = uvuni_to_utf8(tmpbuf, 0x7fffffff); + t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, + UNICODE_ALLOW_SUPER); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); t = (U8*)SvPVX(transv); tlen = SvCUR(transv); @@ -2927,6 +3051,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (!squash) o->op_private |= OPpTRANS_IDENTICAL; } + else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { + o->op_private |= OPpTRANS_IDENTICAL; + } for (i = 0; i < 256; i++) tbl[i] = -1; for (i = 0, j = 0; i < tlen; i++,j++) { @@ -2978,7 +3105,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_pmoffset = SvIV(repointer); SvREPADTMP_off(repointer); sv_setiv(repointer,0); - } else { + } else { repointer = newSViv(0); av_push(PL_regex_padav,SvREFCNT_inc(repointer)); pmop->op_pmoffset = av_len(PL_regex_padav); @@ -2986,7 +3113,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) } } #endif - + /* link into pm list */ if (type != OP_TRANS && PL_curstash) { pmop->op_pmnext = HvPMROOT(PL_curstash); @@ -3019,6 +3146,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } + if (DO_UTF8(pat)) + pm->op_pmdynflags |= PMdf_UTF8; PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm)); if (strEQ("\\s+", PM_GETRE(pm)->precomp)) pm->op_pmflags |= PMf_WHITE; @@ -3228,7 +3357,7 @@ Perl_package(pTHX_ OP *o) op_free(o); } else { - deprecate("\"package\" with no arguments"); + deprecate_old("\"package\" with no arguments"); sv_setpv(PL_curstname,""); PL_curstash = Nullhv; } @@ -3294,7 +3423,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) /* Fake up a method call to import/unimport */ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);; - sv_upgrade(meth, SVt_PVIV); + (void)SvUPGRADE(meth, SVt_PVIV); (void)SvIOK_on(meth); PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, @@ -3324,11 +3453,22 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) newSTATEOP(0, Nullch, imop) )); if (packname) { - if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) { - Perl_warner(aTHX_ WARN_MISC, - "Package `%s' not found " - "(did you use the incorrect case?)", packname); - } + /* The "did you use incorrect case?" warning used to be here. + * The problem is that on case-insensitive filesystems one + * might get false positives for "use" (and "require"): + * "use Strict" or "require CARP" will work. This causes + * portability problems for the script: in case-strict + * filesystems the script will stop working. + * + * The "incorrect case" warning checked whether "use Foo" + * imported "Foo" to your namespace, but that is wrong, too: + * there is no requirement nor promise in the language that + * a Foo.pm should or would contain anything in package "Foo". + * + * There is very little Configure-wise that can be done, either: + * the case-sensitivity of the build filesystem of Perl does not + * help in guessing the case-sensitivity of the runtime environment. + */ safefree(packname); } @@ -3338,6 +3478,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) } /* +=head1 Embedding Functions + =for apidoc load_module Loads the module whose name is pointed to by the string part of name. @@ -3417,10 +3559,10 @@ Perl_dofile(pTHX_ OP *term) GV *gv; gv = gv_fetchpv("do", FALSE, SVt_PVCV); - if (!(gv && GvIMPORTED_CV(gv))) + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, @@ -3461,6 +3603,11 @@ S_list_assignment(pTHX_ register OP *o) return FALSE; } + if (o->op_type == OP_LIST && + (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && + o->op_private & OPpLVAL_INTRO) + return FALSE; + if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) @@ -3550,14 +3697,14 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) else if (curop->op_type == OP_PUSHRE) { if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS - GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot]; + GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)]; #else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; - } + } } else break; @@ -3580,7 +3727,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) tmpop = ((UNOP*)left)->op_first; if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { #ifdef USE_ITHREADS - pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix; + pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; @@ -3684,8 +3831,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) if (PERLDB_LINE && PL_curstash != PL_debstash) { SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); - if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) { - (void)SvIOK_on(*svp); + if (svp && *svp != &PL_sv_undef ) { + (void)SvIOK_on(*svp); SvIVX(*svp) = PTR2IV(cop); } } @@ -3961,7 +4108,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) case OP_SASSIGN: if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB - || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL) + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) expr = newUNOP(OP_DEFINED, 0, expr); break; @@ -4167,6 +4314,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LOOP); + FreeOp(loop); loop = tmp; } #else @@ -4246,15 +4394,9 @@ Perl_cv_undef(pTHX_ CV *cv) * CV, they don't hold a refcount on the outside CV. This avoids * the refcount loop between the outer CV (which keeps a refcount to * the closure prototype in the pad entry for pp_anoncode()) and the - * closure prototype, and the ensuing memory leak. This does not - * apply to closures generated within eval"", since eval"" CVs are - * ephemeral. --GSAR */ - if (!CvANON(cv) || CvCLONED(cv) - || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV - && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv)))) - { + * closure prototype, and the ensuing memory leak. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv)) SvREFCNT_dec(CvOUTSIDE(cv)); - } CvOUTSIDE(cv) = Nullcv; if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); @@ -4515,9 +4657,12 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) } } -static void const_sv_xsub(pTHXo_ CV* cv); +static void const_sv_xsub(pTHX_ CV* cv); /* + +=head1 Optree Manipulation Functions + =for apidoc cv_const_sv If C is a constant sub eligible for inlining. returns the constant @@ -4623,13 +4768,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]", + Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", + PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); aname = SvPVX(sv); } else aname = Nullch; - gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"), + gv = gv_fetchpv(name ? name : (aname ? aname : + (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")), GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), SVt_PVCV); @@ -4704,7 +4851,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) { line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, PL_copline); + if (PL_copline != NOLINE) + CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ WARN_REDEFINE, CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", name); @@ -4758,7 +4906,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else stash = PL_curstash; } - apply_attrs(stash, rcv, attrs); + apply_attrs(stash, rcv, attrs, FALSE); } if (cv) { /* must reuse cv if autoloaded */ if (!block) { @@ -4900,17 +5048,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } - /* If a potential closure prototype, don't keep a refcount on - * outer CV, unless the latter happens to be a passing eval"". + /* If a potential closure prototype, don't keep a refcount on outer CV. * This is okay as the lifetime of the prototype is tied to the * lifetime of the outer CV. Avoids memory leak due to reference * loop. --GSAR */ - if (!name && CvOUTSIDE(cv) - && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV - && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv)))) - { + if (!name) SvREFCNT_dec(CvOUTSIDE(cv)); - } if (name || aname) { char *s; @@ -4953,8 +5096,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - save_svref(&PL_rs); - sv_setsv(PL_rs, PL_nrs); if (!PL_beginav) PL_beginav = newAV(); @@ -5029,11 +5170,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) SAVESPTR(PL_curstash); SAVECOPSTASH(PL_curcop); PL_curstash = stash; -#ifdef USE_ITHREADS - CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch; -#else - CopSTASH(PL_curcop) = stash; -#endif + CopSTASH_set(PL_curcop,stash); } cv = newXS(name, const_sv_xsub, __FILE__); @@ -5057,7 +5194,9 @@ Used by C to hook up XSUBs as Perl subs. CV * Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) { - GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); + GV *gv = gv_fetchpv(name ? name : + (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), + GV_ADDMULTI, SVt_PVCV); register CV *cv; if ((cv = (name ? GvCV(gv) : Nullcv))) { @@ -5177,8 +5316,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { line_t oldline = CopLINE(PL_curcop); - - CopLINE_set(PL_curcop, PL_copline); + if (PL_copline != NOLINE) + CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name); CopLINE_set(PL_curcop, oldline); } @@ -5241,7 +5380,7 @@ Perl_oopsAV(pTHX_ OP *o) o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; return ref(o, OP_RV2AV); - + case OP_RV2SV: o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; @@ -5290,8 +5429,8 @@ Perl_newAVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) - && ckWARN(WARN_DEPRECATED)) { - Perl_warner(aTHX_ WARN_DEPRECATED, + && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Using an array as a reference is deprecated"); } return newUNOP(OP_RV2AV, 0, scalar(o)); @@ -5314,8 +5453,8 @@ Perl_newHVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) - && ckWARN(WARN_DEPRECATED)) { - Perl_warner(aTHX_ WARN_DEPRECATED, + && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Using a hash as a reference is deprecated"); } return newUNOP(OP_RV2HV, 0, scalar(o)); @@ -5402,7 +5541,7 @@ Perl_ck_spair(pTHX_ OP *o) !(PL_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); @@ -5441,6 +5580,15 @@ Perl_ck_delete(pTHX_ OP *o) } OP * +Perl_ck_die(pTHX_ OP *o) +{ +#ifdef VMS + if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; +#endif + return ck_fun(o); +} + +OP * Perl_ck_eof(pTHX_ OP *o) { I32 type = o->op_type; @@ -5509,6 +5657,7 @@ Perl_ck_exit(pTHX_ OP *o) if (svp && *svp && SvTRUE(*svp)) o->op_private |= OPpEXIT_VMSISH; } + if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif return ck_fun(o); } @@ -5759,15 +5908,15 @@ Perl_ck_fun(pTHX_ OP *o) Perl_warner(aTHX_ WARN_SYNTAX, "Useless use of %s with no values", PL_op_desc[type]); - + if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); - if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ WARN_DEPRECATED, + if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Array @%s missing the @ in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5786,8 +5935,8 @@ Perl_ck_fun(pTHX_ OP *o) char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); - if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ WARN_DEPRECATED, + if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Hash %%%s missing the %% in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5818,6 +5967,8 @@ Perl_ck_fun(pTHX_ OP *o) OP *newop = newGVOP(OP_GV, 0, gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, SVt_PVIO) ); + if (kid == cLISTOPo->op_last) + cLISTOPo->op_last = newop; op_free(kid); kid = newop; } @@ -5917,16 +6068,19 @@ Perl_ck_glob(pTHX_ OP *o) 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))) + if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) + && GvCVu(gv) && GvIMPORTED_CV(gv))) + { gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); + } #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { GV *glob_gv; ENTER; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv, - Nullsv, Nullsv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); GvCV(gv) = GvCV(glob_gv); @@ -5936,7 +6090,7 @@ Perl_ck_glob(pTHX_ OP *o) } #endif /* PERL_EXTERNAL_GLOB */ - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); o->op_type = OP_LIST; @@ -6039,7 +6193,7 @@ Perl_ck_lfun(pTHX_ OP *o) OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { - if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { + if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: /* This is needed for @@ -6049,9 +6203,9 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(@array) is deprecated"); - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: @@ -6061,9 +6215,9 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ */ break; /* Globals via GV can be undef */ case OP_PADHV: - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(%%hash) is deprecated"); - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); break; default: @@ -6104,7 +6258,7 @@ Perl_ck_listiob(pTHX_ OP *o) kid = kid->op_sibling; } } - + if (!kid) append_elem(o->op_type, o, newDEFSVOP()); @@ -6247,10 +6401,10 @@ Perl_ck_require(pTHX_ OP *o) /* handle override, if any */ gv = gv_fetchpv("require", FALSE, SVt_PVCV); - if (!(gv && GvIMPORTED_CV(gv))) + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { OP *kid = cUNOPo->op_first; cUNOPo->op_first = 0; op_free(o); @@ -6312,7 +6466,7 @@ Perl_ck_shift(pTHX_ OP *o) if (!(o->op_flags & OPf_KIDS)) { OP *argop; - + op_free(o); #ifdef USE_5005THREADS if (!CvUNIQUE(PL_compcv)) { @@ -6541,6 +6695,8 @@ Perl_ck_subr(pTHX_ OP *o) GV *namegv = 0; int optional = 0; I32 arg = 0; + I32 contextclass = 0; + char *e = 0; STRLEN n_a; o->op_private |= OPpENTERSUB_HASTARG; @@ -6637,36 +6793,74 @@ Perl_ck_subr(pTHX_ OP *o) } scalar(o2); break; + case '[': case ']': + goto oops; + break; case '\\': proto++; arg++; + again: switch (*proto++) { + case '[': + if (contextclass++ == 0) { + e = strchr(proto, ']'); + if (!e || e == proto) + goto oops; + } + else + goto oops; + goto again; + break; + case ']': + if (contextclass) { + char *p = proto; + char s = *p; + contextclass = 0; + *p = '\0'; + while (*--p != '['); + bad_type(arg, Perl_form(aTHX_ "one of %s", p), + gv_ename(namegv), o2); + *proto = s; + } else + goto oops; + break; case '*': - if (o2->op_type != OP_RV2GV) - bad_type(arg, "symbol", gv_ename(namegv), o2); - goto wrapref; + if (o2->op_type == OP_RV2GV) + goto wrapref; + if (!contextclass) + bad_type(arg, "symbol", gv_ename(namegv), o2); + break; case '&': - if (o2->op_type != OP_ENTERSUB) - bad_type(arg, "subroutine entry", gv_ename(namegv), o2); - goto wrapref; + if (o2->op_type == OP_ENTERSUB) + goto wrapref; + if (!contextclass) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); + break; case '$': - if (o2->op_type != OP_RV2SV - && o2->op_type != OP_PADSV - && o2->op_type != OP_HELEM - && o2->op_type != OP_AELEM - && o2->op_type != OP_THREADSV) - { + if (o2->op_type == OP_RV2SV || + o2->op_type == OP_PADSV || + o2->op_type == OP_HELEM || + o2->op_type == OP_AELEM || + o2->op_type == OP_THREADSV) + goto wrapref; + if (!contextclass) bad_type(arg, "scalar", gv_ename(namegv), o2); - } - goto wrapref; + break; case '@': - if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV) + if (o2->op_type == OP_RV2AV || + o2->op_type == OP_PADAV) + goto wrapref; + if (!contextclass) bad_type(arg, "array", gv_ename(namegv), o2); - goto wrapref; + break; case '%': - if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV) - bad_type(arg, "hash", gv_ename(namegv), o2); - wrapref: + if (o2->op_type == OP_RV2HV || + o2->op_type == OP_PADHV) + goto wrapref; + if (!contextclass) + bad_type(arg, "hash", gv_ename(namegv), o2); + break; + wrapref: { OP* kid = o2; OP* sib = kid->op_sibling; @@ -6675,9 +6869,15 @@ Perl_ck_subr(pTHX_ OP *o) o2->op_sibling = sib; prev->op_sibling = o2; } + if (contextclass && e) { + proto = e + 1; + contextclass = 0; + } break; default: goto oops; } + if (contextclass) + goto again; break; case ' ': proto++; @@ -6685,7 +6885,7 @@ Perl_ck_subr(pTHX_ OP *o) default: oops: Perl_croak(aTHX_ "Malformed prototype for %s: %s", - gv_ename(namegv), SvPV((SV*)cv, n_a)); + gv_ename(namegv), SvPV((SV*)cv, n_a)); } } else @@ -6862,7 +7062,7 @@ Perl_peep(pTHX_ register OP *o) else if (o->op_next->op_type == OP_RV2AV) { OP* pop = o->op_next->op_next; IV i; - if (pop->op_type == OP_CONST && + if (pop && pop->op_type == OP_CONST && (PL_op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & @@ -6899,10 +7099,12 @@ Perl_peep(pTHX_ register OP *o) && o->op_next->op_next->op_type == OP_CONCAT && (o->op_next->op_next->op_flags & OPf_STACKED)) { - /* Turn "$a .= " into an OP_RCATLINE. AMS 20010811 */ - o->op_next->op_type = OP_RCATLINE; - o->op_next->op_flags |= OPf_STACKED; + /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ + o->op_type = OP_RCATLINE; + o->op_flags |= OPf_STACKED; + o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; op_null(o->op_next->op_next); + op_null(o->op_next); } o->op_seq = PL_op_seqmax++; @@ -6965,7 +7167,7 @@ Perl_peep(pTHX_ register OP *o) } } break; - + case OP_HELEM: { UNOP *rop; SV *lexname; @@ -6974,7 +7176,7 @@ Perl_peep(pTHX_ register OP *o) I32 ind; char *key = NULL; STRLEN keylen; - + o->op_seq = PL_op_seqmax++; if (((BINOP*)o)->op_last->op_type != OP_CONST) @@ -7026,7 +7228,7 @@ Perl_peep(pTHX_ register OP *o) *svp = sv; break; } - + case OP_HSLICE: { UNOP *rop; SV *lexname; @@ -7100,8 +7302,9 @@ Perl_peep(pTHX_ register OP *o) LEAVE; } -#ifdef PERL_CUSTOM_OPS -char* custom_op_name(pTHX_ OP* o) + + +char* Perl_custom_op_name(pTHX_ OP* o) { IV index = PTR2IV(o->op_ppaddr); SV* keysv; @@ -7119,7 +7322,7 @@ char* custom_op_name(pTHX_ OP* o) return SvPV_nolen(HeVAL(he)); } -char* custom_op_desc(pTHX_ OP* o) +char* Perl_custom_op_desc(pTHX_ OP* o) { IV index = PTR2IV(o->op_ppaddr); SV* keysv; @@ -7136,13 +7339,13 @@ char* custom_op_desc(pTHX_ OP* o) return SvPV_nolen(HeVAL(he)); } -#endif + #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */ static void -const_sv_xsub(pTHXo_ CV* cv) +const_sv_xsub(pTHX_ CV* cv) { dXSARGS; if (items != 0) { @@ -7155,4 +7358,3 @@ const_sv_xsub(pTHXo_ CV* cv) ST(0) = (SV*)XSANY.any_ptr; XSRETURN(1); } -