X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=5103efb21537ee635765ff1c44e5785d9f8e753f;hb=08d0d8ab11be611f4baf746cfb6ff7791962f494;hp=11e940b342fde6114e10f20905ef6ff4e4b78931;hpb=aac018bb00282d5a72a5c5b4d95935b9eb667bcc;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index 11e940b..5103efb 100644
--- a/op.c
+++ b/op.c
@@ -785,8 +785,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 +817,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 +1205,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 +1293,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 +1766,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 +2152,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 +2338,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 +2425,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 +2566,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 +2980,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 +3118,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 +3442,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
@@ -5802,7 +5802,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        pp_entereval that it should not throw away any saved lines at scope
        exit.  */
        
-    PL_breakable_sub_generation++;
+    PL_breakable_sub_gen++;
     if (CvLVALUE(cv)) {
 	CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
 			     mod(scalarseq(block), OP_LEAVESUBLV));
@@ -5958,14 +5958,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;
 
@@ -5993,10 +5990,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)
@@ -7635,14 +7632,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;
 }