X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=78f07a17f30ba4186ae0f8ec8b0bb725ba33288d;hb=b0ce926a45891e83ffb4badae874161f93c0eb49;hp=36a33ff04d39cd0b3479a8ae1bbffb75e917b395;hpb=864dbfa3ca8032ef66f7aa86961933b19b962357;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index 36a33ff..78f07a1 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -34,25 +34,7 @@
 /* Hot code. */
 
 #ifdef USE_THREADS
-STATIC void
-unset_cvowner(pTHX_ 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)
@@ -87,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);
@@ -142,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)
@@ -212,7 +200,7 @@ PP(pp_readline)
 	    dSP;
 	    XPUSHs((SV*)PL_last_in_gv);
 	    PUTBACK;
-	    pp_rv2gv(ARGS);
+	    pp_rv2gv();
 	    PL_last_in_gv = (GV*)(*PL_stack_sp--);
 	}
     }
@@ -233,7 +221,7 @@ PP(pp_preinc)
 {
     djSP;
     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
     	SvIVX(TOPs) != IV_MAX)
     {
@@ -350,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;
@@ -426,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;
@@ -455,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;
@@ -474,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);
 		}
 	    }
@@ -526,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;
@@ -555,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;
@@ -574,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);
 		}
 	    }
@@ -593,15 +582,21 @@ 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);
+#ifdef IV_IS_QUAD
 	if (HvFILL(hv))
-	    sv_setpvf(TARG, "%ld/%ld",
-		      (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+            Perl_sv_setpvf(aTHX_ TARG, "%" PERL_PRId64 "/%" PERL_PRId64,
+                      (Quad_t)HvFILL(hv), (Quad_t)HvMAX(hv) + 1);
+#else
+	if (HvFILL(hv))
+            Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
+                      (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+#endif
 	else
 	    sv_setiv(TARG, 0);
 	
@@ -711,9 +706,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);
@@ -767,13 +762,13 @@ 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 */
 #endif /* HAS_SETRESUID */
-	    PL_uid = (int)PerlProc_getuid();
-	    PL_euid = (int)PerlProc_geteuid();
+	    PL_uid = PerlProc_getuid();
+	    PL_euid = PerlProc_geteuid();
 	}
 	if (PL_delaymagic & DM_GID) {
 #ifdef HAS_SETRESGID
@@ -796,13 +791,13 @@ 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 */
 #endif /* HAS_SETRESGID */
-	    PL_gid = (int)PerlProc_getgid();
-	    PL_egid = (int)PerlProc_getegid();
+	    PL_gid = PerlProc_getgid();
+	    PL_egid = PerlProc_getegid();
 	}
 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
     }
@@ -846,10 +841,8 @@ PP(pp_match)
     register char *s;
     char *strend;
     I32 global;
-    I32 r_flags = 0;
-    char *truebase;			/* Start of string, may be
-					   relocated if REx engine
-					   copies the string.  */
+    I32 r_flags = REXEC_CHECKED;
+    char *truebase;			/* Start of string  */
     register REGEXP *rx = pm->op_pmregexp;
     bool rxtainted;
     I32 gimme = GIMME;
@@ -869,7 +862,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;
@@ -909,9 +902,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)) {
@@ -927,78 +918,19 @@ play_it_again:
 	if (update_minmatch++)
 	    minmatch = had_zerolen;
     }
-    if (rx->check_substr) {
-	if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
-	    SV *c = rx->check_substr;
+    if (rx->reganch & RE_USE_INTUIT) {
+	s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
 
-	    if (r_flags & REXEC_SCREAM) {
-		I32 p = -1;
-		char *b;
-
-		if (PL_screamfirst[BmRARE(c)] < 0
-		    && !( BmRARE(c) == '\n' && (BmPREVIOUS(c) == SvCUR(c) - 1)
-			  && SvTAIL(c) ))
-		    goto nope;
-
-		b = (char*)HOP((U8*)s, rx->check_offset_min);
-		if (!(s = screaminstr(TARG, c, b - s, 0, &p, 0)))
-		    goto nope;
-
-		if ((rx->reganch & ROPT_CHECK_ALL)
-			 && !PL_sawampersand && !SvTAIL(c))
-		    goto yup;
-	    }
-	    else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
-				     (unsigned char*)strend, c, 
-				     PL_multiline ? FBMrf_MULTILINE : 0)))
-		goto nope;
-	    else if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
-		goto yup;
-	    if (s && rx->check_offset_max < s - t) {
-		++BmUSEFUL(c);
-		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 (SvTAIL(rx->check_substr)) {
-		slen = SvCUR(rx->check_substr);	/* >= 1 */
-
-		if ( strend - b > slen || strend - b < slen - 1 )
-		    goto nope;
-		if ( strend - b == slen && strend[-1] != '\n')
-		    goto nope;
-		/* Now should match b[0..slen-2] */
-		slen--;
-		if (slen && (*SvPVX(rx->check_substr) != *b
-			     || (slen > 1
-				 && memNE(SvPVX(rx->check_substr), b, slen))))
-		    goto nope;
-		if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
-		    goto yup;
-	    } else {			/* Assume len > 0 */
-		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_CHECK_ALL) && !PL_sawampersand)
-		    goto yup;
-	    }
-	}
-	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 (!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)
@@ -1066,11 +998,10 @@ 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;
@@ -1081,7 +1012,7 @@ yup:					/* Confirmed by check_substr */
     if (global) {
 	rx->subbeg = truebase;
 	rx->startp[0] = s - truebase;
-	rx->endp[0] = s - truebase + SvCUR(rx->check_substr);
+	rx->endp[0] = s - truebase + rx->minlen;
 	rx->sublen = strend - truebase;
 	goto gotcha;
     } 
@@ -1092,19 +1023,16 @@ yup:					/* Confirmed by check_substr */
 	rx->sublen = strend - t;
 	RX_MATCH_COPIED_on(rx);
 	off = rx->startp[0] = s - t;
-	rx->endp[0] = off + SvCUR(rx->check_substr);
+	rx->endp[0] = off + rx->minlen;
     }
     else {			/* startp/endp are used by @- @+. */
 	rx->startp[0] = s - truebase;
-	rx->endp[0] = s - truebase + SvCUR(rx->check_substr);
+	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)) {
@@ -1265,15 +1193,9 @@ Perl_do_readline(pTHX)
 		sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
 		sv_catsv(tmpcmd, tmpglob);
 #else
-#ifdef CYGWIN32
-		sv_setpv(tmpcmd, "for a in ");
-		sv_catsv(tmpcmd, tmpglob);
-		sv_catpv(tmpcmd, "; do echo -e \"$a\\0\\c\"; done |");
-#else
 		sv_setpv(tmpcmd, "perlglob ");
 		sv_catsv(tmpcmd, tmpglob);
 		sv_catpv(tmpcmd, " |");
-#endif /* !CYGWIN */
 #endif /* !DJGPP */
 #endif /* !OS2 */
 #else /* !DOSISH */
@@ -1301,15 +1223,29 @@ Perl_do_readline(pTHX)
 	}
 	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)) {
 	    if (type == OP_GLOB)
-		warner(WARN_CLOSED, "glob failed (can't start child: %s)",
-		       Strerror(errno));
-	    else
-		warner(WARN_CLOSED, "Read on closed filehandle <%s>",
-		       GvENAME(PL_last_in_gv));
+		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);
@@ -1357,7 +1293,7 @@ Perl_do_readline(pTHX)
 	    }
 	    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" : "");
@@ -1454,7 +1390,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 {
@@ -1466,7 +1402,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);
@@ -1566,7 +1502,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) {
@@ -1696,7 +1632,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);
@@ -1710,7 +1646,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 
@@ -1723,56 +1659,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, 
-				     PL_multiline ? FBMrf_MULTILINE : 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? */
@@ -1784,7 +1690,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);
@@ -1842,7 +1750,7 @@ PP(pp_subst)
 	else {
 	    do {
 		if (iters++ > maxiters)
-		    DIE("Substitution loop");
+		    DIE(aTHX_ "Substitution loop");
 		rxtainted |= RX_MATCH_TAINTED(rx);
 		m = rx->startp[0] + orig;
 		/*SUPPRESS 560*/
@@ -1856,8 +1764,10 @@ PP(pp_subst)
 		    d += clen;
 		}
 		s = rx->endp[0] + orig;
-	    } while (CALLREGEXEC(rx, s, strend, orig, s == m,
-				 Nullsv, NULL, REXEC_NOT_FIRST)); /* don't match same null twice */
+	    } 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);
@@ -1879,7 +1789,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);
@@ -1898,7 +1810,7 @@ PP(pp_subst)
 	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_MATCH_COPIED(rx) && rx->subbeg != orig) {
 		m = s;
@@ -1914,7 +1826,7 @@ PP(pp_subst)
 		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);
@@ -1939,8 +1851,6 @@ PP(pp_subst)
     goto ret_no;
 
 nope:
-    ++BmUSEFUL(rx->check_substr);
-
 ret_no:         
     SPAGAIN;
     PUSHs(&PL_sv_no);
@@ -2041,7 +1951,7 @@ PP(pp_leavesub)
 }
 
 STATIC CV *
-get_db_sub(pTHX_ SV **svp, CV *cv)
+S_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dTHR;
     SV *dbsv = GvSV(PL_DBsub);
@@ -2087,7 +1997,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)) {
@@ -2106,9 +2016,9 @@ 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");
+		DIE(aTHX_ PL_no_symref, sym, "a subroutine");
 	    cv = get_cv(sym, TRUE);
 	    break;
 	}
@@ -2122,7 +2032,7 @@ 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;
@@ -2147,7 +2057,7 @@ PP(pp_entersub)
 
 	/* 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)) {
@@ -2165,11 +2075,11 @@ try_autoload:
 	    else {
 		sub_name = sv_newmortal();
 		gv_efullname3(sub_name, gv, Nullch);
-		DIE("Undefined subroutine &%s called", SvPVX(sub_name));
+		DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
 	    }
 	}
 	if (!cv)
-	    DIE("Not a CODE reference");
+	    DIE(aTHX_ "Not a CODE reference");
 	goto retry;
     }
 
@@ -2177,7 +2087,7 @@ try_autoload:
     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
 	cv = get_db_sub(&sv, cv);
 	if (!cv)
-	    DIE("No DBsub routine");
+	    DIE(aTHX_ "No DBsub routine");
     }
 
 #ifdef USE_THREADS
@@ -2200,7 +2110,7 @@ try_autoload:
 		    || !(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))
@@ -2226,7 +2136,7 @@ try_autoload:
 	    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));
     }
@@ -2366,7 +2276,7 @@ try_autoload:
 		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 ) {
@@ -2515,11 +2425,11 @@ void
 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));
     }
 }
@@ -2543,7 +2453,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';
@@ -2573,7 +2483,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 	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) {
@@ -2600,25 +2510,46 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 PP(pp_method)
 {
     djSP;
+    SV* sv = TOPs;
+
+    if (SvROK(sv)) {
+	SV* rsv = SvRV(sv);
+	if (SvTYPE(rsv) == SVt_PVCV) {
+	    SETs(rsv);
+	    RETURN;
+	}
+    }
+
+    SETs(method_common(sv, Null(U32*)));
+    RETURN;
+}
+
+PP(pp_method_named)
+{
+    djSP;
+    SV* sv = cSVOP->op_sv;
+    U32 hash = SvUVX(sv);
+
+    XPUSHs(method_common(sv, &hash));
+    RETURN;
+}
+
+STATIC SV *
+S_method_common(pTHX_ SV* meth, U32* hashp)
+{
+    djSP;
     SV* sv;
     SV* ob;
     GV* gv;
     HV* stash;
     char* name;
+    STRLEN namelen;
     char* packname;
     STRLEN packlen;
 
-    if (SvROK(TOPs)) {
-	sv = SvRV(TOPs);
-	if (SvTYPE(sv) == SVt_PVCV) {
-	    SETs(sv);
-	    RETURN;
-	}
-    }
-
-    name = SvPV(TOPs, packlen);
+    name = SvPV(meth, namelen);
     sv = *(PL_stack_base + TOPMARK + 1);
-    
+
     if (SvGMAGICAL(sv))
         mg_get(sv);
     if (SvROK(sv))
@@ -2638,9 +2569,9 @@ PP(pp_method)
 		    : !isIDFIRST(*packname)
 		))
 	    {
-		DIE("Can't call method \"%s\" %s", name,
-		    SvOK(sv)? "without a package or object reference"
-			    : "on an undefined value");
+		Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+			   SvOK(sv) ? "without a package or object reference"
+				    : "on an undefined value");
 	    }
 	    stash = gv_stashpvn(packname, packlen, TRUE);
 	    goto fetch;
@@ -2649,11 +2580,23 @@ PP(pp_method)
     }
 
     if (!ob || !SvOBJECT(ob))
-	DIE("Can't call method \"%s\" on unblessed reference", name);
+	Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
+		   name);
 
     stash = SvSTASH(ob);
 
   fetch:
+    /* shortcut for simple names */
+    if (hashp) {
+	HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
+	if (he) {
+	    gv = (GV*)HeVAL(he);
+	    if (isGV(gv) && GvCV(gv) &&
+		(!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
+		return (SV*)GvCV(gv);
+	}
+    }
+
     gv = gv_fetchmethod(stash, name);
     if (!gv) {
 	char* leaf = name;
@@ -2674,10 +2617,31 @@ PP(pp_method)
 	    packname = name;
 	    packlen = sep - name;
 	}
-	DIE("Can't locate object method \"%s\" via package \"%.*s\"",
-	    leaf, (int)packlen, packname);
+	Perl_croak(aTHX_
+		   "Can't locate object method \"%s\" via package \"%s\"",
+		   leaf, packname);
     }
-    SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
-    RETURN;
+    return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }
 
+#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 */