X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=748888704c93069a5a85ef91e76a8fe457b63ad3;hb=2e5b50041f3643ca27385b211da60add40857ec8;hp=b08b7e27c77e96bf294734255aeb856d2ea0421e;hpb=4ac71550d23cca4632a2bcdfcb1d83a6bf705e45;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index b08b7e2..7488887 100644 --- a/op.c +++ b/op.c @@ -399,14 +399,6 @@ Perl_allocmy(pTHX_ const char *const name) /* check for duplicate declaration */ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); - if (PL_parser->in_my_stash && *name != '$') { - yyerror(Perl_form(aTHX_ - "Can't declare class for non-scalar %s in \"%s\"", - name, - is_our ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); - } - /* allocate a spare slot and store the name in that slot */ off = pad_add_name(name, @@ -785,8 +777,8 @@ Perl_op_refcnt_unlock(pTHX) #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) -OP * -Perl_linklist(pTHX_ OP *o) +static OP * +S_linklist(pTHX_ OP *o) { OP *first; @@ -817,8 +809,8 @@ Perl_linklist(pTHX_ OP *o) return o->op_next; } -OP * -Perl_scalarkids(pTHX_ OP *o) +static OP * +S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -1205,8 +1197,8 @@ Perl_scalarvoid(pTHX_ OP *o) return o; } -OP * -Perl_listkids(pTHX_ OP *o) +static OP * +S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -1293,8 +1285,8 @@ Perl_list(pTHX_ OP *o) return o; } -OP * -Perl_scalarseq(pTHX_ OP *o) +static OP * +S_scalarseq(pTHX_ OP *o) { dVAR; if (o) { @@ -1766,8 +1758,8 @@ S_is_handle_constructor(const OP *o, I32 numargs) } } -OP * -Perl_refkids(pTHX_ OP *o, I32 type) +static OP * +S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -2152,14 +2144,6 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) } OP * -Perl_my(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_MY; - - return my_attrs(o, NULL); -} - -OP * Perl_sawparens(pTHX_ OP *o) { PERL_UNUSED_CONTEXT; @@ -2346,8 +2330,7 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV * const cv - = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0); + CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; PUSHMARK(SP); @@ -2434,8 +2417,8 @@ Perl_jmaybe(pTHX_ OP *o) return o; } -OP * -Perl_fold_constants(pTHX_ register OP *o) +static OP * +S_fold_constants(pTHX_ register OP *o) { dVAR; register OP * VOL curop; @@ -2575,8 +2558,8 @@ Perl_fold_constants(pTHX_ register OP *o) return o; } -OP * -Perl_gen_constant_list(pTHX_ register OP *o) +static OP * +S_gen_constant_list(pTHX_ register OP *o) { dVAR; register OP *curop; @@ -2989,8 +2972,8 @@ Perl_newNULLLIST(pTHX) return newOP(OP_STUB, 0); } -OP * -Perl_force_list(pTHX_ OP *o) +static OP * +S_force_list(pTHX_ OP *o) { if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); @@ -3127,8 +3110,8 @@ static int uvcompare(const void *a, const void *b) return 0; } -OP * -Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) +static OP * +S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; @@ -3451,6 +3434,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } } + + if(ckWARN(WARN_MISC)) { + if(del && rlen == tlen) { + Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + } else if(rlen > tlen) { + Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); + } + } + if (grows) o->op_private |= OPpTRANS_GROWS; #ifdef PERL_MAD @@ -4333,7 +4325,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; - if (SvIVX(sv) == 0) + if (SvIOK(sv) && SvIVX(sv) == 0) sv_setiv(sv, PL_modcount+1); } } @@ -4355,6 +4347,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) PL_eval_start = 0; else { if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */ + deprecate("assignment to $["); op_free(o); o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); o->op_private |= OPpCONST_ARYBASE; @@ -4424,7 +4417,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) #endif CopSTASH_set(cop, PL_curstash); - if (PERLDB_LINE && PL_curstash != PL_debstash) { + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) { + /* this line can have a breakpoint - store the cop in IV */ AV *av = CopFILEAVx(PL_curcop); if (av) { SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); @@ -5182,6 +5176,7 @@ S_looks_like_bool(pTHX_ const OP *o) switch(o->op_type) { case OP_OR: + case OP_DOR: return looks_like_bool(cLOGOPo->op_first); case OP_AND: @@ -5197,7 +5192,6 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_ENTERSUB: case OP_NOT: case OP_XOR: - /* Note that OP_DOR is not here */ case OP_EQ: case OP_NE: case OP_LT: case OP_GT: case OP_LE: case OP_GE: @@ -5222,6 +5216,8 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_DEFINED: case OP_EXISTS: case OP_MATCH: case OP_EOF: + case OP_FLOP: + return TRUE; case OP_CONST: @@ -5230,7 +5226,9 @@ S_looks_like_bool(pTHX_ const OP *o) || cSVOPo->op_sv == &PL_sv_no) return TRUE; - + else + return FALSE; + /* FALL THROUGH */ default: return FALSE; @@ -5586,12 +5584,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); -#ifdef GV_UNIQUE_CHECK - if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { - Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name); - } -#endif - if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) #ifdef PERL_MAD @@ -5605,12 +5597,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); -#ifdef GV_UNIQUE_CHECK - if (exists && GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name); - } -#endif - /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, * skipping the prototype check @@ -5796,6 +5782,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!block) goto done; + /* If we assign an optree to a PVCV, then we've defined a subroutine that + the debugger could be able to set a breakpoint in, so signal to + pp_entereval that it should not throw away any saved lines at scope + exit. */ + + PL_breakable_sub_gen++; if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); @@ -5942,6 +5934,11 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, Creates a constant sub equivalent to Perl C which is eligible for inlining at compile-time. +Passing NULL for SV creates a constant sub equivalent to C, +which won't be called if used as a destructor, but will suppress the overhead +of a call to C. (This form, however, isn't eligible for inlining at +compile time.) + =cut */ @@ -5951,14 +5948,11 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) dVAR; CV* cv; #ifdef USE_ITHREADS - const char *const temp_p = CopFILE(PL_curcop); - const STRLEN len = temp_p ? strlen(temp_p) : 0; + const char *const file = CopFILE(PL_curcop); #else SV *const temp_sv = CopFILESV(PL_curcop); - STRLEN len; - const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL; + const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL; #endif - char *const file = savepvn(temp_p, temp_p ? len : 0); ENTER; @@ -5986,10 +5980,10 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ - cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME); + cv = newXS_flags(name, const_sv_xsub, file ? file : "", "", + XS_DYNAMIC_FILENAME); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); - Safefree(file); #ifdef USE_ITHREADS if (stash) @@ -6145,20 +6139,19 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); -#ifdef GV_UNIQUE_CHECK - if (GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); - } -#endif GvMULTI_on(gv); if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - o ? "Format %"SVf" redefined" - : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv)); + if (o) { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); + } else { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format STDOUT redefined"); + } CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -6536,6 +6529,8 @@ Perl_ck_eval(pTHX_ OP *o) /* establish postfix order */ enter->op_next = (OP*)enter; + CHECKOP(OP_ENTERTRY, enter); + o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; @@ -7628,14 +7623,29 @@ OP * Perl_ck_return(pTHX_ OP *o) { dVAR; + OP *kid; PERL_ARGS_ASSERT_CK_RETURN; + kid = cLISTOPo->op_first->op_sibling; if (CvLVALUE(PL_compcv)) { - OP *kid; - for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); + } else { + for (; kid; kid = kid->op_sibling) + if ((kid->op_type == OP_NULL) + && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) { + /* This is a do block */ + OP *op = kUNOP->op_first; + if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) { + op = cUNOPx(op)->op_first; + assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL)); + /* Force the use of the caller's context */ + op->op_flags |= OPf_SPECIAL; + } + } } + return o; } @@ -7918,7 +7928,7 @@ Perl_ck_join(pTHX_ OP *o) if (kid && kid->op_type == OP_MATCH) { if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); - const char *pmstr = re ? RX_PRECOMP(re) : "STRING"; + const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING"; const STRLEN len = re ? RX_PRELEN(re) : 6; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%.*s/ should probably be written as \"%.*s\"", @@ -8542,7 +8552,7 @@ Perl_peep(pTHX_ register OP *o) /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); - if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { + if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, @@ -8947,6 +8957,7 @@ const_sv_xsub(pTHX_ CV* cv) { dVAR; dXSARGS; + SV *const sv = MUTABLE_SV(XSANY.any_ptr); if (items != 0) { NOOP; #if 0 @@ -8954,8 +8965,11 @@ const_sv_xsub(pTHX_ CV* cv) HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } + if (!sv) { + XSRETURN(0); + } EXTEND(sp, 1); - ST(0) = MUTABLE_SV(XSANY.any_ptr); + ST(0) = sv; XSRETURN(1); }