provisional MakeMaker patch for VMS

[p5sagit/p5-mst-13.2.git] / regcomp.c

diff --git a/regcomp.c b/regcomp.c
index 53d8947..b5d9860 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -1690,17 +1690,15 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     if (exp == NULL)
        FAIL("NULL regexp argument");
 
-    /* XXXX This looks very suspicious... */
-    if (pm->op_pmdynflags & PMdf_CMP_UTF8)
-        RExC_utf8 = 1;
-    else
-        RExC_utf8 = 0;
+    RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
 
     RExC_precomp = exp;
-    DEBUG_r(if (!PL_colorset) reginitcolors());
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
-                     PL_colors[4],PL_colors[5],PL_colors[0],
-                     (int)(xend - exp), RExC_precomp, PL_colors[1]));
+    DEBUG_r({
+        if (!PL_colorset) reginitcolors();
+        PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
+                      PL_colors[4],PL_colors[5],PL_colors[0],
+                      (int)(xend - exp), RExC_precomp, PL_colors[1]);
+    });
     RExC_flags16 = pm->op_pmflags;
     RExC_sawback = 0;
 
@@ -3019,6 +3017,8 @@ tryagain:
                case '\\':
                    switch (*++p) {
                    case 'A':
+                   case 'C':
+                   case 'X':
                    case 'G':
                    case 'Z':
                    case 'z':
@@ -3131,7 +3131,7 @@ tryagain:
                if (RExC_flags16 & PMf_EXTENDED)
                    p = regwhite(p, RExC_end);
                if (UTF && FOLD) {
-                   toLOWER_uni(ender, tmpbuf, &ulen);
+                   toFOLD_uni(ender, tmpbuf, &ulen);
                    ender = utf8_to_uvchr(tmpbuf, 0);
                }
                if (ISMULT2(p)) { /* Back off on ?+*. */
@@ -3180,20 +3180,26 @@ tryagain:
        break;
     }
 
-    if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT && !RExC_utf8) {
+    if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) {
         STRLEN oldlen = STR_LEN(ret);
         SV *sv        = sv_2mortal(newSVpvn(STRING(ret), oldlen));
-        char *s       = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
-        STRLEN newlen = SvCUR(sv);
-        if (!SIZE_ONLY) {
-             DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
-                                   (int)oldlen, STRING(ret), (int)newlen, s));
-             Copy(s, STRING(ret), newlen, char);
-             STR_LEN(ret) += newlen - oldlen;
-             RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
-        } else
-             RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
-        RExC_utf8 = 1;
+
+        if (RExC_utf8)
+             SvUTF8_on(sv);
+        if (sv_utf8_downgrade(sv, TRUE)) {
+             char *s       = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
+             STRLEN newlen = SvCUR(sv);
+        
+             if (!SIZE_ONLY) {
+                  DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
+                                        (int)oldlen, STRING(ret),
+                                        (int)newlen, s));
+                  Copy(s, STRING(ret), newlen, char);
+                  STR_LEN(ret) += newlen - oldlen;
+                  RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
+             } else
+                  RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
+        }
     }
 
     return(ret);
@@ -3967,17 +3973,29 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state)
                }
                else
 #endif
-                   for (i = prevvalue; i <= ceilvalue; i++)
-                       ANYOF_BITMAP_SET(ret, i);
+                     for (i = prevvalue; i <= ceilvalue; i++)
+                         ANYOF_BITMAP_SET(ret, i);
          }
-         if (value > 255) {
+         if (value > 255 || UTF) {
                ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
                if (prevvalue < value)
                    Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
                                   (UV)prevvalue, (UV)value);
-               else if (prevvalue == value)
+               else if (prevvalue == value) {
                    Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
                                   (UV)value);
+                   if (FOLD) {
+                        if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
+                             Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
+                                            (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
+                             Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
+                                            (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
+                        }
+                        else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
+                             Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
+                                            (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
+                   }
+               }
            }
         }