X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regcomp.c;h=aacae22edbb771aaa8a80f34f00408c2eafc02fb;hb=d8f6a7325d6b2ec46e8cdc1ec4b5e1ad4a86abd0;hp=cd3857eb2bdddee6c0701987f8a3960f1d934984;hpb=a72c75842468bcd2a7cf17032844c4040a5a31e2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/regcomp.c b/regcomp.c
index cd3857e..aacae22 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -522,11 +522,8 @@ S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
 STATIC void
 S_cl_anything(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
 {
-    int value;
-
     ANYOF_CLASS_ZERO(cl);
-    for (value = 0; value < 256; ++value)
-	ANYOF_BITMAP_SET(cl, value);
+    ANYOF_BITMAP_SETALL(cl);
     cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
     if (LOC)
 	cl->flags |= ANYOF_LOCALE;
@@ -543,9 +540,8 @@ S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
 	    return 1;
     if (!(cl->flags & ANYOF_UNICODE_ALL))
 	return 0;
-    for (value = 0; value < 256; ++value)
-	if (!ANYOF_BITMAP_TEST(cl, value))
-	    return 0;
+    if (!ANYOF_BITMAP_TESTALLSET(cl))
+	return 0;
     return 1;
 }
 
@@ -662,6 +658,17 @@ S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, str
     }
 }
 
+/*
+ * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
+ * These need to be revisited when a newer toolchain becomes available.
+ */
+#if defined(__sparc64__) && defined(__GNUC__)
+#   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
+#       undef  SPARC64_GCC_WORKAROUND
+#       define SPARC64_GCC_WORKAROUND 1
+#   endif
+#endif
+
 /* REx optimizer.  Converts nodes into quickier variants "in place".
    Finds fixed substrings.  */
 
@@ -1207,11 +1214,28 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, reg
 		    int counted = mincount != 0;
 
 		    if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
+#if defined(SPARC64_GCC_WORKAROUND)
+			I32 b = 0;
+			STRLEN l = 0;
+			char *s = NULL;
+			I32 old = 0;
+
+			if (pos_before >= data->last_start_min)
+			    b = pos_before;
+			else
+			    b = data->last_start_min;
+
+			l = 0;
+			s = SvPV(data->last_found, l);
+			old = b - data->last_start_min;
+
+#else
 			I32 b = pos_before >= data->last_start_min
 			    ? pos_before : data->last_start_min;
 			STRLEN l;
 			char *s = SvPV(data->last_found, l);
 			I32 old = b - data->last_start_min;
+#endif
 
 			if (UTF)
 			    old = utf8_hop((U8*)s, old) - (U8*)s;
@@ -1666,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;
 
@@ -1764,7 +1786,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
     pm->op_pmflags = RExC_flags16;
     if (UTF)
-	r->reganch |= ROPT_UTF8;
+        r->reganch |= ROPT_UTF8;	/* Unicode in it? */
     r->regstclass = NULL;
     if (RExC_naughty >= 10)	/* Probably an expensive pattern. */
 	r->reganch |= ROPT_NAUGHTY;
@@ -2795,6 +2817,7 @@ tryagain:
 	case 'Z':
 	    ret = reg_node(pRExC_state, SEOL);
 	    *flagp |= SIMPLE;
+	    RExC_seen_zerolen++;		/* Do not optimize RE away */
 	    nextchar(pRExC_state);
 	    break;
 	case 'z':
@@ -2962,8 +2985,8 @@ tryagain:
 	    register char *p;
 	    char *oldp, *s;
 	    STRLEN numlen;
-	    STRLEN ulen;
-	    U8 tmpbuf[UTF8_MAXLEN*2+1];
+	    STRLEN foldlen;
+	    U8 tmpbuf[UTF8_MAXLEN_FOLD+1], *foldbuf;
 
             parse_start = RExC_parse - 1;
 
@@ -2994,6 +3017,8 @@ tryagain:
 		case '\\':
 		    switch (*++p) {
 		    case 'A':
+		    case 'C':
+		    case 'X':
 		    case 'G':
 		    case 'Z':
 		    case 'z':
@@ -3106,16 +3131,30 @@ tryagain:
 		if (RExC_flags16 & PMf_EXTENDED)
 		    p = regwhite(p, RExC_end);
 		if (UTF && FOLD) {
-		    toLOWER_uni(ender, tmpbuf, &ulen);
-		    ender = utf8_to_uvchr(tmpbuf, 0);
+		    /* Prime the casefolded buffer. */
+		    ender = toFOLD_uni(ender, tmpbuf, &foldlen);
 		}
 		if (ISMULT2(p)) { /* Back off on ?+*. */
 		    if (len)
 			p = oldp;
-		    else if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(ender)) && UTF) {
-			reguni(pRExC_state, ender, s, &numlen);
-			s += numlen;
-			len += numlen;
+		    else if (UTF) {
+			 if (FOLD) {
+			      /* Emit all the Unicode characters. */
+			      for (foldbuf = tmpbuf;
+				   foldlen;
+				   foldlen -= numlen) {
+				   ender = utf8_to_uvchr(foldbuf, &numlen);
+				   reguni(pRExC_state, ender, s, &numlen);
+				   s       += numlen;
+				   len     += numlen;
+				   foldbuf += numlen;
+			      }
+			 }
+			 else {
+			      reguni(pRExC_state, ender, s, &numlen);
+			      s   += numlen;
+			      len += numlen;
+			 }
 		    }
 		    else {
 			len++;
@@ -3123,10 +3162,25 @@ tryagain:
 		    }
 		    break;
 		}
-		if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(ender)) && UTF) {
-		    reguni(pRExC_state, ender, s, &numlen);
-		    s += numlen;
-		    len += numlen - 1;
+		if (UTF) {
+		     if (FOLD) {
+		          /* Emit all the Unicode characters. */
+			  for (foldbuf = tmpbuf;
+			       foldlen;
+			       foldlen -= numlen) {
+			       ender = utf8_to_uvchr(foldbuf, &numlen);
+			       reguni(pRExC_state, ender, s, &numlen);
+			       s       += numlen;
+			       len     += numlen;
+			       foldbuf += numlen;
+			  }
+		     }
+		     else {
+			  reguni(pRExC_state, ender, s, &numlen);
+			  s   += numlen;
+			  len += numlen;
+		     }
+		     len--;
 		}
 		else
 		    REGC(ender, s++);
@@ -3155,19 +3209,28 @@ tryagain:
 	break;
     }
 
-    if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT && !RExC_utf8) {
+    /* If the encoding pragma is in effect recode the text of
+     * any EXACT-kind nodes. */
+    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",
-				    oldlen, STRING(ret), 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);
+
+	 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);
@@ -3941,17 +4004,53 @@ 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) {
+			 U8 tmpbuf [UTF8_MAXLEN+1];
+			 U8 foldbuf[UTF8_MAXLEN_FOLD+1];
+			 STRLEN foldlen;
+			 UV f;
+
+			 uvchr_to_utf8(tmpbuf, value);
+			 to_utf8_fold(tmpbuf, foldbuf, &foldlen);
+			 f = utf8_to_uvchr(foldbuf, 0);
+
+			 /* If folding and foldable and a single
+			  * character, insert also the folded version
+			  * to the charclass. */
+			 if (f != value && foldlen == UNISKIP(f))
+			      Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", f);
+
+			 /* If folding and the value is one of the Greek
+			  * sigmas insert a few more sigmas to make the
+			  * folding rules of the sigmas to work right.
+			  * Note that not all the possible combinations
+			  * are handled here: some of them are handled
+			  * handled by the standard folding rules, and
+			  * some of them (literal or EXACTF cases) are
+			  * handled during runtime in
+			  * regexec.c:S_find_byclass(). */
+			 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);
+		    }
+		}
 	    }
         }