X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=f512832a30d9e922ff2f94cd75d8f665f74e1805;hb=76467b2a651c6c83b127a7ee5b8170cd17171b66;hp=3ef7e3210b4064bef651c9b2852c9c7b7df41b91;hpb=414bf5ae0886eb91e2f6dbb35893ddb012852bef;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 3ef7e32..f512832 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -357,8 +357,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) } } -void -Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) +static void +S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; @@ -387,8 +387,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) } } -void -Perl_rxres_free(pTHX_ void **rsp) +static void +S_rxres_free(pTHX_ void **rsp) { UV * const p = (UV*)*rsp; @@ -511,8 +511,7 @@ PP(pp_formline) if (!targ_is_utf8 && DO_UTF8(tmpForm)) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -695,8 +694,8 @@ PP(pp_formline) if (!targ_is_utf8) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, + fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -807,7 +806,7 @@ PP(pp_formline) t - SvPVX_const(PL_formtarget)); targ_is_utf8 = TRUE; /* Don't need get magic. */ - sv_utf8_upgrade_flags(PL_formtarget, 0); + sv_utf8_upgrade_nomg(PL_formtarget); } else { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); @@ -1779,7 +1778,7 @@ PP(pp_caller) /* Get the bit mask for $warnings::Bits{all}, because * it could have been extended by warnings::register */ SV **bits_all; - HV * const bits = get_hv("warnings::Bits", FALSE); + HV * const bits = get_hv("warnings::Bits", 0); if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { mask = newSVsv(*bits_all); } @@ -2576,7 +2575,7 @@ PP(pp_goto) if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ Perl_get_db_sub(aTHX_ NULL, cv); if (PERLDB_GOTO) { - CV * const gotocv = get_cv("DB::goto", FALSE); + CV * const gotocv = get_cvs("DB::goto", 0); if (gotocv) { PUSHMARK( PL_stack_sp ); call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); @@ -2764,7 +2763,7 @@ S_save_lines(pTHX_ AV *array, SV *sv) const char *t; SV * const tmpstr = newSV_type(SVt_PVMG); - t = strchr(s, '\n'); + t = (const char *)memchr(s, '\n', send - s); if (t) t++; else @@ -3048,7 +3047,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) POPEVAL(cx); } lex_end(); - LEAVE; + LEAVE; /* pp_entereval knows about this LEAVE. */ msg = SvPVx_nolen_const(ERRSV); if (optype == OP_REQUIRE) { @@ -3099,7 +3098,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) /* Register with debugger: */ if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { - CV * const cv = get_cv("DB::postponed", FALSE); + CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; PUSHMARK(SP); @@ -3653,18 +3652,14 @@ PP(pp_entereval) register PERL_CONTEXT *cx; SV *sv; const I32 gimme = GIMME_V; - const I32 was = PL_sub_generation; + const U32 was = PL_breakable_sub_gen; char tbuf[TYPE_DIGITS(long) + 12]; char *tmpbuf = tbuf; - char *safestr; STRLEN len; - bool ok; CV* runcv; U32 seq; HV *saved_hh = NULL; - const char * const fakestr = "_<(eval )"; - const int fakelen = 9 + 1; - + if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } @@ -3698,8 +3693,6 @@ PP(pp_entereval) (i.e. before run-time proper). To work around the coredump that ensues, we always turn GvMULTI_on for any globals that were introduced within evals. See force_ident(). GSAR 96-10-12 */ - safestr = savepvn(tmpbuf, len); - SAVEDELETE(PL_defstash, safestr, len); SAVEHINTS(); PL_hints = PL_op->op_targ; if (saved_hh) @@ -3728,17 +3721,32 @@ PP(pp_entereval) /* prepare to compile string */ - if (PERLDB_SAVESRC && PL_curstash != PL_debstash) + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); PUTBACK; - ok = doeval(gimme, NULL, runcv, seq); - if ((PERLDB_LINE || PERLDB_SAVESRC) - && was != (I32)PL_sub_generation /* Some subs defined here. */ - && ok) { - /* Copy in anything fake and short. */ - my_strlcpy(safestr, fakestr, fakelen); - } - return ok ? DOCATCH(PL_eval_start) : PL_op->op_next; + + if (doeval(gimme, NULL, runcv, seq)) { + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? (PERLDB_LINE || PERLDB_SAVESRC) + : PERLDB_SAVESRC_NOSUBS) { + /* Retain the filegv we created. */ + } else { + char *const safestr = savepvn(tmpbuf, len); + SAVEDELETE(PL_defstash, safestr, len); + } + return DOCATCH(PL_eval_start); + } else { + /* We have already left the scope set up earler thanks to the LEAVE + in doeval(). */ + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? (PERLDB_LINE || PERLDB_SAVESRC) + : PERLDB_SAVESRC_INVALID) { + /* Retain the filegv we created. */ + } else { + (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); + } + return PL_op->op_next; + } } PP(pp_leaveeval) @@ -4079,8 +4087,12 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SvGMAGICAL(e)) e = sv_mortalcopy(e); - if (SM_OBJECT) - Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + if (SM_OBJECT) { + if (!SvOK(d) || !SvOK(e)) + RETPUSHNO; + else + Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + } if (SM_CV_NEP) { I32 c;