X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=30b44064ef4b70f44f8317549a9503ff42761436;hb=8876aa855575c76fe5c85df0966371a59a0bbc8e;hp=cdfe8c430ba6575a156f39cd657a4bc7b43f019c;hpb=6fc9266916f08dacf1850556174b6312eefb14e6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index cdfe8c4..30b4406 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -16,6 +16,7 @@ */ #include "EXTERN.h" +#define PERL_IN_PP_HOT_C #include "perl.h" #ifdef I_UNISTD @@ -33,25 +34,7 @@ /* Hot code. */ #ifdef USE_THREADS -static void -unset_cvowner(void *cvarg) -{ - register CV* cv = (CV *) cvarg; -#ifdef DEBUGGING - dTHR; -#endif /* DEBUGGING */ - - DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", - thr, cv, SvPEEK((SV*)cv)))); - MUTEX_LOCK(CvMUTEXP(cv)); - DEBUG_S(if (CvDEPTH(cv) != 0) - PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", - CvDEPTH(cv));); - assert(thr == CvOWNER(cv)); - CvOWNER(cv) = 0; - MUTEX_UNLOCK(CvMUTEXP(cv)); - SvREFCNT_dec(cv); -} +static void unset_cvowner(pTHXo_ void *cvarg); #endif /* USE_THREADS */ PP(pp_const) @@ -86,6 +69,12 @@ PP(pp_null) return NORMAL; } +PP(pp_setstate) +{ + PL_curcop = (COP*)PL_op; + return NORMAL; +} + PP(pp_pushmark) { PUSHMARK(PL_stack_sp); @@ -141,9 +130,9 @@ PP(pp_cond_expr) { djSP; if (SvTRUEx(POPs)) - RETURNOP(cCONDOP->op_true); + RETURNOP(cLOGOP->op_other); else - RETURNOP(cCONDOP->op_false); + RETURNOP(cLOGOP->op_next); } PP(pp_unstack) @@ -204,19 +193,15 @@ PP(pp_readline) { tryAMAGICunTARGET(iter, 0); PL_last_in_gv = (GV*)(*PL_stack_sp--); - if (PL_op->op_flags & OPf_SPECIAL) { /* Are called as <$var> */ - if (SvROK(PL_last_in_gv)) { - if (SvTYPE(SvRV(PL_last_in_gv)) != SVt_PVGV) - goto hard_way; + if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { + if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); - } else if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { - hard_way: { + else { dSP; XPUSHs((SV*)PL_last_in_gv); PUTBACK; - pp_rv2gv(ARGS); + pp_rv2gv(); PL_last_in_gv = (GV*)(*PL_stack_sp--); - } } } return do_readline(); @@ -236,8 +221,8 @@ PP(pp_preinc) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(PL_no_modify); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + Perl_croak(aTHX_ PL_no_modify); + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); @@ -342,7 +327,7 @@ PP(pp_print) *MARK = SvTIED_obj((SV*)gv, mg); PUTBACK; ENTER; - perl_call_method("PRINT", G_SCALAR); + call_method("PRINT", G_SCALAR); LEAVE; SPAGAIN; MARK = ORIGMARK + 1; @@ -353,23 +338,24 @@ PP(pp_print) if (!(io = GvIO(gv))) { if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); - warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a)); + gv_efullname3(sv, gv, Nullch); + Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", + SvPV(sv,n_a)); } - SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED, WARN_IO)) { SV* sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); + gv_efullname3(sv, gv, Nullch); if (IoIFP(io)) - warner(WARN_IO, "Filehandle %s opened only for input", - SvPV(sv,n_a)); + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", + SvPV(sv,n_a)); else if (ckWARN(WARN_CLOSED)) - warner(WARN_CLOSED, "print on closed filehandle %s", - SvPV(sv,n_a)); + Perl_warner(aTHX_ WARN_CLOSED, + "print on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -429,7 +415,7 @@ PP(pp_rv2av) av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) - DIE("Not an ARRAY reference"); + DIE(aTHX_ "Not an ARRAY reference"); if (PL_op->op_flags & OPf_REF) { SETs((SV*)av); RETURN; @@ -458,9 +444,9 @@ PP(pp_rv2av) if (!SvOK(sv)) { if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_usym, "an ARRAY"); + DIE(aTHX_ PL_no_usym, "an ARRAY"); if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); if (GIMME == G_ARRAY) { (void)POPs; RETURN; @@ -477,7 +463,7 @@ PP(pp_rv2av) } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_symref, sym, "an ARRAY"); + DIE(aTHX_ PL_no_symref, sym, "an ARRAY"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); } } @@ -529,7 +515,7 @@ PP(pp_rv2hv) hv = (HV*)SvRV(sv); if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) - DIE("Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; @@ -558,9 +544,9 @@ PP(pp_rv2hv) if (!SvOK(sv)) { if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_usym, "a HASH"); + DIE(aTHX_ PL_no_usym, "a HASH"); if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; @@ -577,7 +563,7 @@ PP(pp_rv2hv) } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_symref, sym, "a HASH"); + DIE(aTHX_ PL_no_symref, sym, "a HASH"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); } } @@ -596,14 +582,14 @@ PP(pp_rv2hv) if (GIMME == G_ARRAY) { /* array wanted */ *PL_stack_sp = (SV*)hv; - return do_kv(ARGS); + return do_kv(); } else { dTARGET; if (SvTYPE(hv) == SVt_PVAV) hv = avhv_keys((AV*)hv); if (HvFILL(hv)) - sv_setpvf(TARG, "%ld/%ld", + Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv) + 1); else sv_setiv(TARG, 0); @@ -714,9 +700,9 @@ PP(pp_aassign) SvROK(*relem) && ( SvTYPE(SvRV(*relem)) == SVt_PVAV || SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) - warner(WARN_UNSAFE, "Reference found where even-sized list expected"); + Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected"); else - warner(WARN_UNSAFE, "Odd number of elements in hash assignment"); + Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment"); } tmpstr = NEWSV(29,0); didstore = hv_store_ent(hash,*relem,tmpstr,0); @@ -770,7 +756,7 @@ PP(pp_aassign) # endif /* HAS_SETEUID */ if (PL_delaymagic & DM_UID) { if (PL_uid != PL_euid) - DIE("No setreuid available"); + DIE(aTHX_ "No setreuid available"); (void)PerlProc_setuid(PL_uid); } # endif /* HAS_SETREUID */ @@ -799,7 +785,7 @@ PP(pp_aassign) # endif /* HAS_SETEGID */ if (PL_delaymagic & DM_GID) { if (PL_gid != PL_egid) - DIE("No setregid available"); + DIE(aTHX_ "No setregid available"); (void)PerlProc_setgid(PL_gid); } # endif /* HAS_SETREGID */ @@ -849,8 +835,8 @@ PP(pp_match) register char *s; char *strend; I32 global; - I32 r_flags = 0; - char *truebase; + I32 r_flags = REXEC_CHECKED; + char *truebase; /* Start of string */ register REGEXP *rx = pm->op_pmregexp; bool rxtainted; I32 gimme = GIMME; @@ -870,7 +856,7 @@ PP(pp_match) s = SvPV(TARG, len); strend = s + len; if (!s) - DIE("panic: do_match"); + DIE(aTHX_ "panic: do_match"); rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; @@ -892,15 +878,15 @@ PP(pp_match) /* XXXX What part of this is needed with true \G-support? */ if (global = pm->op_pmflags & PMf_GLOBAL) { - rx->startp[0] = 0; + rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); if (mg && mg->mg_len >= 0) { if (!(rx->reganch & ROPT_GPOS_SEEN)) - rx->endp[0] = rx->startp[0] = s + mg->mg_len; + rx->endp[0] = rx->startp[0] = mg->mg_len; else if (rx->reganch & ROPT_ANCH_GPOS) { r_flags |= REXEC_IGNOREPOS; - rx->endp[0] = rx->startp[0] = s + mg->mg_len; + rx->endp[0] = rx->startp[0] = mg->mg_len; } minmatch = (mg->mg_flags & MGf_MINMATCH); update_minmatch = 0; @@ -910,9 +896,7 @@ PP(pp_match) if ((gimme != G_ARRAY && !global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) r_flags |= REXEC_COPY_STR; - if (SvSCREAM(TARG) && rx->check_substr - && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) + if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { @@ -921,61 +905,26 @@ PP(pp_match) } play_it_again: - if (global && rx->startp[0]) { - t = s = rx->endp[0]; + if (global && rx->startp[0] != -1) { + t = s = rx->endp[0] + truebase; if ((s + rx->minlen) > strend) goto nope; if (update_minmatch++) minmatch = had_zerolen; } - if (rx->check_substr) { - if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */ - if (r_flags & REXEC_SCREAM) { - I32 p = -1; - char *b; - - if (PL_screamfirst[BmRARE(rx->check_substr)] < 0) - goto nope; - - b = (char*)HOP((U8*)s, rx->check_offset_min); - if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0))) - goto nope; - - if ((rx->reganch & ROPT_CHECK_ALL) - && !PL_sawampersand && !SvTAIL(rx->check_substr)) - goto yup; - } - else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), - (unsigned char*)strend, - rx->check_substr, 0))) - goto nope; - else if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand) - goto yup; - if (s && rx->check_offset_max < s - t) { - ++BmUSEFUL(rx->check_substr); - s = (char*)HOP((U8*)s, -rx->check_offset_max); - } - else - s = t; - } - /* Now checkstring is fixed, i.e. at fixed offset from the - beginning of match, and the match is anchored at s. */ - else if (!PL_multiline) { /* Anchored near beginning of string. */ - I32 slen; - char *b = (char*)HOP((U8*)s, rx->check_offset_min); - if (*SvPVX(rx->check_substr) != *b - || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), b, slen))) - goto nope; - } - if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0 - && rx->check_substr == rx->float_substr) { - SvREFCNT_dec(rx->check_substr); - rx->check_substr = Nullsv; /* opt is being useless */ - rx->float_substr = Nullsv; - } - } - if (CALLREGEXEC(rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) + if (rx->reganch & RE_USE_INTUIT) { + s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + + if (!s) + goto nope; + if ( (rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand + && ((rx->reganch & ROPT_NOSCAN) + || !((rx->reganch & RE_INTUIT_TAIL) + && (r_flags & REXEC_SCREAM)))) + goto yup; + } + if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) { PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) @@ -1004,17 +953,17 @@ play_it_again: for (i = !i; i <= iters; i++) { PUSHs(sv_newmortal()); /*SUPPRESS 560*/ - if ((s = rx->startp[i]) && rx->endp[i] ) { - len = rx->endp[i] - s; + if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { + len = rx->endp[i] - rx->startp[i]; + s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); } } if (global) { - truebase = rx->subbeg; - strend = rx->subend; - had_zerolen = (rx->startp[0] && rx->startp[0] == rx->endp[0]); + had_zerolen = (rx->startp[0] != -1 + && rx->startp[0] == rx->endp[0]); PUTBACK; /* EVAL blocks may use stack */ - r_flags |= REXEC_IGNOREPOS; + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; } else if (!iters) @@ -1031,8 +980,8 @@ play_it_again: sv_magic(TARG, (SV*)0, 'g', Nullch, 0); mg = mg_find(TARG, 'g'); } - if (rx->startp[0]) { - mg->mg_len = rx->endp[0] - rx->subbeg; + if (rx->startp[0] != -1) { + mg->mg_len = rx->endp[0]; if (rx->startp[0] == rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else @@ -1043,39 +992,41 @@ play_it_again: RETPUSHYES; } -yup: /* Confirmed by check_substr */ +yup: /* Confirmed by INTUIT */ if (rxtainted) RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); - ++BmUSEFUL(rx->check_substr); PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) pm->op_pmdynflags |= PMdf_USED; - Safefree(rx->subbase); - rx->subbase = Nullch; + if (RX_MATCH_COPIED(rx)) + Safefree(rx->subbeg); + RX_MATCH_COPIED_off(rx); + rx->subbeg = Nullch; if (global) { rx->subbeg = truebase; - rx->subend = strend; - rx->startp[0] = s; - rx->endp[0] = s + SvCUR(rx->check_substr); + rx->startp[0] = s - truebase; + rx->endp[0] = s - truebase + rx->minlen; + rx->sublen = strend - truebase; goto gotcha; - } + } if (PL_sawampersand) { - char *tmps; + I32 off; - tmps = rx->subbase = savepvn(t, strend-t); - rx->subbeg = tmps; - rx->subend = tmps + (strend-t); - tmps = rx->startp[0] = tmps + (s - t); - rx->endp[0] = tmps + SvCUR(rx->check_substr); + rx->subbeg = savepvn(t, strend - t); + rx->sublen = strend - t; + RX_MATCH_COPIED_on(rx); + off = rx->startp[0] = s - t; + rx->endp[0] = off + rx->minlen; + } + else { /* startp/endp are used by @- @+. */ + rx->startp[0] = s - truebase; + rx->endp[0] = s - truebase + rx->minlen; } LEAVE_SCOPE(oldsave); RETPUSHYES; nope: - if (rx->check_substr) - ++BmUSEFUL(rx->check_substr); - ret_no: if (global && !(pm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { @@ -1091,7 +1042,7 @@ ret_no: } OP * -do_readline(void) +Perl_do_readline(pTHX) { dSP; dTARGETSTACKED; register SV *sv; @@ -1108,7 +1059,7 @@ do_readline(void) XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); PUTBACK; ENTER; - perl_call_method("READLINE", gimme); + call_method("READLINE", gimme); LEAVE; SPAGAIN; if (gimme == G_SCALAR) @@ -1266,11 +1217,30 @@ do_readline(void) } else if (type == OP_GLOB) SP--; + else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */ + && (IoTYPE(io) == '>' || fp == PerlIO_stdout() + || fp == PerlIO_stderr())) + { + SV* sv = sv_newmortal(); + gv_efullname3(sv, PL_last_in_gv, Nullch); + Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", + SvPV_nolen(sv)); + } } if (!fp) { - if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) - warner(WARN_CLOSED, - "Read on closed filehandle <%s>", GvENAME(PL_last_in_gv)); + if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { + if (type == OP_GLOB) + Perl_warner(aTHX_ WARN_CLOSED, + "glob failed (can't start child: %s)", + Strerror(errno)); + else { + SV* sv = sv_newmortal(); + gv_efullname3(sv, PL_last_in_gv, Nullch); + Perl_warner(aTHX_ WARN_CLOSED, + "Read on closed filehandle %s", + SvPV_nolen(sv)); + } + } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; @@ -1317,7 +1287,7 @@ do_readline(void) } else if (type == OP_GLOB) { if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) { - warner(WARN_CLOSED, + Perl_warner(aTHX_ WARN_CLOSED, "glob failed (child exited with status %d%s)", STATUS_CURRENT >> 8, (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); @@ -1351,7 +1321,7 @@ do_readline(void) if (!isALPHA(*tmps) && !isDIGIT(*tmps) && strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) break; - if (*tmps && PerlLIO_stat(SvPVX(sv), &PL_statbuf) < 0) { + if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } @@ -1414,7 +1384,7 @@ PP(pp_helem) } else if (SvTYPE(hv) == SVt_PVAV) { if (PL_op->op_private & OPpLVAL_INTRO) - DIE("Can't localize pseudo-hash element"); + DIE(aTHX_ "Can't localize pseudo-hash element"); svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0); } else { @@ -1426,7 +1396,7 @@ PP(pp_helem) SV* key2; if (!defer) { STRLEN n_a; - DIE(PL_no_helem, SvPV(keysv, n_a)); + DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); @@ -1526,7 +1496,7 @@ PP(pp_iter) EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; if (CxTYPE(cx) != CXt_LOOP) - DIE("panic: pp_iter"); + DIE(aTHX_ "panic: pp_iter"); av = cx->blk_loop.iterary; if (SvTYPE(av) != SVt_PVAV) { @@ -1656,7 +1626,7 @@ PP(pp_subst) if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); PUTBACK; s = SvPV(TARG, len); @@ -1670,7 +1640,7 @@ PP(pp_subst) force_it: if (!pm || !s) - DIE("panic: do_subst"); + DIE(aTHX_ "panic: do_subst"); strend = s + len; maxiters = 2*(strend - s) + 10; /* We can match twice at each @@ -1683,55 +1653,26 @@ PP(pp_subst) } r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) ? REXEC_COPY_STR : 0; - if (SvSCREAM(TARG) && rx->check_substr - && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) + if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } orig = m = s; - if (rx->check_substr) { - if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */ - if (r_flags & REXEC_SCREAM) { - I32 p = -1; - char *b; - - if (PL_screamfirst[BmRARE(rx->check_substr)] < 0) - goto nope; - - b = (char*)HOP((U8*)s, rx->check_offset_min); - if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0))) - goto nope; - } - else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), - (unsigned char*)strend, - rx->check_substr, 0))) - goto nope; - if (s && rx->check_offset_max < s - m) { - ++BmUSEFUL(rx->check_substr); - s = (char*)HOP((U8*)s, -rx->check_offset_max); - } - else - s = m; - } - /* Now checkstring is fixed, i.e. at fixed offset from the - beginning of match, and the match is anchored at s. */ - else if (!PL_multiline) { /* Anchored at beginning of string. */ - I32 slen; - char *b = (char*)HOP((U8*)s, rx->check_offset_min); - if (*SvPVX(rx->check_substr) != *b - || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), b, slen))) - goto nope; - } - if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0 - && rx->check_substr == rx->float_substr) { - SvREFCNT_dec(rx->check_substr); - rx->check_substr = Nullsv; /* opt is being useless */ - rx->float_substr = Nullsv; - } + if (rx->reganch & RE_USE_INTUIT) { + s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + + if (!s) + goto nope; + /* How to do it in subst? */ +/* if ( (rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand + && ((rx->reganch & ROPT_NOSCAN) + || !((rx->reganch & RE_INTUIT_TAIL) + && (r_flags & REXEC_SCREAM)))) + goto yup; +*/ } /* only replace once? */ @@ -1743,7 +1684,9 @@ PP(pp_subst) /* can do inplace substitution? */ if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { - if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) { + if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { SPAGAIN; PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); @@ -1759,13 +1702,8 @@ PP(pp_subst) SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { rxtainted |= RX_MATCH_TAINTED(rx); - if (rx->subbase) { - m = orig + (rx->startp[0] - rx->subbase); - d = orig + (rx->endp[0] - rx->subbase); - } else { - m = rx->startp[0]; - d = rx->endp[0]; - } + m = orig + rx->startp[0]; + d = orig + rx->endp[0]; s = orig; if (m - s > strend - d) { /* faster to shorten from end */ if (clen) { @@ -1806,9 +1744,9 @@ PP(pp_subst) else { do { if (iters++ > maxiters) - DIE("Substitution loop"); + DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); - m = rx->startp[0]; + m = rx->startp[0] + orig; /*SUPPRESS 560*/ if (i = m - s) { if (s != d) @@ -1819,9 +1757,11 @@ PP(pp_subst) Copy(c, d, clen, char); d += clen; } - s = rx->endp[0]; - } while (CALLREGEXEC(rx, s, strend, orig, s == m, - Nullsv, NULL, 0)); /* don't match same null twice */ + s = rx->endp[0] + orig; + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + TARG, NULL, + /* don't match same null twice */ + REXEC_NOT_FIRST|REXEC_IGNOREPOS)); if (s != d) { i = strend - s; SvCUR_set(TARG, d - SvPVX(TARG) + i); @@ -1843,7 +1783,9 @@ PP(pp_subst) RETURN; } - if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) { + if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); @@ -1859,26 +1801,26 @@ PP(pp_subst) PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } - r_flags |= REXEC_IGNOREPOS; + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; do { if (iters++ > maxiters) - DIE("Substitution loop"); + DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); - if (rx->subbase && rx->subbase != orig) { + if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; - orig = rx->subbase; + orig = rx->subbeg; s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0]; + m = rx->startp[0] + orig; sv_catpvn(dstr, s, m-s); - s = rx->endp[0]; + s = rx->endp[0] + orig; if (clen) sv_catpvn(dstr, c, clen); if (once) break; - } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags)); + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); @@ -1903,8 +1845,6 @@ PP(pp_subst) goto ret_no; nope: - ++BmUSEFUL(rx->check_substr); - ret_no: SPAGAIN; PUSHs(&PL_sv_no); @@ -2005,7 +1945,7 @@ PP(pp_leavesub) } STATIC CV * -get_db_sub(SV **svp, CV *cv) +S_get_db_sub(pTHX_ SV **svp, CV *cv) { dTHR; SV *dbsv = GvSV(PL_DBsub); @@ -2051,7 +1991,7 @@ PP(pp_entersub) bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; if (!sv) - DIE("Not a CODE reference"); + DIE(aTHX_ "Not a CODE reference"); switch (SvTYPE(sv)) { default: if (!SvROK(sv)) { @@ -2070,10 +2010,10 @@ PP(pp_entersub) else sym = SvPV(sv, n_a); if (!sym) - DIE(PL_no_usym, "a subroutine"); + DIE(aTHX_ PL_no_usym, "a subroutine"); if (PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_symref, sym, "a subroutine"); - cv = perl_get_cv(sym, TRUE); + DIE(aTHX_ PL_no_symref, sym, "a subroutine"); + cv = get_cv(sym, TRUE); break; } { @@ -2086,13 +2026,18 @@ PP(pp_entersub) /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: - DIE("Not a CODE reference"); + DIE(aTHX_ "Not a CODE reference"); case SVt_PVCV: cv = (CV*)sv; break; case SVt_PVGV: if (!(cv = GvCVu((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, TRUE); + cv = sv_2cv(sv, &stash, &gv, FALSE); + if (!cv) { + ENTER; + SAVETMPS; + goto try_autoload; + } break; } @@ -2100,39 +2045,44 @@ PP(pp_entersub) SAVETMPS; retry: - if (!cv) - DIE("Not a CODE reference"); - if (!CvROOT(cv) && !CvXSUB(cv)) { GV* autogv; SV* sub_name; /* anonymous or undef'd function leaves us no recourse */ if (CvANON(cv) || !(gv = CvGV(cv))) - DIE("Undefined subroutine called"); + DIE(aTHX_ "Undefined subroutine called"); + /* autoloaded stub? */ if (cv != GvCV(gv)) { cv = GvCV(gv); - goto retry; } /* should call AUTOLOAD now? */ - if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + else { +try_autoload: + if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) - { - cv = GvCV(autogv); - goto retry; + { + cv = GvCV(autogv); + } + /* sorry */ + else { + sub_name = sv_newmortal(); + gv_efullname3(sub_name, gv, Nullch); + DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name)); + } } - /* sorry */ - sub_name = sv_newmortal(); - gv_efullname3(sub_name, gv, Nullch); - DIE("Undefined subroutine &%s called", SvPVX(sub_name)); + if (!cv) + DIE(aTHX_ "Not a CODE reference"); + goto retry; } gimme = GIMME_V; - if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) + if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { cv = get_db_sub(&sv, cv); - if (!cv) - DIE("No DBsub routine"); + if (!cv) + DIE(aTHX_ "No DBsub routine"); + } #ifdef USE_THREADS /* @@ -2154,7 +2104,7 @@ PP(pp_entersub) || !(sv = AvARRAY(av)[0])) { MUTEX_UNLOCK(CvMUTEXP(cv)); - croak("no argument for locked method call"); + Perl_croak(aTHX_ "no argument for locked method call"); } } if (SvROK(sv)) @@ -2180,7 +2130,7 @@ PP(pp_entersub) DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", thr, sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - save_destructor(unlock_condpair, sv); + SAVEDESTRUCTOR(Perl_unlock_condpair, sv); } MUTEX_LOCK(CvMUTEXP(cv)); } @@ -2268,8 +2218,9 @@ PP(pp_entersub) #endif /* USE_THREADS */ if (CvXSUB(cv)) { +#ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { - I32 (*fp3)_((int,int,int)); + I32 (*fp3)(int,int,int); dMARK; register I32 items = SP - MARK; /* We dont worry to copy from @_. */ @@ -2278,13 +2229,15 @@ PP(pp_entersub) SP--; } PL_stack_sp = mark + 1; - fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); + fp3 = (I32(*)(int,int,int)))CvXSUB(cv; items = (*fp3)(CvXSUBANY(cv).any_i32, MARK - PL_stack_base + 1, items); PL_stack_sp = PL_stack_base + items; } - else { + else +#endif /* PERL_XSUB_OLDSTYLE */ + { I32 markix = TOPMARK; PUTBACK; @@ -2310,15 +2263,14 @@ PP(pp_entersub) PUTBACK ; } } - if (PL_curcopdb) { /* We assume that the first - XSUB in &DB::sub is the - called one. */ + /* We assume first XSUB in &DB::sub is the called one. */ + if (PL_curcopdb) { SAVESPTR(PL_curcop); PL_curcop = PL_curcopdb; PL_curcopdb = NULL; } /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS); + (void)(*CvXSUB(cv))(aTHXo_ cv); /* Enforce some sanity in scalar context. */ if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { @@ -2464,14 +2416,14 @@ PP(pp_entersub) } void -sub_crush_depth(CV *cv) +Perl_sub_crush_depth(pTHX_ CV *cv) { if (CvANON(cv)) - warner(WARN_RECURSION, "Deep recursion on anonymous subroutine"); + Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"", + Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); } } @@ -2495,7 +2447,7 @@ PP(pp_aelem) if (!svp || *svp == &PL_sv_undef) { SV* lv; if (!defer) - DIE(PL_no_aelem, elem); + DIE(aTHX_ PL_no_aelem, elem); lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; @@ -2519,13 +2471,13 @@ PP(pp_aelem) } void -vivify_ref(SV *sv, U32 to_what) +Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) { if (SvGMAGICAL(sv)) mg_get(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); else if (SvTYPE(sv) >= SVt_PV) { @@ -2590,7 +2542,7 @@ PP(pp_method) : !isIDFIRST(*packname) )) { - DIE("Can't call method \"%s\" %s", name, + DIE(aTHX_ "Can't call method \"%s\" %s", name, SvOK(sv)? "without a package or object reference" : "on an undefined value"); } @@ -2601,7 +2553,7 @@ PP(pp_method) } if (!ob || !SvOBJECT(ob)) - DIE("Can't call method \"%s\" on unblessed reference", name); + DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name); stash = SvSTASH(ob); @@ -2626,10 +2578,31 @@ PP(pp_method) packname = name; packlen = sep - name; } - DIE("Can't locate object method \"%s\" via package \"%.*s\"", + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", leaf, (int)packlen, packname); } SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); RETURN; } +#ifdef USE_THREADS +static void +unset_cvowner(pTHXo_ void *cvarg) +{ + register CV* cv = (CV *) cvarg; +#ifdef DEBUGGING + dTHR; +#endif /* DEBUGGING */ + + DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", + thr, cv, SvPEEK((SV*)cv)))); + MUTEX_LOCK(CvMUTEXP(cv)); + DEBUG_S(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); + assert(thr == CvOWNER(cv)); + CvOWNER(cv) = 0; + MUTEX_UNLOCK(CvMUTEXP(cv)); + SvREFCNT_dec(cv); +} +#endif /* USE_THREADS */