[perl #23769] Unicode regex broken on simple example

[perl5.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index 416eba5..0ad2fcf 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -795,7 +795,6 @@ PP(pp_rv2hv)
 {
     dSP; dTOPss;
     HV *hv;
-    I32 gimme = GIMME_V;
 
     if (SvROK(sv)) {
       wasref:
@@ -1235,7 +1234,7 @@ PP(pp_match)
     if (SvSCREAM(TARG))
        r_flags |= REXEC_SCREAM;
 
-    if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+    if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
@@ -1407,7 +1406,7 @@ yup:                                      /* Confirmed by INTUIT */
        rx->startp[0] = s - truebase;
        rx->endp[0] = s - truebase + rx->minlen;
     }
-    rx->nparens = rx->lastparen = 0;   /* used by @- and @+ */
+    rx->nparens = rx->lastparen = rx->lastcloseparen = 0;      /* used by @-, @+, and $^N */
     LEAVE_SCOPE(oldsave);
     RETPUSHYES;
 
@@ -1498,7 +1497,7 @@ Perl_do_readline(pTHX)
            /* undef TARG, and push that undefined value */
            if (type != OP_RCATLINE) {
                SV_CHECK_THINKFIRST_COW_DROP(TARG);
-               SvOK_off(TARG);
+               (void)SvOK_off(TARG);
            }
            PUSHTARG;
        }
@@ -1562,7 +1561,7 @@ Perl_do_readline(pTHX)
            if (gimme == G_SCALAR) {
                if (type != OP_RCATLINE) {
                    SV_CHECK_THINKFIRST_COW_DROP(TARG);
-                   SvOK_off(TARG);
+                   (void)SvOK_off(TARG);
                }
                SPAGAIN;
                PUSHTARG;
@@ -1594,6 +1593,17 @@ Perl_do_readline(pTHX)
                (void)POPs;             /* Unmatched wildcard?  Chuck it... */
                continue;
            }
+       } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
+            U8 *s = (U8*)SvPVX(sv) + offset;
+            STRLEN len = SvCUR(sv) - offset;
+            U8 *f;
+            
+            if (ckWARN(WARN_UTF8) &&
+                !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
+                 /* Emulate :encoding(utf8) warning in the same case. */
+                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                             "utf8 \"\\x%02X\" does not map to Unicode",
+                             f < (U8*)SvEND(sv) ? *f : 0);
        }
        if (gimme == G_ARRAY) {
            if (SvLEN(sv) - SvCUR(sv) > 20) {
@@ -1980,7 +1990,7 @@ PP(pp_subst)
               ? REXEC_COPY_STR : 0;
     if (SvSCREAM(TARG))
        r_flags |= REXEC_SCREAM;
-    if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+    if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
@@ -2292,6 +2302,7 @@ PP(pp_leavesub)
     SV *sv;
 
     POPBLOCK(cx,newpm);
+    cxstack_ix++; /* temporarily protect top context */
 
     TAINT_NOT;
     if (gimme == G_SCALAR) {
@@ -2330,6 +2341,7 @@ PP(pp_leavesub)
     PUTBACK;
 
     LEAVE;
+    cxstack_ix--;
     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;  /* ... and pop $1 et al */
 
@@ -2350,6 +2362,7 @@ PP(pp_leavesublv)
     SV *sv;
 
     POPBLOCK(cx,newpm);
+    cxstack_ix++; /* temporarily protect top context */
 
     TAINT_NOT;
 
@@ -2386,6 +2399,7 @@ PP(pp_leavesublv)
         * TEMP, so sv_2mortal is out of question. */
        if (!CvLVALUE(cx->blk_sub.cv)) {
            LEAVE;
+           cxstack_ix--;
            POPSUB(cx,sv);
            PL_curpm = newpm;
            LEAVESUB(sv);
@@ -2397,6 +2411,7 @@ PP(pp_leavesublv)
            if (MARK == SP) {
                if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
                    LEAVE;
+                   cxstack_ix--;
                    POPSUB(cx,sv);
                    PL_curpm = newpm;
                    LEAVESUB(sv);
@@ -2412,6 +2427,7 @@ PP(pp_leavesublv)
            }
            else {                      /* Should not happen? */
                LEAVE;
+               cxstack_ix--;
                POPSUB(cx,sv);
                PL_curpm = newpm;
                LEAVESUB(sv);
@@ -2428,6 +2444,7 @@ PP(pp_leavesublv)
                    /* Might be flattened array after $#array =  */
                    PUTBACK;
                    LEAVE;
+                   cxstack_ix--;
                    POPSUB(cx,sv);
                    PL_curpm = newpm;
                    LEAVESUB(sv);
@@ -2482,6 +2499,7 @@ PP(pp_leavesublv)
     PUTBACK;
 
     LEAVE;
+    cxstack_ix--;
     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;  /* ... and pop $1 et al */
 
@@ -3025,7 +3043,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
            /* the method name is unqualified or starts with SUPER:: */ 
            packname = sep ? CopSTASHPV(PL_curcop) :
                stash ? HvNAME(stash) : packname;
-           packlen = strlen(packname);
+           if (!packname)
+               Perl_croak(aTHX_
+                          "Can't use anonymous symbol table for method lookup");
+           else
+               packlen = strlen(packname);
        }
        else {
            /* the method name is qualified */