Upstream for Math::BigRat is CPAN

[perl5.git] / regcomp.c

diff --git a/regcomp.c b/regcomp.c
index c8c47e9..43b881d 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -3116,7 +3116,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
            }
            flags &= ~SCF_DO_STCLASS;
        }
-       else if (strchr((const char*)PL_varies,OP(scan))) {
+       else if (REGNODE_VARIES(OP(scan))) {
            I32 mincount, maxcount, minnext, deltanext, fl = 0;
            I32 f = flags, pos_before = 0;
            regnode * const oscan = scan;
@@ -3268,7 +3268,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
 
                    /* Skip open. */
                    nxt = regnext(nxt);
-                   if (!strchr((const char*)PL_simple,OP(nxt))
+                   if (!REGNODE_SIMPLE(OP(nxt))
                        && !(PL_regkind[OP(nxt)] == EXACT
                             && STR_LEN(nxt) == 1))
                        goto nogo;
@@ -3316,12 +3316,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
                        nxt = nxt2;
                    OP(nxt2)  = SUCCEED; /* Whas WHILEM */
                    /* Need to optimize away parenths. */
-                   if (data->flags & SF_IN_PAR) {
+                   if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
                        /* Set the parenth number.  */
                        regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
 
-                       if (OP(nxt) != CLOSE)
-                           FAIL("Panic opt close");
                        oscan->flags = (U8)ARG(nxt);
                        if (RExC_open_parens) {
                            RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
@@ -3527,7 +3525,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
                data->longest = &(data->longest_float);
            }
        }
-       else if (strchr((const char*)PL_simple,OP(scan))) {
+       else if (REGNODE_SIMPLE(OP(scan))) {
            int value = 0;
 
            if (flags & SCF_DO_SUBSTR) {
@@ -4604,7 +4602,7 @@ reStudy:
            ri->regstclass = trie_op;
        }
 #endif 
-       else if (strchr((const char*)PL_simple,OP(first)))
+       else if (REGNODE_SIMPLE(OP(first)))
            ri->regstclass = first;
        else if (PL_regkind[OP(first)] == BOUND ||
                 PL_regkind[OP(first)] == NBOUND)
@@ -4945,7 +4943,7 @@ reStudy:
 #endif
 #ifdef DEBUGGING
     if (RExC_paren_names) {
-        ri->name_list_idx = add_data( pRExC_state, 1, "p" );
+        ri->name_list_idx = add_data( pRExC_state, 1, "a" );
         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
     } else
 #endif
@@ -4995,7 +4993,7 @@ Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
     if (flags & RXapif_FETCH) {
         return reg_named_buff_fetch(rx, key, flags);
     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
-        Perl_croak(aTHX_ "%s", PL_no_modify);
+        Perl_croak_no_modify(aTHX);
         return NULL;
     } else if (flags & RXapif_EXISTS) {
         return reg_named_buff_exists(rx, key, flags)
@@ -5295,7 +5293,7 @@ Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
     PERL_UNUSED_ARG(value);
 
     if (!PL_localizing)
-        Perl_croak(aTHX_ "%s", PL_no_modify);
+        Perl_croak_no_modify(aTHX);
 }
 
 I32
@@ -7462,6 +7460,35 @@ tryagain:
                          ender = ASCII_TO_NATIVE('\007');
                        p++;
                        break;
+                   case 'o':
+                       {
+                           STRLEN brace_len = len;
+                           UV result;
+                           const char* error_msg;
+
+                           bool valid = grok_bslash_o(p,
+                                                      &result,
+                                                      &brace_len,
+                                                      &error_msg,
+                                                      1);
+                           p += brace_len;
+                           if (! valid) {
+                               RExC_parse = p; /* going to die anyway; point
+                                                  to exact spot of failure */
+                               vFAIL(error_msg);
+                           }
+                           else
+                           {
+                               ender = result;
+                           }
+                           if (PL_encoding && ender < 0x100) {
+                               goto recode_encoding;
+                           }
+                           if (ender > 0xff) {
+                               RExC_utf8 = 1;
+                           }
+                           break;
+                       }
                    case 'x':
                        if (*++p == '{') {
                            char* const e = strchr(p, '}');
@@ -7500,17 +7527,8 @@ tryagain:
                             I32 flags = 0;
                            STRLEN numlen = 3;
                            ender = grok_oct(p, &numlen, &flags, NULL);
-
-                           /* An octal above 0xff is interpreted differently
-                            * depending on if the re is in utf8 or not.  If it
-                            * is in utf8, the value will be itself, otherwise
-                            * it is interpreted as modulo 0x100.  It has been
-                            * decided to discourage the use of octal above the
-                            * single-byte range.  For now, warn only when
-                            * it ends up modulo */
-                           if (SIZE_ONLY && ender >= 0x100
-                                   && ! UTF && ! PL_encoding) {
-                               ckWARNregdep(p, "Use of octal value above 377 is deprecated");
+                           if (ender > 0xff) {
+                               RExC_utf8 = 1;
                            }
                            p += numlen;
                        }
@@ -8086,6 +8104,24 @@ parseit:
            case 'b':   value = '\b';                   break;
            case 'e':   value = ASCII_TO_NATIVE('\033');break;
            case 'a':   value = ASCII_TO_NATIVE('\007');break;
+           case 'o':
+               RExC_parse--;   /* function expects to be pointed at the 'o' */
+               {
+                   const char* error_msg;
+                   bool valid = grok_bslash_o(RExC_parse,
+                                              &value,
+                                              &numlen,
+                                              &error_msg,
+                                              SIZE_ONLY);
+                   RExC_parse += numlen;
+                   if (! valid) {
+                       vFAIL(error_msg);
+                   }
+               }
+               if (PL_encoding && value < 0x100) {
+                   goto recode_encoding;
+               }
+               break;
            case 'x':
                if (*RExC_parse == '{') {
                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
@@ -9556,6 +9592,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx)
        while (--n >= 0) {
           /* If you add a ->what type here, update the comment in regcomp.h */
            switch (ri->data->what[n]) {
+           case 'a':
            case 's':
            case 'S':
            case 'u':
@@ -9789,8 +9826,9 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
        for (i = 0; i < count; i++) {
            d->what[i] = ri->data->what[i];
            switch (d->what[i]) {
-               /* legal options are one of: sSfpontTu
+               /* legal options are one of: sSfpontTua
                   see also regcomp.h and pregfree() */
+           case 'a': /* actually an AV, but the dup function is identical.  */
            case 's':
            case 'S':
            case 'p': /* actually an AV, but the dup function is identical.  */
@@ -9866,6 +9904,10 @@ Perl_regnext(pTHX_ register regnode *p)
     if (!p)
        return(NULL);
 
+    if (OP(p) > REGNODE_MAX) {         /* regnode.type is unsigned */
+       Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
+    }
+
     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
     if (offset == 0)
        return(NULL);