Change \p{} matching for above-Unicode code points

[perl5.git] / regexec.c

diff --git a/regexec.c b/regexec.c
index acca274..fdaa537 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -1489,7 +1489,6 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
     switch (OP(c)) {
     case ANYOF:
     case ANYOF_SYNTHETIC:
-    case ANYOF_WARN_SUPER:
         if (utf8_target) {
             REXEC_FBC_UTF8_CLASS_SCAN(
                       reginclass(prog, c, (U8*)s, utf8_target));
@@ -2283,7 +2282,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
             : strbeg; /* pos() not defined; use start of string */
 
         DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
-            "GPOS ganch set to strbeg[%"IVdf"]\n", reginfo->ganch - strbeg));
+            "GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg)));
 
         /* in the presence of \G, we may need to start looking earlier in
          * the string than the suggested start point of stringarg:
@@ -2409,7 +2408,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
            Not newSVsv, either, as it does not COW.
         */
         reginfo->sv = newSV(0);
-        sv_setsv(reginfo->sv, sv);
+        SvSetSV_nosteal(reginfo->sv, sv);
         SAVEFREESV(reginfo->sv);
     }
 
@@ -4386,7 +4385,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
            break;
 
        case ANYOF:  /*  /[abc]/       */
-       case ANYOF_WARN_SUPER:
             if (NEXTCHR_IS_EOS)
                 sayNO;
            if (utf8_target) {
@@ -5103,20 +5101,22 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                else {                   /*  /(??{})  */
                    /*  if its overloaded, let the regex compiler handle
                     *  it; otherwise extract regex, or stringify  */
+                   if (SvGMAGICAL(ret))
+                       ret = sv_mortalcopy(ret);
                    if (!SvAMAGIC(ret)) {
                        SV *sv = ret;
                        if (SvROK(sv))
                            sv = SvRV(sv);
                        if (SvTYPE(sv) == SVt_REGEXP)
                            re_sv = (REGEXP*) sv;
-                       else if (SvSMAGICAL(sv)) {
-                           MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
+                       else if (SvSMAGICAL(ret)) {
+                           MAGIC *mg = mg_find(ret, PERL_MAGIC_qr);
                            if (mg)
                                re_sv = (REGEXP *) mg->mg_obj;
                        }
 
-                       /* force any magic, undef warnings here */
-                       if (!re_sv) {
+                       /* force any undef warnings here */
+                       if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) {
                            ret = sv_mortalcopy(ret);
                            (void) SvPV_force_nolen(ret);
                        }
@@ -5170,17 +5170,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                                     pm_flags);
 
                        if (!(SvFLAGS(ret)
-                             & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
-                                | SVs_GMG))) {
+                             & (SVs_TEMP | SVs_GMG | SVf_ROK))
+                        && (!SvPADTMP(ret) || SvREADONLY(ret))) {
                            /* This isn't a first class regexp. Instead, it's
                               caching a regexp onto an existing, Perl visible
                               scalar.  */
                            sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0);
                        }
-                       /* safe to do now that any $1 etc has been
-                        * interpolated into the new pattern string and
-                        * compiled */
-                       S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
                    }
                    SAVEFREESV(re_sv);
                    re = ReANY(re_sv);
@@ -7003,7 +6999,6 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p,
        break;
     }
     case ANYOF:
-    case ANYOF_WARN_SUPER:
        if (utf8_target) {
            while (hardcount < max
                    && scan < loceol
@@ -7450,13 +7445,12 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const
            match = TRUE;
        }
        else if (flags & ANYOF_LOCALE) {
-           RXp_MATCH_TAINTED_on(prog);
-
-           if ((flags & ANYOF_LOC_FOLD)
-                && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
-           {
-               match = TRUE;
-           }
+           if (flags & ANYOF_LOC_FOLD) {
+                RXp_MATCH_TAINTED_on(prog);
+                if (ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) {
+                    match = TRUE;
+                }
+            }
            else if (ANYOF_POSIXL_TEST_ANY_SET(n)) {
 
                 /* The data structure is arranged so bits 0, 2, 4, ... are set
@@ -7491,6 +7485,8 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const
 
                 int count = 0;
                 int to_complement = 0;
+
+                RXp_MATCH_TAINTED_on(prog);
                 while (count < ANYOF_MAX) {
                     if (ANYOF_POSIXL_TEST(n, count)
                         && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c)))
@@ -7545,16 +7541,22 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const
        }
 
         if (UNICODE_IS_SUPER(c)
-            && OP(n) == ANYOF_WARN_SUPER
+            && (flags & ANYOF_WARN_SUPER)
             && ckWARN_d(WARN_NON_UNICODE))
         {
             Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
-                "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", c);
+                "Matched non-Unicode code point 0x%04"UVXf" against Unicode property; may not be portable", c);
         }
     }
 
+#if ANYOF_INVERT != 1
+    /* Depending on compiler optimization cBOOL takes time, so if don't have to
+     * use it, don't */
+#   error ANYOF_INVERT needs to be set to 1, or guarded with cBOOL below,
+#endif
+
     /* The xor complements the return if to invert: 1^1 = 0, 1^0 = 1 */
-    return cBOOL(flags & ANYOF_INVERT) ^ match;
+    return (flags & ANYOF_INVERT) ^ match;
 }
 
 STATIC U8 *